DPMJET/dpmjet3.0-5.f

   1 *$ CREATE DT_INIT.FOR
   2 *COPY DT_INIT
   3 *
   4 *    +-------------------------------------------------------------+
   5 *    |                                                             |
   6 *    |                                                             |
   7 *    |                        DPMJET 3.0                           |
   8 *    |                                                             |
   9 *    |                                                             |
  10 *    |         S. Roesler+), R. Engel#), J. Ranft*)                |
  11 *    |                                                             |
  12 *    |         +) CERN, SC-RP                                      |
  13 *    |            CH-1211 Geneva 23, Switzerland                   |
  14 *    |            Email: Stefan.Roesler@cern.ch                    |
  15 *    |                                                             |
  16 *    |         #) Institut fuer Kernphysik                         |
  17 *    |            Forschungszentrum Karlsruhe                      |
  18 *    |            D-76021 Karlsruhe, Germany                       |
  19 *    |                                                             |
  20 *    |         *) University of Siegen, Dept. of Physics           |
  21 *    |            D-57068 Siegen, Germany                          |
  22 *    |                                                             |
  23 *    |                                                             |
  24 *    |       http://home.cern.ch/sroesler/dpmjet3.html             |
  25 *    |                                                             |
  26 *    |                                                             |
  27 *    |       Monte Carlo models used for event generation:         |
  28 *    |          PHOJET 1.12, JETSET 7.4 and LEPTO 6.5.1            |
  29 *    |                                                             |
  30 *    +-------------------------------------------------------------+
  31 *
  32 *
  33 *===init===============================================================*
  34 *
  35       SUBROUTINE DT_INIT(NCASES,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
  36      &                                             IDP,IGLAU)
  37
  38 ************************************************************************
  39 * Initialization of event generation                                   *
  40 * This version dated  7.4.98  is written by S. Roesler.                *
  41 *                                                                      *
  42 * Last change 27.12.2006 by S. Roesler.                                *
  43 ************************************************************************
  44
  45       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  46       SAVE
  47
  48       PARAMETER ( LINP = 10 ,
  49      &            LOUT = 6 ,
  50      &            LDAT = 9 )
  51       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
  52
  53 * particle properties (BAMJET index convention)
  54       CHARACTER*8  ANAME
  55       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
  56      &                IICH(210),IIBAR(210),K1(210),K2(210)
  57 * names of hadrons used in input-cards
  58       CHARACTER*8 BTYPE
  59       COMMON /DTPAIN/ BTYPE(30)
  60 * (original name: PAREVT)
  61       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
  62      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
  63       PARAMETER ( NALLWP = 39   )
  64       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
  65      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
  66      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
  67      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
  68 * (original name: INPFLG)
  69       COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
  70 * (original name: FRBKCM)
  71       PARAMETER ( MXFFBK =     6 )
  72       PARAMETER ( MXZFBK =     9 )
  73       PARAMETER ( MXNFBK =    10 )
  74       PARAMETER ( MXAFBK =    16 )
  75       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
  76       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
  77       PARAMETER ( NXAFBK = MXAFBK + 1 )
  78       PARAMETER ( MXPSST =   300 )
  79       PARAMETER ( MXPSFB = 41000 )
  80       LOGICAL LFRMBK, LNCMSS
  81       COMMON /FKFRBK/  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
  82      &          EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
  83      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
  84      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
  85      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
  86      &          IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
  87      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
  88      &          IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
  89      &          IFBFRB, NBUFBK, LFRMBK, LNCMSS
  90       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
  91 * emulsion treatment
  92       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
  93      &                NCOMPO,IEMUL
  94 * Glauber formalism: parameters
  95       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
  96      &                BMAX(NCOMPX),BSTEP(NCOMPX),
  97      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
  98      &                NSITEB,NSTATB
  99 * Glauber formalism: cross sections
 100       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
 101      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
 102      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
 103      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
 104      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
 105      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
 106      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
 107      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
 108      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
 109      &                BSLOPE,NEBINI,NQBINI
 110 * interface HADRIN-DPM
 111       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
 112 * central particle production, impact parameter biasing
 113       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
 114 * parameter for intranuclear cascade
 115       LOGICAL LPAULI
 116       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
 117 * various options for treatment of partons (DTUNUC 1.x)
 118 * (chain recombination, Cronin,..)
 119       LOGICAL LCO2CR,LINTPT
 120       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
 121      &                LCO2CR,LINTPT
 122 * threshold values for x-sampling (DTUNUC 1.x)
 123       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
 124      &                SSMIMQ,VVMTHR
 125 * flags for input different options
 126       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
 127       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
 128      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
 129 * nuclear potential
 130       LOGICAL LFERMI
 131       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
 132      &                EBINDP(2),EBINDN(2),EPOT(2,210),
 133      &                ETACOU(2),ICOUL,LFERMI
 134 * n-n cross section fluctuations
 135       PARAMETER (NBINS = 1000)
 136       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
 137 * flags for particle decays
 138       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
 139      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
 140      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
 141 * diquark-breaking mechanism
 142       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
 143 * nucleon-nucleon event-generator
 144       CHARACTER*8 CMODEL
 145       LOGICAL LPHOIN
 146       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
 147 * properties of interacting particles
 148       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
 149 * properties of photon/lepton projectiles
 150       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
 151 * flags for diffractive interactions (DTUNUC 1.x)
 152       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
 153 * parameters for hA-diffraction
 154       COMMON /DTDIHA/ DIBETA,DIALPH
 155 * Lorentz-parameters of the current interaction
 156       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
 157      &                UMO,PPCM,EPROJ,PPROJ
 158 * kinematical cuts for lepton-nucleus interactions
 159       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
 160      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
 161 * VDM parameter for photon-nucleus interactions
 162       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
 163 * Glauber formalism: flags and parameters for statistics
 164       LOGICAL LPROD
 165       CHARACTER*8 CGLB
 166       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
 167 * cuts for variable energy runs
 168       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
 169 * flags for activated histograms
 170       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
 171       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
 172       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
 173 * LEPTO
 174 **LUND single / double precision
 175       REAL CUT,PARL,TMPX,TMPY,TMPW2,TMPQ2,TMPU
 176       COMMON /LEPTOU/ CUT(14),LST(40),PARL(30),
 177      &                TMPX,TMPY,TMPW2,TMPQ2,TMPU
 178 * LEPTO
 179       REAL RPPN
 180       COMMON /LEPTOI/ RPPN,LEPIN,INTER
 181 * steering flags for qel neutrino scattering modules
 182       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
 183 * event flag
 184       COMMON /DTEVNO/ NEVENT,ICASCA
 185
 186       INTEGER PYCOMP
 187
 188 C     DIMENSION XPARA(5)
 189       DIMENSION XDUMB(40),IPRANG(5)
 190
 191       PARAMETER (MXCARD=58)
 192       CHARACTER*78 CLINE,CTITLE
 193       CHARACTER*60 CWHAT
 194       CHARACTER*8  BLANK,SDUM
 195       CHARACTER*10 CODE,CODEWD
 196       CHARACTER*72 HEADER
 197       LOGICAL LSTART,LEINP,LXSTAB
 198       DIMENSION WHAT(6),CODE(MXCARD)
 199       DATA CODE/
 200      &   'TITLE     ','PROJPAR   ','TARPAR    ','ENERGY    ',
 201      &   'MOMENTUM  ','CMENERGY  ','EMULSION  ','FERMI     ',
 202      &   'TAUFOR    ','PAULI     ','COULOMB   ','HADRIN    ',
 203      &   'EVAP      ','EMCCHECK  ','MODEL     ','PHOINPUT  ',
 204      &   'GLAUBERI  ','FLUCTUAT  ','CENTRAL   ','RECOMBIN  ',
 205      &   'COMBIJET  ','XCUTS     ','INTPT     ','CRONINPT  ',
 206      &   'SEADISTR  ','SEASU3    ','DIQUARKS  ','RESONANC  ',
 207      &   'DIFFRACT  ','SINGLECH  ','NOFRAGME  ','HADRONIZE ',
 208      &   'POPCORN   ','PARDECAY  ','BEAM      ','LUND-MSTU ',
 209      &   'LUND-MSTJ ','LUND-MDCY ','LUND-PARJ ','LUND-PARU ',
 210      &   'OUTLEVEL  ','FRAME     ','L-TAG     ','L-ETAG    ',
 211      &   'ECMS-CUT  ','VDM-PAR1  ','HISTOGRAM ','XS-TABLE  ',
 212      &   'GLAUB-PAR ','GLAUB-INI ','VDM-PAR2  ','XS-QELPRO ',
 213      &   'RNDMINIT  ','LEPTO-CUT ','LEPTO-LST ','LEPTO-PARL',
 214      &   'START     ','STOP      '/
 215       DATA BLANK /'        '/
 216
 217       DATA LSTART,LXSTAB,IFIRST /.TRUE.,.FALSE.,1/
 218       DATA CMEOLD /0.0D0/
 219
 220 *---------------------------------------------------------------------
 221 * at the first call of INIT: initialize event generation
 222       EPNSAV = EPN
 223       IF (LSTART) THEN
 224          CALL DT_TITLE
 225 *   initialization and test of the random number generator
 226          IF (ITRSPT.NE.1) THEN
 227             CALL DT_RNDMST(22,54,76,92)
 228             CALL DT_RNDMTE(1)
 229          ENDIF
 230 *   initialization of BAMJET, DECAY and HADRIN
 231          CALL DT_DDATAR
 232          CALL DT_DHADDE
 233          CALL DT_DCHANT
 234          CALL DT_DCHANH
 235 *   set default values for input variables
 236          CALL DT_DEFAUL(EPN,PPN)
 237          IGLAU  = 0
 238          IXSQEL = 0
 239 *   flag for collision energy input
 240          LEINP  = .FALSE.
 241          LSTART = .FALSE.
 242       ENDIF
 243
 244 *---------------------------------------------------------------------
 245    10 CONTINUE
 246
 247 * bypass reading input cards (e.g. for use with Fluka)
 248 *  in this case Epn is expected to carry the beam momentum
 249       IF (NCASES.EQ.-1) THEN
 250          IP      = NPMASS
 251          IPZ     = NPCHAR
 252          PPN     = EPNSAV
 253          EPN     = ZERO
 254          CMENER  = ZERO
 255          LEINP   = .TRUE.
 256          MKCRON  = 0
 257          WHAT(1) = 1
 258          WHAT(2) = 0
 259          CODEWD  = 'START     '
 260          GOTO 900
 261       ENDIF
 262
 263 * read control card from input-unit LINP
 264       READ(LINP,'(A78)',END=9999) CLINE
 265       IF (CLINE(1:1).EQ.'*') THEN
 266 * comment-line
 267          WRITE(LOUT,'(A78)') CLINE
 268          GOTO 10
 269       ENDIF
 270 C     READ(CLINE,1000,END=9999) CODEWD,(WHAT(I),I=1,6),SDUM
 271 C1000 FORMAT(A10,6E10.0,A8)
 272       DO 1008 I=1,6
 273          WHAT(I) = ZERO
 274  1008 CONTINUE
 275       READ(CLINE,1006,END=9999) CODEWD,CWHAT,SDUM
 276  1006 FORMAT(A10,A60,A8)
 277       READ(CWHAT,*,END=1007) (WHAT(I),I=1,6)
 278  1007 CONTINUE
 279       WRITE(LOUT,1001) CODEWD,(WHAT(I),I=1,6),SDUM
 280  1001 FORMAT(A10,6G10.3,A8)
 281
 282   900 CONTINUE
 283
 284 * check for valid control card and get card index
 285       ICW = 0
 286       DO 11 I=1,MXCARD
 287          IF (CODEWD.EQ.CODE(I)) ICW = I
 288    11 CONTINUE
 289       IF (ICW.EQ.0) THEN
 290          WRITE(LOUT,1002) CODEWD
 291  1002    FORMAT(/,1X,'---> ',A10,': invalid control-card !',/)
 292          GOTO 10
 293       ENDIF
 294
 295       GOTO(
 296 *------------------------------------------------------------
 297 *       TITLE   ,  PROJPAR ,  TARPAR  ,  ENERGY  ,  MOMENTUM,
 298      &  100     ,  110     ,  120     ,  130     ,  140     ,
 299 *
 300 *------------------------------------------------------------
 301 *       CMENERGY,  EMULSION,  FERMI   ,  TAUFOR  ,  PAULI   ,
 302      &  150     ,  160     ,  170     ,  180     ,  190     ,
 303 *
 304 *------------------------------------------------------------
 305 *       COULOMB ,  HADRIN  ,  EVAP    ,  EMCCHECK,  MODEL   ,
 306      &  200     ,  210     ,  220     ,  230     ,  240     ,
 307 *
 308 *------------------------------------------------------------
 309 *       PHOINPUT,  GLAUBERI,  FLUCTUAT,  CENTRAL ,  RECOMBIN,
 310      &  250     ,  260     ,  270     ,  280     ,  290     ,
 311 *
 312 *------------------------------------------------------------
 313 *       COMBIJET,  XCUTS   ,  INTPT   ,  CRONINPT,  SEADISTR,
 314      &  300     ,  310     ,  320     ,  330     ,  340     ,
 315 *
 316 *------------------------------------------------------------
 317 *       SEASU3  ,  DIQUARKS,  RESONANC,  DIFFRACT,  SINGLECH,
 318      &  350     ,  360     ,  370     ,  380     ,  390     ,
 319 *
 320 *------------------------------------------------------------
 321 *       NOFRAGME, HADRONIZE,  POPCORN ,  PARDECAY,  BEAM    ,
 322      &  400     ,  410     ,  420     ,  430     ,  440     ,
 323 *
 324 *------------------------------------------------------------
 325 *      LUND-MSTU, LUND-MSTJ, LUND-MDCY, LUND-PARJ, LUND-PARU,
 326      &  450     ,  451     ,  452     ,  460     ,  470     ,
 327 *
 328 *------------------------------------------------------------
 329 *       OUTLEVEL,  FRAME   , L-TAG    ,  L-ETAG  ,  ECMS-CUT,
 330      &  480     ,  490     ,  500     ,  510     ,  520     ,
 331 *
 332 *------------------------------------------------------------
 333 *       VDM-PAR1, HISTOGRAM, XS-TABLE , GLAUB-PAR, GLAUB-INI,
 334      &  530     ,  540     ,  550     ,  560     ,  565     ,
 335 *
 336 *------------------------------------------------------------
 337 *               ,          ,  VDM-PAR2, XS-QELPRO, RNDMINIT ,
 338      &                        570     ,  580     ,  590     ,
 339 *
 340 *------------------------------------------------------------
 341 *      LEPTO-CUT, LEPTO-LST,LEPTO-PARL,  START   ,  STOP    )
 342      &  600     ,  610     ,  620     ,  630     ,  640     ) , ICW
 343 *
 344 *------------------------------------------------------------
 345
 346       GOTO 10
 347
 348 *********************************************************************
 349 *                                                                   *
 350 *               control card:  codewd = TITLE                       *
 351 *                                                                   *
 352 *       what (1..6), sdum   no meaning                              *
 353 *                                                                   *
 354 *       Note:  The control-card following this must consist of      *
 355 *              a string of characters usually giving the title of   *
 356 *              the run.                                             *
 357 *                                                                   *
 358 *********************************************************************
 359
 360   100 CONTINUE
 361       READ(LINP,'(A78)') CTITLE
 362       WRITE(LOUT,'(//,5X,A78,//)') CTITLE
 363       GOTO 10
 364
 365 *********************************************************************
 366 *                                                                   *
 367 *               control card:  codewd = PROJPAR                     *
 368 *                                                                   *
 369 *       what (1) =  mass number of projectile nucleus  default: 1   *
 370 *       what (2) =  charge of projectile nucleus       default: 1   *
 371 *       what (3..6)   no meaning                                    *
 372 *       sdum        projectile particle code word                   *
 373 *                                                                   *
 374 *       Note: If sdum is defined what (1..2) have no meaning.       *
 375 *                                                                   *
 376 *********************************************************************
 377
 378   110 CONTINUE
 379       IF (SDUM.EQ.BLANK) THEN
 380          IP     = INT(WHAT(1))
 381          IPZ    = INT(WHAT(2))
 382          IJPROJ = 1
 383          IBPROJ = 1
 384       ELSE
 385          IJPROJ = 0
 386          DO 111 II=1,30
 387             IF (SDUM.EQ.BTYPE(II)) THEN
 388                IP     = 1
 389                IPZ    = 1
 390                IF (II.EQ.26) THEN
 391                   IJPROJ = 135
 392                ELSEIF (II.EQ.27) THEN
 393                   IJPROJ = 136
 394                ELSEIF (II.EQ.28) THEN
 395                   IJPROJ = 133
 396                ELSEIF (II.EQ.29) THEN
 397                   IJPROJ = 134
 398                ELSE
 399                   IJPROJ = II
 400                ENDIF
 401                IBPROJ = IIBAR(IJPROJ)
 402 * photon
 403                IF ((IJPROJ.EQ.7).AND.(WHAT(1).GT.ZERO)) VIRT = WHAT(1)
 404 * lepton
 405                IF (((IJPROJ.EQ. 3).OR.(IJPROJ.EQ. 4).OR.
 406      &              (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11)).AND.
 407      &                              (WHAT(1).GT.ZERO)) Q2HI = WHAT(1)
 408             ENDIF
 409   111    CONTINUE
 410          IF (IJPROJ.EQ.0) THEN
 411             WRITE(LOUT,1110)
 412  1110       FORMAT(/,1X,'invalid PROJPAR card !',/)
 413             GOTO 9999
 414          ENDIF
 415       ENDIF
 416       GOTO 10
 417
 418 *********************************************************************
 419 *                                                                   *
 420 *               control card:  codewd = TARPAR                      *
 421 *                                                                   *
 422 *       what (1) =  mass number of target nucleus      default: 1   *
 423 *       what (2) =  charge of target nucleus           default: 1   *
 424 *       what (3..6)   no meaning                                    *
 425 *       sdum        target particle code word                       *
 426 *                                                                   *
 427 *       Note: If sdum is defined what (1..2) have no meaning.       *
 428 *                                                                   *
 429 *********************************************************************
 430
 431   120 CONTINUE
 432       IF (SDUM.EQ.BLANK) THEN
 433          IT     = INT(WHAT(1))
 434          ITZ    = INT(WHAT(2))
 435          IJTARG = 1
 436          IBTARG = 1
 437       ELSE
 438          IJTARG = 0
 439          DO 121 II=1,30
 440             IF (SDUM.EQ.BTYPE(II)) THEN
 441                IT     = 1
 442                ITZ    = 1
 443                IJTARG = II
 444                IBTARG = IIBAR(IJTARG)
 445             ENDIF
 446   121    CONTINUE
 447          IF (IJTARG.EQ.0) THEN
 448             WRITE(LOUT,1120)
 449  1120       FORMAT(/,1X,'invalid TARPAR card !',/)
 450             GOTO 9999
 451          ENDIF
 452       ENDIF
 453       GOTO 10
 454
 455 *********************************************************************
 456 *                                                                   *
 457 *               control card:  codewd = ENERGY                      *
 458 *                                                                   *
 459 *       what (1) =  energy (GeV) of projectile in Lab.              *
 460 *                   if what(1) < 0:  |what(1)| = kinetic energy     *
 461 *                                                default: 200 GeV   *
 462 *                   if |what(2)| > 0: min. energy for variable      *
 463 *                                     energy runs                   *
 464 *       what (2) =  max. energy for variable energy runs            *
 465 *                   if what(2) < 0:  |what(2)| = kinetic energy     *
 466 *                                                                   *
 467 *********************************************************************
 468
 469   130 CONTINUE
 470       EPN    = WHAT(1)
 471       PPN    = ZERO
 472       CMENER = ZERO
 473       IF ((ABS(WHAT(2)).GT.ZERO).AND.
 474      &    (ABS(WHAT(2)).GT.ABS(WHAT(1)))) THEN
 475          VARELO = WHAT(1)
 476          VAREHI = WHAT(2)
 477          EPN    = VAREHI
 478       ENDIF
 479       LEINP  = .TRUE.
 480       GOTO 10
 481
 482 *********************************************************************
 483 *                                                                   *
 484 *               control card:  codewd = MOMENTUM                    *
 485 *                                                                   *
 486 *       what (1) =  momentum (GeV/c) of projectile in Lab.          *
 487 *                                                default: 200 GeV/c *
 488 *       what (2..6), sdum   no meaning                              *
 489 *                                                                   *
 490 *********************************************************************
 491
 492   140 CONTINUE
 493       EPN    = ZERO
 494       PPN    = WHAT(1)
 495       CMENER = ZERO
 496       LEINP  = .TRUE.
 497       GOTO 10
 498
 499 *********************************************************************
 500 *                                                                   *
 501 *               control card:  codewd = CMENERGY                    *
 502 *                                                                   *
 503 *       what (1) =  energy in nucleon-nucleon cms.                  *
 504 *                                                default: none      *
 505 *       what (2..6), sdum   no meaning                              *
 506 *                                                                   *
 507 *********************************************************************
 508
 509   150 CONTINUE
 510       EPN    = ZERO
 511       PPN    = ZERO
 512       CMENER = WHAT(1)
 513       LEINP  = .TRUE.
 514       GOTO 10
 515
 516 *********************************************************************
 517 *                                                                   *
 518 *               control card:  codewd = EMULSION                    *
 519 *                                                                   *
 520 *               definition of nuclear emulsions                     *
 521 *                                                                   *
 522 *     what(1)      mass number of emulsion component                *
 523 *     what(2)      charge of emulsion component                     *
 524 *     what(3)      fraction of events in which a scattering on a    *
 525 *                  nucleus of this properties is performed          *
 526 *     what(4,5,6)  as what(1,2,3) but for another component         *
 527 *                                             default: no emulsion  *
 528 *     sdum         no meaning                                       *
 529 *                                                                   *
 530 *     Note: If this input-card is once used with valid parameters   *
 531 *           TARPAR is obsolete.                                     *
 532 *           Not the absolute values of the fractions are important  *
 533 *           but only the ratios of fractions of different comp.     *
 534 *           This control card can be repeatedly used to define      *
 535 *           emulsions consisting of up to 10 elements.              *
 536 *                                                                   *
 537 *********************************************************************
 538
 539   160 CONTINUE
 540       IF ((WHAT(1).GT.ZERO).AND.(WHAT(2).GT.ZERO)
 541      &                     .AND.(ABS(WHAT(3)).GT.ZERO)) THEN
 542          NCOMPO = NCOMPO+1
 543          IF (NCOMPO.GT.NCOMPX) THEN
 544             WRITE(LOUT,1600)
 545             STOP
 546          ENDIF
 547          IEMUMA(NCOMPO) = INT(WHAT(1))
 548          IEMUCH(NCOMPO) = INT(WHAT(2))
 549          EMUFRA(NCOMPO) = WHAT(3)
 550          IEMUL = 1
 551 C        CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
 552       ENDIF
 553       IF ((WHAT(4).GT.ZERO).AND.(WHAT(5).GT.ZERO)
 554      &                     .AND.(ABS(WHAT(6)).GT.ZERO)) THEN
 555          NCOMPO = NCOMPO+1
 556          IF (NCOMPO.GT.NCOMPX) THEN
 557             WRITE(LOUT,1001)
 558             STOP
 559          ENDIF
 560          IEMUMA(NCOMPO) = INT(WHAT(4))
 561          IEMUCH(NCOMPO) = INT(WHAT(5))
 562          EMUFRA(NCOMPO) = WHAT(6)
 563 C        CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
 564       ENDIF
 565  1600 FORMAT(1X,'too many emulsion components - program stopped')
 566       GOTO 10
 567
 568 *********************************************************************
 569 *                                                                   *
 570 *               control card:  codewd = FERMI                       *
 571 *                                                                   *
 572 *       what (1) = -1 Fermi-motion of nucleons not treated          *
 573 *                                                 default: 1        *
 574 *       what (2) =    scale factor for Fermi-momentum               *
 575 *                                                 default: 0.75     *
 576 *       what (3..6), sdum   no meaning                              *
 577 *                                                                   *
 578 *********************************************************************
 579
 580   170 CONTINUE
 581       IF (WHAT(1).EQ.-1.0D0) THEN
 582          LFERMI = .FALSE.
 583       ELSE
 584          LFERMI = .TRUE.
 585       ENDIF
 586       XMOD = WHAT(2)
 587       IF (XMOD.GE.ZERO) FERMOD = XMOD
 588       GOTO 10
 589
 590 *********************************************************************
 591 *                                                                   *
 592 *               control card:  codewd = TAUFOR                      *
 593 *                                                                   *
 594 *          formation time supressed intranuclear cascade            *
 595 *                                                                   *
 596 *    what (1)      formation time (in fm/c)                         *
 597 *                  note: what(1)=10. corresponds roughly to an      *
 598 *                        average formation time of 1 fm/c           *
 599 *                                                 default: 5. fm/c  *
 600 *    what (2)      number of generations followed                   *
 601 *                                                 default: 25       *
 602 *    what (3) = 1. p_t-dependent formation zone                     *
 603 *             = 2. constant formation zone                          *
 604 *                                                 default: 1        *
 605 *    what (4)      modus of selection of nucleus where the          *
 606 *                  cascade if followed first                        *
 607 *             = 1.  proj./target-nucleus with probab. 1/2           *
 608 *             = 2.  nucleus with highest mass                       *
 609 *             = 3.  proj. nucleus if particle is moving in pos. z   *
 610 *                   targ. nucleus if particle is moving in neg. z   *
 611 *                                                 default: 1        *
 612 *    what (5..6), sdum   no meaning                                 *
 613 *                                                                   *
 614 *********************************************************************
 615
 616   180 CONTINUE
 617       TAUFOR = WHAT(1)
 618       KTAUGE = INT(WHAT(2))
 619       INCMOD = 1
 620       IF ((WHAT(3).GE.1.0D0).AND.(WHAT(3).LE.2.0D0))
 621      &                                    ITAUVE = INT(WHAT(3))
 622       IF ((WHAT(4).GE.1.0D0).AND.(WHAT(4).LE.3.0D0))
 623      &                                    INCMOD = INT(WHAT(4))
 624       GOTO 10
 625
 626 *********************************************************************
 627 *                                                                   *
 628 *               control card:  codewd = PAULI                       *
 629 *                                                                   *
 630 *       what (1) =  -1  Pauli's principle for secondary             *
 631 *                       interactions not treated                    *
 632 *                                                    default: 1     *
 633 *       what (2..6), sdum   no meaning                              *
 634 *                                                                   *
 635 *********************************************************************
 636
 637   190 CONTINUE
 638       IF (WHAT(1).EQ.-1.0D0) THEN
 639          LPAULI = .FALSE.
 640       ELSE
 641          LPAULI = .TRUE.
 642       ENDIF
 643       GOTO 10
 644
 645 *********************************************************************
 646 *                                                                   *
 647 *               control card:  codewd = COULOMB                     *
 648 *                                                                   *
 649 *       what (1) = -1. Coulomb-energy treatment switched off        *
 650 *                                                    default: 1     *
 651 *       what (2..6), sdum   no meaning                              *
 652 *                                                                   *
 653 *********************************************************************
 654
 655   200 CONTINUE
 656       ICOUL = 1
 657       IF (WHAT(1).EQ.-1.0D0) THEN
 658          ICOUL = 0
 659       ELSE
 660          ICOUL = 1
 661       ENDIF
 662       GOTO 10
 663
 664 *********************************************************************
 665 *                                                                   *
 666 *               control card:  codewd = HADRIN                      *
 667 *                                                                   *
 668 *                       HADRIN module                               *
 669 *                                                                   *
 670 *    what (1) = 0. elastic/inelastic interactions with probab.      *
 671 *                  as defined by cross-sections                     *
 672 *             = 1. inelastic interactions forced                    *
 673 *             = 2. elastic interactions forced                      *
 674 *                                                 default: 1        *
 675 *    what (2)      upper threshold in total energy (GeV) below      *
 676 *                  which interactions are sampled by HADRIN         *
 677 *                                                 default: 5. GeV   *
 678 *    what (3..6), sdum   no meaning                                 *
 679 *                                                                   *
 680 *********************************************************************
 681
 682   210 CONTINUE
 683       IWHAT = INT(WHAT(1))
 684       IF ((IWHAT.GE.0).AND.(IWHAT.LE.2)) INTHAD = IWHAT
 685       IF ((WHAT(2).GT.ZERO).AND.(WHAT(2).LT.15.0D0)) EHADTH = WHAT(2)
 686       GOTO 10
 687
 688 *********************************************************************
 689 *                                                                   *
 690 *               control card:  codewd = EVAP                        *
 691 *                                                                   *
 692 *                    evaporation module                             *
 693 *                                                                   *
 694 *  what (1) =< -1 ==> evaporation is switched off                   *
 695 *           >=  1 ==> evaporation is performed                      *
 696 *                                                                   *
 697 *         what (1) = i1 + i2*10 + i3*100 + i4*10000                 *
 698 *                    (i1, i2, i3, i4 >= 0 )                         *
 699 *                                                                   *
 700 *   i1 is the flag for selecting the T=0 level density option used  *
 701 *      =  1: standard EVAP level densities with Cook pairing        *
 702 *            energies                                               *
 703 *      =  2: Z,N-dependent Gilbert & Cameron level densities        *
 704 *                                                        (default)  *
 705 *      =  3: Julich A-dependent level densities                     *
 706 *      =  4: Z,N-dependent Brancazio & Cameron level densities      *
 707 *                                                                   *
 708 *   i2 >= 1: high energy fission activated                          *
 709 *            (default high energy fission activated)                *
 710 *                                                                   *
 711 *   i3 =  0: No energy dependence for level densities               *
 712 *      =  1: Standard Ignyatuk (1975, 1st) energy dependence        *
 713 *            for level densities (default)                          *
 714 *      =  2: Standard Ignyatuk (1975, 1st) energy dependence        *
 715 *            for level densities with NOT used set of parameters    *
 716 *      =  3: Standard Ignyatuk (1975, 1st) energy dependence        *
 717 *            for level densities with NOT used set of parameters    *
 718 *      =  4: Second   Ignyatuk (1975, 2nd) energy dependence        *
 719 *            for level densities                                    *
 720 *      =  5: Second   Ignyatuk (1975, 2nd) energy dependence        *
 721 *            for level densities with fit 1 Iljinov & Mebel set of  *
 722 *            parameters                                             *
 723 *      =  6: Second   Ignyatuk (1975, 2nd) energy dependence        *
 724 *            for level densities with fit 2 Iljinov & Mebel set of  *
 725 *            parameters                                             *
 726 *      =  7: Second   Ignyatuk (1975, 2nd) energy dependence        *
 727 *            for level densities with fit 3 Iljinov & Mebel set of  *
 728 *            parameters                                             *
 729 *      =  8: Second   Ignyatuk (1975, 2nd) energy dependence        *
 730 *            for level densities with fit 4 Iljinov & Mebel set of  *
 731 *            parameters                                             *
 732 *                                                                   *
 733 *   i4 >= 1: Original Gilbert and Cameron pairing energies used     *
 734 *            (default Cook's modified pairing energies)             *
 735 *                                                                   *
 736 *  what (2) = ig + 10 * if   (ig and if must have the same sign)    *
 737 *                                                                   *
 738 *   ig =< -1 ==> deexcitation gammas are not produced               *
 739 *                (if the evaporation step is not performed          *
 740 *                 they are never produced)                          *
 741 *   if =< -1 ==> Fermi Break Up is not invoked                      *
 742 *                (if the evaporation step is not performed          *
 743 *                 it is never invoked)                              *
 744 *   The default is: deexcitation gamma produced and Fermi break up  *
 745 *                   activated for the new  preequilibrium, not      *
 746 *                   activated otherwise.                            *
 747 *  what (3..6), sdum   no meaning                                   *
 748 *                                                                   *
 749 *********************************************************************
 750
 751  220  CONTINUE
 752       WRITE(LOUT,1009)
 753  1009 FORMAT(1X,/,'Warning!  Evaporation request rejected since',
 754      &       ' evaporation modules not available with this version.')
 755       LEVPRT = .FALSE.
 756       LDEEXG = .FALSE.
 757       LHEAVY = .FALSE.
 758       LFRMBK = .FALSE.
 759       IFISS  = 0
 760       IEVFSS = 0
 761
 762       GOTO 10
 763
 764 *********************************************************************
 765 *                                                                   *
 766 *               control card:  codewd = EMCCHECK                    *
 767 *                                                                   *
 768 *    extended energy-momentum / quantum-number conservation check   *
 769 *                                                                   *
 770 *       what (1) = -1   extended check not performed                *
 771 *                                                    default: 1.    *
 772 *       what (2..6), sdum   no meaning                              *
 773 *                                                                   *
 774 *********************************************************************
 775
 776   230 CONTINUE
 777       IF (WHAT(1).EQ.-1) THEN
 778          LEMCCK = .FALSE.
 779       ELSE
 780          LEMCCK = .TRUE.
 781       ENDIF
 782       GOTO 10
 783
 784 *********************************************************************
 785 *                                                                   *
 786 *               control card:  codewd = MODEL                       *
 787 *                                                                   *
 788 *     Model to be used to treat nucleon-nucleon interactions        *
 789 *                                                                   *
 790 *       sdum = DTUNUC    two-chain model                            *
 791 *            = PHOJET    multiple chains including minijets         *
 792 *            = LEPTO     DIS                                        *
 793 *            = QNEUTRIN  quasi-elastic neutrino scattering          *
 794 *                                                  default: PHOJET  *
 795 *                                                                   *
 796 *       if sdum = LEPTO:                                            *
 797 *       what (1)         (variable INTER)                           *
 798 *                        = 1  gamma exchange                        *
 799 *                        = 2  W+-   exchange                        *
 800 *                        = 3  Z0    exchange                        *
 801 *                        = 4  gamma/Z0 exchange                     *
 802 *                                                                   *
 803 *       if sdum = QNEUTRIN:                                         *
 804 *       what (1)         = 0  elastic scattering on nucleon and     *
 805 *                             tau does not decay (default)          *
 806 *                        = 1  decay of tau into mu..                *
 807 *                        = 2  decay of tau into e..                 *
 808 *                        = 10 CC events on p and n                  *
 809 *                        = 11 NC events on p and n                  *
 810 *                                                                   *
 811 *       what (2..6)      no meaning                                 *
 812 *                                                                   *
 813 *********************************************************************
 814
 815   240 CONTINUE
 816       IF (SDUM.EQ.CMODEL(1)) THEN
 817          MCGENE = 1
 818       ELSEIF (SDUM.EQ.CMODEL(2)) THEN
 819          MCGENE = 2
 820       ELSEIF (SDUM.EQ.CMODEL(3)) THEN
 821          MCGENE = 3
 822          IF ((WHAT(1).GE.1.0D0).AND.(WHAT(1).LE.4.0D0))
 823      &      INTER = INT(WHAT(1))
 824       ELSEIF (SDUM.EQ.CMODEL(4)) THEN
 825          MCGENE = 4
 826          IWHAT  = INT(WHAT(1))
 827          IF ((IWHAT.EQ.1 ).OR.(IWHAT.EQ.2 ).OR.
 828      &       (IWHAT.EQ.10).OR.(IWHAT.EQ.11))
 829      &      NEUDEC = IWHAT
 830       ELSE
 831          STOP ' Unknown model !'
 832       ENDIF
 833       GOTO 10
 834
 835 *********************************************************************
 836 *                                                                   *
 837 *               control card:  codewd = PHOINPUT                    *
 838 *                                                                   *
 839 *       Start of input-section for PHOJET-specific input-cards      *
 840 *       Note:  This section will not be finished before giving      *
 841 *              ENDINPUT-card                                        *
 842 *       what (1..6), sdum   no meaning                              *
 843 *                                                                   *
 844 *********************************************************************
 845
 846   250 CONTINUE
 847       IF (LPHOIN) THEN
 848          CALL PHO_INIT(LINP,LOUT,IREJ1)
 849          IF (IREJ1.NE.0) THEN
 850             WRITE(LOUT,'(1X,A)')'INIT:   reading PHOJET-input failed'
 851             STOP
 852          ENDIF
 853          LPHOIN = .FALSE.
 854       ENDIF
 855       GOTO 10
 856
 857 *********************************************************************
 858 *                                                                   *
 859 *               control card:  codewd = GLAUBERI                    *
 860 *                                                                   *
 861 *        Pre-initialization of impact parameter selection           *
 862 *                                                                   *
 863 *        what (1..6), sdum   no meaning                             *
 864 *                                                                   *
 865 *********************************************************************
 866
 867   260 CONTINUE
 868       IF (IFIRST.NE.99) THEN
 869          CALL DT_RNDMST(12,34,56,78)
 870          CALL DT_RNDMTE(1)
 871          OPEN(40,FILE='outdata0/shm.out',STATUS='UNKNOWN')
 872 C        OPEN(11,FILE='outdata0/shm.dbg',STATUS='UNKNOWN')
 873          IFIRST = 99
 874       ENDIF
 875
 876       IPPN = 8
 877       PLOW = 10.0D0
 878 C     IPPN = 1
 879 C     PLOW = 100.0D0
 880       PHI  = 1.0D5
 881       APLOW = LOG10(PLOW)
 882       APHI  = LOG10(PHI)
 883       ADP   = (APHI-APLOW)/DBLE(IPPN)
 884
 885       IPLOW = 1
 886       IDIP  = 1
 887       IIP   = 5
 888 C     IPLOW = 1
 889 C     IDIP  = 1
 890 C     IIP   = 1
 891       IPRANG(1) = 1
 892       IPRANG(2) = 2
 893       IPRANG(3) = 5
 894       IPRANG(4) = 10
 895       IPRANG(5) = 20
 896
 897       ITLOW = 30
 898       IDIT  = 3
 899       IIT   = 60
 900 C     IDIT  = 10
 901 C     IIT   = 21
 902
 903       DO 473 NCIT=1,IIT
 904          IT   = ITLOW+(NCIT-1)*IDIT
 905 C        IPHI = IT
 906 C        IDIP = 10
 907 C        IIP  = (IPHI-IPLOW)/IDIP
 908 C        IF (IIP.EQ.0) IIP = 1
 909 C        IF (IT.EQ.IPLOW) IIP = 0
 910
 911          DO 472 NCIP=1,IIP
 912             IP = IPRANG(NCIP)
 913 CC           IF (NCIP.LE.IIP) THEN
 914 C               IP = IPLOW+(NCIP-1)*IDIP
 915 CC           ELSE
 916 CC              IP = IT
 917 CC           ENDIF
 918             IF (IP.GT.IT) GOTO 472
 919
 920             DO 471 NCP=1,IPPN+1
 921                APPN = APLOW+DBLE(NCP-1)*ADP
 922                PPN  = 10**APPN
 923
 924                OPEN(12,FILE='outdata0/shm.sta',STATUS='UNKNOWN')
 925                WRITE(12,'(1X,2I5,E15.3)') IP,IT,PPN
 926                CLOSE(12)
 927
 928                XLIM1 = 0.0D0
 929                XLIM2 = 50.0D0
 930                XLIM3 = ZERO
 931                IBIN  = 50
 932                CALL DT_NEWHGR(XDUM,XDUM,XDUM,XDUMB,-1,IHDUM)
 933                CALL DT_NEWHGR(XLIM1,XLIM2,XLIM3,XDUMB,IBIN,IHSHMA)
 934
 935                NEVFIT = 5
 936 C              IF ((IP.GT.10).OR.(IT.GT.10)) THEN
 937 C                 NEVFIT = 5
 938 C              ELSE
 939 C                 NEVFIT = 10
 940 C              ENDIF
 941                SIGAV  = 0.0D0
 942
 943                DO 478 I=1,NEVFIT
 944                   CALL DT_SHMAKI(IP,IDUM1,IT,IDUM1,IJPROJ,PPN,99)
 945                   SIGAV = SIGAV+XSPRO(1,1,1)
 946                   DO 479 J=1,50
 947                      XC = DBLE(J)
 948                      CALL DT_FILHGR(XC,BSITE(1,1,1,J),IHSHMA,I)
 949   479             CONTINUE
 950   478          CONTINUE
 951
 952                CALL DT_EVTHIS(IDUM)
 953                HEADER = ' BSITE'
 954 C              CALL OUTGEN(IHSHMA,0,0,0,0,0,HEADER,0,NEVFIT,ONE,0,1,-1)
 955
 956 C              CALL GENFIT(XPARA)
 957 C              WRITE(40,'(2I4,E11.3,F6.0,5E11.3)')
 958 C    &              IP,IT,PPN,SIGAV/DBLE(NEVFIT),XPARA
 959
 960   471       CONTINUE
 961
 962   472    CONTINUE
 963
 964   473 CONTINUE
 965
 966       STOP
 967
 968 *********************************************************************
 969 *                                                                   *
 970 *               control card:  codewd = FLUCTUAT                    *
 971 *                                                                   *
 972 *           Treatment of cross section fluctuations                 *
 973 *                                                                   *
 974 *       what (1) = 1  treat cross section fluctuations              *
 975 *                                                    default: 0.    *
 976 *       what (1..6), sdum   no meaning                              *
 977 *                                                                   *
 978 *********************************************************************
 979
 980  270  CONTINUE
 981       IFLUCT = 0
 982       IF (WHAT(1).EQ.ONE) THEN
 983          IFLUCT = 1
 984          CALL DT_FLUINI
 985       ENDIF
 986       GOTO 10
 987
 988 *********************************************************************
 989 *                                                                   *
 990 *               control card:  codewd = CENTRAL                     *
 991 *                                                                   *
 992 *       what (1) = 1.  central production forced     default: 0     *
 993 *  if what (1) < 0 and > -100                                       *
 994 *       what (2) = min. impact parameter             default: 0     *
 995 *       what (3) = max. impact parameter             default: b_max *
 996 *  if what (1) < -99                                                *
 997 *       what (2) = fraction of cross section         default: 1     *
 998 *  if what (1) = -1 : evaporation/fzc suppressed                    *
 999 *  if what (1) < -1 : evaporation/fzc allowed                       *
1000 *                                                                   *
1001 *       what (4..6), sdum   no meaning                              *
1002 *                                                                   *
1003 *********************************************************************
1004
1005   280 CONTINUE
1006       ICENTR = INT(WHAT(1))
1007       IF (ICENTR.LT.0) THEN
1008          IF (ICENTR.GT.-100) THEN
1009             BIMIN = WHAT(2)
1010             BIMAX = WHAT(3)
1011          ELSE
1012             XSFRAC = WHAT(2)
1013          ENDIF
1014       ENDIF
1015       GOTO 10
1016
1017 *********************************************************************
1018 *                                                                   *
1019 *               control card:  codewd = RECOMBIN                    *
1020 *                                                                   *
1021 *                     Chain recombination                           *
1022 *        (recombine S-S and V-V chains to V-S chains)               *
1023 *                                                                   *
1024 *       what (1) = -1. recombination switched off    default: 1     *
1025 *       what (2..6), sdum   no meaning                              *
1026 *                                                                   *
1027 *********************************************************************
1028
1029   290 CONTINUE
1030       IRECOM = 1
1031       IF (WHAT(1).EQ.-1.0D0) IRECOM = 0
1032       GOTO 10
1033
1034 *********************************************************************
1035 *                                                                   *
1036 *               control card:  codewd = COMBIJET                    *
1037 *                                                                   *
1038 *               chain fusion (2 q-aq --> qq-aqaq)                   *
1039 *                                                                   *
1040 *       what (1) = 1   fusion treated                               *
1041 *                                                    default: 0.    *
1042 *       what (2)       minimum number of uncombined chains from     *
1043 *                      single projectile or target nucleons         *
1044 *                                                    default: 0.    *
1045 *       what (3..6), sdum   no meaning                              *
1046 *                                                                   *
1047 *********************************************************************
1048
1049   300 CONTINUE
1050       LCO2CR = .FALSE.
1051       IF (INT(WHAT(1)).EQ.1) LCO2CR = .TRUE.
1052       IF (WHAT(2).GE.ZERO) CUTOF = WHAT(2)
1053       GOTO 10
1054
1055 *********************************************************************
1056 *                                                                   *
1057 *               control card:  codewd = XCUTS                       *
1058 *                                                                   *
1059 *                 thresholds for x-sampling                         *
1060 *                                                                   *
1061 *    what (1)    defines lower threshold for val.-q x-value (CVQ)   *
1062 *                                                 default: 1.       *
1063 *    what (2)    defines lower threshold for val.-qq x-value (CDQ)  *
1064 *                                                 default: 2.       *
1065 *    what (3)    defines lower threshold for sea-q x-value (CSEA)   *
1066 *                                                 default: 0.2      *
1067 *    what (4)    sea-q x-values in S-S chains (SSMIMA)              *
1068 *                                                 default: 0.14     *
1069 *    what (5)    not used                                           *
1070 *                                                 default: 2.       *
1071 *    what (6), sdum   no meaning                                    *
1072 *                                                                   *
1073 *    Note: Lower thresholds (what(1..3)) are def. as x_thr=CXXX/ECM *
1074 *                                                                   *
1075 *********************************************************************
1076
1077   310 CONTINUE
1078       IF (WHAT(1).GE.0.5D0) CVQ    = WHAT(1)
1079       IF (WHAT(2).GE.ONE)   CDQ    = WHAT(2)
1080       IF (WHAT(3).GE.0.1D0) CSEA   = WHAT(3)
1081       IF (WHAT(4).GE.ZERO) THEN
1082          SSMIMA = WHAT(4)
1083          SSMIMQ = SSMIMA**2
1084       ENDIF
1085       IF (WHAT(5).GT.2.0D0) VVMTHR = WHAT(5)
1086       GOTO 10
1087
1088 *********************************************************************
1089 *                                                                   *
1090 *               control card:  codewd = INTPT                       *
1091 *                                                                   *
1092 *     what (1) = -1   intrinsic transverse momenta of partons       *
1093 *                     not treated                default: 1         *
1094 *     what (2..6), sdum   no meaning                                *
1095 *                                                                   *
1096 *********************************************************************
1097
1098   320 CONTINUE
1099       IF (WHAT(1).EQ.-1.0D0) THEN
1100          LINTPT = .FALSE.
1101       ELSE
1102          LINTPT = .TRUE.
1103       ENDIF
1104       GOTO 10
1105
1106 *********************************************************************
1107 *                                                                   *
1108 *               control card:  codewd = CRONINPT                    *
1109 *                                                                   *
1110 *    Cronin effect (multiple scattering of partons at chain ends)   *
1111 *                                                                   *
1112 *       what (1) = -1  Cronin effect not treated     default: 1     *
1113 *       what (2) = 0   scattering parameter          default: 0.64  *
1114 *       what (3..6), sdum   no meaning                              *
1115 *                                                                   *
1116 *********************************************************************
1117
1118   330 CONTINUE
1119       IF (WHAT(1).EQ.-1.0D0) THEN
1120          MKCRON = 0
1121       ELSE
1122          MKCRON = 1
1123       ENDIF
1124       CRONCO = WHAT(2)
1125       GOTO 10
1126
1127 *********************************************************************
1128 *                                                                   *
1129 *               control card:  codewd = SEADISTR                    *
1130 *                                                                   *
1131 *     what (1)  (XSEACO)  sea(x) prop. 1/x**what (1)   default: 1.  *
1132 *     what (2)  (UNON)                                 default: 2.  *
1133 *     what (3)  (UNOM)                                 default: 1.5 *
1134 *     what (4)  (UNOSEA)                               default: 5.  *
1135 *                        qdis(x) prop. (1-x)**what (1)  etc.        *
1136 *     what (5..6), sdum   no meaning                                *
1137 *                                                                   *
1138 *********************************************************************
1139
1140   340 CONTINUE
1141       XSEACO = WHAT(1)
1142       XSEACU = 1.05D0-XSEACO
1143       UNON   = WHAT(2)
1144       IF (UNON.LT.0.1D0) UNON = 2.0D0
1145       UNOM   = WHAT(3)
1146       IF (UNOM.LT.0.1D0) UNOM = 1.5D0
1147       UNOSEA = WHAT(4)
1148       IF (UNOSEA.LT.0.1D0) UNOSEA = 5.0D0
1149       GOTO 10
1150
1151 *********************************************************************
1152 *                                                                   *
1153 *               control card:  codewd = SEASU3                      *
1154 *                                                                   *
1155 *          Treatment of strange-quarks at chain ends                *
1156 *                                                                   *
1157 *       what (1)   (SEASQ)  strange-quark supression factor         *
1158 *                  iflav = 1.+rndm*(2.+SEASQ)                       *
1159 *                                                    default: 1.    *
1160 *       what (2..6), sdum   no meaning                              *
1161 *                                                                   *
1162 *********************************************************************
1163
1164   350 CONTINUE
1165       SEASQ = WHAT(1)
1166       GOTO 10
1167
1168 *********************************************************************
1169 *                                                                   *
1170 *               control card:  codewd = DIQUARKS                    *
1171 *                                                                   *
1172 *     what (1) = -1.  sea-diquark/antidiquark-pairs not treated     *
1173 *                                                    default: 1.    *
1174 *     what (2..6), sdum   no meaning                                *
1175 *                                                                   *
1176 *********************************************************************
1177
1178  360  CONTINUE
1179       IF (WHAT(1).EQ.-1.0D0) THEN
1180          LSEADI = .FALSE.
1181       ELSE
1182          LSEADI = .TRUE.
1183       ENDIF
1184       GOTO 10
1185
1186 *********************************************************************
1187 *                                                                   *
1188 *               control card:  codewd = RESONANC                    *
1189 *                                                                   *
1190 *                 treatment of low mass chains                      *
1191 *                                                                   *
1192 *    what (1) = -1 low chain masses are not corrected for resonance *
1193 *                  masses (obsolete for BAMJET-fragmentation)       *
1194 *                                       default: 1.                 *
1195 *    what (2) = -1 massless partons     default: 1. (massive)       *
1196 *                                       default: 1. (massive)       *
1197 *    what (3) = -1 chain-system containing chain of too small       *
1198 *                  mass is rejected (note: this does not fully      *
1199 *                  apply to S-S chains) default: 0.                 *
1200 *    what (4..6), sdum   no meaning                                 *
1201 *                                                                   *
1202 *********************************************************************
1203
1204   370 CONTINUE
1205       IRESCO = 1
1206       IMSHL  = 1
1207       IRESRJ = 0
1208       IF (WHAT(1).EQ.-ONE) IRESCO = 0
1209       IF (WHAT(2).EQ.-ONE) IMSHL  = 0
1210       IF (WHAT(3).EQ.-ONE) IRESRJ = 1
1211       GOTO 10
1212
1213 *********************************************************************
1214 *                                                                   *
1215 *               control card:  codewd = DIFFRACT                    *
1216 *                                                                   *
1217 *                Treatment of diffractive events                    *
1218 *                                                                   *
1219 *     what (1) = (ISINGD) 0  no single diffraction                  *
1220 *                         1  single diffraction included            *
1221 *                       +-2  single diffractive events only         *
1222 *                       +-3  projectile single diffraction only     *
1223 *                       +-4  target single diffraction only         *
1224 *                        -5  double pomeron exchange only           *
1225 *                      (neg. sign applies to PHOJET events)         *
1226 *                                                     default: 0.   *
1227 *                                                                   *
1228 *     what (2) = (IDOUBD) 0  no double diffraction                  *
1229 *                         1  double diffraction included            *
1230 *                         2  double diffractive events only         *
1231 *                                                     default: 0.   *
1232 *     what (3) = 1 projectile diffraction treated (2-channel form.) *
1233 *                                                     default: 0.   *
1234 *     what (4) = alpha-parameter in projectile diffraction          *
1235 *                                                     default: 0.   *
1236 *     what (5..6), sdum   no meaning                                *
1237 *                                                                   *
1238 *********************************************************************
1239
1240   380 CONTINUE
1241       IF (ABS(WHAT(1)).GT.ZERO) ISINGD = INT(WHAT(1))
1242       IF (ABS(WHAT(2)).GT.ZERO) IDOUBD = INT(WHAT(2))
1243       IF ((ISINGD.GT.1).AND.(IDOUBD.GT.1)) THEN
1244          WRITE(LOUT,1380)
1245  1380    FORMAT(1X,'INIT:   inconsistent DIFFRACT - input !',/,
1246      &          11X,'IDOUBD is reset to zero')
1247          IDOUBD = 0
1248       ENDIF
1249       IF (WHAT(3).GT.ZERO) DIBETA = WHAT(3)
1250       IF (WHAT(4).GT.ZERO) DIALPH = WHAT(4)
1251       GOTO 10
1252
1253 *********************************************************************
1254 *                                                                   *
1255 *               control card:  codewd = SINGLECH                    *
1256 *                                                                   *
1257 *       what (1) = 1.  Regge contribution (one chain) included      *
1258 *                                                   default: 0.     *
1259 *       what (2..6), sdum   no meaning                              *
1260 *                                                                   *
1261 *********************************************************************
1262
1263  390  CONTINUE
1264       ISICHA = 0
1265       IF (WHAT(1).EQ.ONE) ISICHA = 1
1266       GOTO 10
1267
1268 *********************************************************************
1269 *                                                                   *
1270 *               control card:  codewd = NOFRAGME                    *
1271 *                                                                   *
1272 *                 biased chain hadronization                        *
1273 *                                                                   *
1274 *       what (1..6) = -1  no of hadronizsation of S-S chains        *
1275 *                   = -2  no of hadronizsation of D-S chains        *
1276 *                   = -3  no of hadronizsation of S-D chains        *
1277 *                   = -4  no of hadronizsation of S-V chains        *
1278 *                   = -5  no of hadronizsation of D-V chains        *
1279 *                   = -6  no of hadronizsation of V-S chains        *
1280 *                   = -7  no of hadronizsation of V-D chains        *
1281 *                   = -8  no of hadronizsation of V-V chains        *
1282 *                   = -9  no of hadronizsation of comb. chains      *
1283 *                                  default:  complete hadronization *
1284 *       sdum   no meaning                                           *
1285 *                                                                   *
1286 *********************************************************************
1287
1288   400 CONTINUE
1289       DO 401 I=1,6
1290          ICHAIN = INT(WHAT(I))
1291          IF ((ICHAIN.LE.-1).AND.(ICHAIN.GE.-9))
1292      &      LHADRO(ABS(ICHAIN)) = .FALSE.
1293   401 CONTINUE
1294       GOTO 10
1295
1296 *********************************************************************
1297 *                                                                   *
1298 *               control card:  codewd = HADRONIZE                   *
1299 *                                                                   *
1300 *           hadronization model and parameter switch                *
1301 *                                                                   *
1302 *       what (1) = 1    hadronization via BAMJET                    *
1303 *                = 2    hadronization via JETSET                    *
1304 *                                                    default: 2     *
1305 *       what (2) = 1..3 parameter set to be used                    *
1306 *                       JETSET: 3 sets available                    *
1307 *                               ( = 3 default JETSET-parameters)    *
1308 *                       BAMJET: 1 set available                     *
1309 *                                                    default: 1     *
1310 *       what (3..6), sdum   no meaning                              *
1311 *                                                                   *
1312 *********************************************************************
1313
1314   410 CONTINUE
1315       IWHAT1 = INT(WHAT(1))
1316       IWHAT2 = INT(WHAT(2))
1317       IF ((IWHAT1.EQ.1).OR.(IWHAT1.EQ.2)) IFRAG(1) = IWHAT1
1318       IF ((IWHAT1.EQ.2).AND.(IWHAT2.GE.1).AND.(IWHAT2.LE.3))
1319      &                                    IFRAG(2) = IWHAT2
1320       GOTO 10
1321
1322 *********************************************************************
1323 *                                                                   *
1324 *               control card:  codewd = POPCORN                     *
1325 *                                                                   *
1326 *  "Popcorn-effect" in fragmentation and diquark breaking diagrams  *
1327 *                                                                   *
1328 *   what (1) = (PDB) frac. of diquark fragmenting directly into     *
1329 *                    baryons (PYTHIA/JETSET fragmentation)          *
1330 *                    (JETSET: = 0. Popcorn mechanism switched off)  *
1331 *                                                    default: 0.5   *
1332 *   what (2) = probability for accepting a diquark breaking         *
1333 *              diagram involving the generation of a u/d quark-     *
1334 *              antiquark pair                        default: 0.0   *
1335 *   what (3) = same a what (2), here for s quark-antiquark pair     *
1336 *                                                    default: 0.0   *
1337 *   what (4..6), sdum   no meaning                                  *
1338 *                                                                   *
1339 *********************************************************************
1340
1341   420 CONTINUE
1342       IF (WHAT(1).GE.0.0D0) PDB = WHAT(1)
1343       IF (WHAT(2).GE.0.0D0) THEN
1344          PDBSEA(1) = WHAT(2)
1345          PDBSEA(2) = WHAT(2)
1346       ENDIF
1347       IF (WHAT(3).GE.0.0D0) PDBSEA(3) = WHAT(3)
1348       DO 421 I=1,8
1349          DBRKA(1,I) = DBRKR(1,I)*PDBSEA(1)/(1.D0-PDBSEA(1))
1350          DBRKA(2,I) = DBRKR(2,I)*PDBSEA(2)/(1.D0-PDBSEA(2))
1351          DBRKA(3,I) = DBRKR(3,I)*PDBSEA(3)/(1.D0-PDBSEA(3))
1352   421 CONTINUE
1353       GOTO 10
1354
1355 *********************************************************************
1356 *                                                                   *
1357 *               control card:  codewd = PARDECAY                    *
1358 *                                                                   *
1359 *      what (1) = 1.  Sigma0/Asigma0 are decaying within JETSET     *
1360 *               = 2.  pion^0 decay after intranucl. cascade         *
1361 *                                                default: no decay  *
1362 *      what (2..6), sdum   no meaning                               *
1363 *                                                                   *
1364 *********************************************************************
1365
1366  430  CONTINUE
1367       IF (WHAT(1).EQ.ONE)  ISIG0 = 1
1368       IF (WHAT(1).EQ.2.0D0) IPI0 = 1
1369       GOTO 10
1370
1371 *********************************************************************
1372 *                                                                   *
1373 *               control card:  codewd = BEAM                        *
1374 *                                                                   *
1375 *              definition of beam parameters                        *
1376 *                                                                   *
1377 *      what (1/2)  > 0 : energy of beam 1/2 (GeV)                   *
1378 *                  < 0 : abs(what(1/2)) energy per charge of        *
1379 *                        beam 1/2 (GeV)                             *
1380 *                  (beam 1 is directed into positive z-direction)   *
1381 *      what (3)    beam crossing angle, defined as 2x angle between *
1382 *                  one beam and the z-axis (micro rad)              *
1383 *      what (4)    angle with x-axis defining the collision plane   *
1384 *      what (5..6), sdum   no meaning                               *
1385 *                                                                   *
1386 *      Note: this card requires previously defined projectile and   *
1387 *            target identities (PROJPAR, TARPAR)                    *
1388 *                                                                   *
1389 *********************************************************************
1390
1391   440 CONTINUE
1392       CALL DT_BEAMPR(WHAT,PPN,1)
1393       EPN    = ZERO
1394       CMENER = ZERO
1395       LEINP  = .TRUE.
1396       GOTO 10
1397
1398 *********************************************************************
1399 *                                                                   *
1400 *               control card:  codewd = LUND-MSTU                   *
1401 *                                                                   *
1402 *          set parameter MSTU in JETSET-common /LUDAT1/             *
1403 *                                                                   *
1404 *       what (1) =  index according to LUND-common block            *
1405 *       what (2) =  new value of MSTU( int(what(1)) )               *
1406 *       what (3), what(4) and what (5), what(6) further             *
1407 *                   parameter in the same way as what (1) and       *
1408 *                   what (2)                                        *
1409 *                        default: default-Lund or corresponding to  *
1410 *                                 the set given in HADRONIZE        *
1411 *                                                                   *
1412 *********************************************************************
1413
1414   450 CONTINUE
1415       IF (WHAT(1).GT.ZERO) THEN
1416          NMSTU = NMSTU+1
1417          IMSTU(NMSTU) = INT(WHAT(1))
1418          MSTUX(NMSTU) = INT(WHAT(2))
1419       ENDIF
1420       IF (WHAT(3).GT.ZERO) THEN
1421          NMSTU = NMSTU+1
1422          IMSTU(NMSTU) = INT(WHAT(3))
1423          MSTUX(NMSTU) = INT(WHAT(4))
1424       ENDIF
1425       IF (WHAT(5).GT.ZERO) THEN
1426          NMSTU = NMSTU+1
1427          IMSTU(NMSTU) = INT(WHAT(5))
1428          MSTUX(NMSTU) = INT(WHAT(6))
1429       ENDIF
1430       GOTO 10
1431
1432 *********************************************************************
1433 *                                                                   *
1434 *               control card:  codewd = LUND-MSTJ                   *
1435 *                                                                   *
1436 *          set parameter MSTJ in JETSET-common /LUDAT1/             *
1437 *                                                                   *
1438 *       what (1) =  index according to LUND-common block            *
1439 *       what (2) =  new value of MSTJ( int(what(1)) )               *
1440 *       what (3), what(4) and what (5), what(6) further             *
1441 *                   parameter in the same way as what (1) and       *
1442 *                   what (2)                                        *
1443 *                        default: default-Lund or corresponding to  *
1444 *                                 the set given in HADRONIZE        *
1445 *                                                                   *
1446 *********************************************************************
1447
1448   451 CONTINUE
1449       IF (WHAT(1).GT.ZERO) THEN
1450          NMSTJ = NMSTJ+1
1451          IMSTJ(NMSTJ) = INT(WHAT(1))
1452          MSTJX(NMSTJ) = INT(WHAT(2))
1453       ENDIF
1454       IF (WHAT(3).GT.ZERO) THEN
1455          NMSTJ = NMSTJ+1
1456          IMSTJ(NMSTJ) = INT(WHAT(3))
1457          MSTJX(NMSTJ) = INT(WHAT(4))
1458       ENDIF
1459       IF (WHAT(5).GT.ZERO) THEN
1460          NMSTJ = NMSTJ+1
1461          IMSTJ(NMSTJ) = INT(WHAT(5))
1462          MSTJX(NMSTJ) = INT(WHAT(6))
1463       ENDIF
1464       GOTO 10
1465
1466 *********************************************************************
1467 *                                                                   *
1468 *               control card:  codewd = LUND-MDCY                   *
1469 *                                                                   *
1470 *  set parameter MDCY(I,1) for particle decays in JETSET-common     *
1471 *                                                      /LUDAT3/     *
1472 *                                                                   *
1473 *       what (1-6) = PDG particle index of particle which should    *
1474 *                    not decay                                      *
1475 *                        default: default-Lund or forced in         *
1476 *                                 DT_INITJS                         *
1477 *                                                                   *
1478 *********************************************************************
1479
1480   452 CONTINUE
1481       DO 4521 I=1,6
1482          IF (WHAT(I).NE.ZERO) THEN
1483             KC = PYCOMP(INT(WHAT(I)))
1484             MDCY(KC,1) = 0
1485          ENDIF
1486  4521 CONTINUE
1487       GOTO 10
1488
1489 *********************************************************************
1490 *                                                                   *
1491 *               control card:  codewd = LUND-PARJ                   *
1492 *                                                                   *
1493 *          set parameter PARJ in JETSET-common /LUDAT1/             *
1494 *                                                                   *
1495 *       what (1) =  index according to LUND-common block            *
1496 *       what (2) =  new value of PARJ( int(what(1)) )               *
1497 *       what (3), what(4) and what (5), what(6) further             *
1498 *                   parameter in the same way as what (1) and       *
1499 *                   what (2)                                        *
1500 *                        default: default-Lund or corresponding to  *
1501 *                                 the set given in HADRONIZE        *
1502 *                                                                   *
1503 *********************************************************************
1504
1505   460 CONTINUE
1506       IF (WHAT(1).NE.ZERO) THEN
1507          NPARJ = NPARJ+1
1508          IPARJ(NPARJ) = INT(WHAT(1))
1509          PARJX(NPARJ) = WHAT(2)
1510       ENDIF
1511       IF (WHAT(3).NE.ZERO) THEN
1512          NPARJ = NPARJ+1
1513          IPARJ(NPARJ) = INT(WHAT(3))
1514          PARJX(NPARJ) = WHAT(4)
1515       ENDIF
1516       IF (WHAT(5).NE.ZERO) THEN
1517          NPARJ = NPARJ+1
1518          IPARJ(NPARJ) = INT(WHAT(5))
1519          PARJX(NPARJ) = WHAT(6)
1520       ENDIF
1521       GOTO 10
1522
1523 *********************************************************************
1524 *                                                                   *
1525 *               control card:  codewd = LUND-PARU                   *
1526 *                                                                   *
1527 *          set parameter PARJ in JETSET-common /LUDAT1/             *
1528 *                                                                   *
1529 *       what (1) =  index according to LUND-common block            *
1530 *       what (2) =  new value of PARU( int(what(1)) )               *
1531 *       what (3), what(4) and what (5), what(6) further             *
1532 *                   parameter in the same way as what (1) and       *
1533 *                   what (2)                                        *
1534 *                        default: default-Lund or corresponding to  *
1535 *                                 the set given in HADRONIZE        *
1536 *                                                                   *
1537 *********************************************************************
1538
1539   470 CONTINUE
1540       IF (WHAT(1).GT.ZERO) THEN
1541          NPARU = NPARU+1
1542          IPARU(NPARU) = INT(WHAT(1))
1543          PARUX(NPARU) = WHAT(2)
1544       ENDIF
1545       IF (WHAT(3).GT.ZERO) THEN
1546          NPARU = NPARU+1
1547          IPARU(NPARU) = INT(WHAT(3))
1548          PARUX(NPARU) = WHAT(4)
1549       ENDIF
1550       IF (WHAT(5).GT.ZERO) THEN
1551          NPARU = NPARU+1
1552          IPARU(NPARU) = INT(WHAT(5))
1553          PARUX(NPARU) = WHAT(6)
1554       ENDIF
1555       GOTO 10
1556
1557 *********************************************************************
1558 *                                                                   *
1559 *               control card:  codewd = OUTLEVEL                    *
1560 *                                                                   *
1561 *                    output control switches                        *
1562 *                                                                   *
1563 *       what (1) =  internal rejection informations  default: 0     *
1564 *       what (2) =  energy-momentum conservation check output       *
1565 *                                                    default: 0     *
1566 *       what (3) =  internal warning messages        default: 0     *
1567 *       what (4..6), sdum    not yet used                           *
1568 *                                                                   *
1569 *********************************************************************
1570
1571   480 CONTINUE
1572       DO 481 K=1,6
1573          IOULEV(K) = INT(WHAT(K))
1574   481 CONTINUE
1575       GOTO 10
1576
1577 *********************************************************************
1578 *                                                                   *
1579 *               control card:  codewd = FRAME                       *
1580 *                                                                   *
1581 *          frame in which final state is given in DTEVT1            *
1582 *                                                                   *
1583 *       what (1) = 1  target rest frame (laboratory)                *
1584 *                = 2  nucleon-nucleon cms                           *
1585 *                                                    default: 1     *
1586 *                                                                   *
1587 *********************************************************************
1588
1589   490 CONTINUE
1590       KFRAME = INT(WHAT(1))
1591       IF ((KFRAME.GE.1).AND.(KFRAME.LE.2)) IFRAME = KFRAME
1592       GOTO 10
1593
1594 *********************************************************************
1595 *                                                                   *
1596 *               control card:  codewd = L-TAG                       *
1597 *                                                                   *
1598 *                        lepton tagger:                             *
1599 *   definition of kinematical cuts for radiated photon and          *
1600 *   outgoing lepton detection in lepton-nucleus interactions        *
1601 *                                                                   *
1602 *       what (1) = y_min                                            *
1603 *       what (2) = y_max                                            *
1604 *       what (3) = Q^2_min                                          *
1605 *       what (4) = Q^2_max                                          *
1606 *       what (5) = theta_min  (Lab)                                 *
1607 *       what (6) = theta_max  (Lab)                                 *
1608 *                                       default: no cuts            *
1609 *       sdum    no meaning                                          *
1610 *                                                                   *
1611 *********************************************************************
1612
1613   500 CONTINUE
1614       YMIN  = WHAT(1)
1615       YMAX  = WHAT(2)
1616       Q2MIN = WHAT(3)
1617       Q2MAX = WHAT(4)
1618       THMIN = WHAT(5)
1619       THMAX = WHAT(6)
1620       GOTO 10
1621
1622 *********************************************************************
1623 *                                                                   *
1624 *               control card:  codewd = L-ETAG                      *
1625 *                                                                   *
1626 *                        lepton tagger:                             *
1627 *       what (1) = min. outgoing lepton energy  (in Lab)            *
1628 *       what (2) = min. photon energy           (in Lab)            *
1629 *       what (3) = max. photon energy           (in Lab)            *
1630 *                                       default: no cuts            *
1631 *       what (2..6), sdum    no meaning                             *
1632 *                                                                   *
1633 *********************************************************************
1634
1635   510 CONTINUE
1636       ELMIN = MAX(WHAT(1),ZERO)
1637       EGMIN = MAX(WHAT(2),ZERO)
1638       EGMAX = MAX(WHAT(3),ZERO)
1639       GOTO 10
1640
1641 *********************************************************************
1642 *                                                                   *
1643 *               control card:  codewd = ECMS-CUT                    *
1644 *                                                                   *
1645 *     what (1) = min. c.m. energy to be sampled                     *
1646 *     what (2) = max. c.m. energy to be sampled                     *
1647 *     what (3) = min x_Bj         to be sampled                     *
1648 *                                       default: no cuts            *
1649 *     what (3..6), sdum    no meaning                               *
1650 *                                                                   *
1651 *********************************************************************
1652
1653   520 CONTINUE
1654       ECMIN  = WHAT(1)
1655       ECMAX  = WHAT(2)
1656       IF (ECMIN.GT.ECMAX) ECMIN = ECMAX
1657       XBJMIN = MAX(WHAT(3),ZERO)
1658       GOTO 10
1659
1660 *********************************************************************
1661 *                                                                   *
1662 *               control card:  codewd = VDM-PAR1                    *
1663 *                                                                   *
1664 *      parameters in gamma-nucleus cross section calculation        *
1665 *                                                                   *
1666 *       what (1) =  Lambda^2                       default: 2.      *
1667 *       what (2)    lower limit in M^2 integration                  *
1668 *                =  1  (3m_pi)^2                                    *
1669 *                =  2  (m_rho0)^2                                   *
1670 *                =  3  (m_phi)^2                   default: 1       *
1671 *       what (3)    upper limit in M^2 integration                  *
1672 *                =  1   s/2                                         *
1673 *                =  2   s/4                                         *
1674 *                =  3   s                          default: 3       *
1675 *       what (4)    CKMT F_2 structure function                     *
1676 *                =  2212  proton                                    *
1677 *                =  100   deuteron                 default: 2212    *
1678 *       what (5)    calculation of gamma-nucleon xsections          *
1679 *                =  1  according to CKMT-parametrization of F_2     *
1680 *                =  2  integrating SIGVP over M^2                   *
1681 *                =  3  using SIGGA                                  *
1682 *                =  4  PHOJET cross sections       default:  4      *
1683 *                                                                   *
1684 *       what (6), sdum    no meaning                                *
1685 *                                                                   *
1686 *********************************************************************
1687
1688   530 CONTINUE
1689       IF (WHAT(1).GE.ZERO) RL2 = WHAT(1)
1690       IF ((WHAT(2).GE.1).AND.(WHAT(2).LE.3)) INTRGE(1) = INT(WHAT(2))
1691       IF ((WHAT(3).GE.1).AND.(WHAT(3).LE.3)) INTRGE(2) = INT(WHAT(3))
1692       IF ((WHAT(4).EQ.2212).OR.(WHAT(4).EQ.100)) IDPDF = INT(WHAT(4))
1693       IF ((WHAT(5).GE.1).AND.(WHAT(5).LE.4)) MODEGA = INT(WHAT(5))
1694       GOTO 10
1695
1696 *********************************************************************
1697 *                                                                   *
1698 *               control card:  codewd = HISTOGRAM                   *
1699 *                                                                   *
1700 *           activate different classes of histograms                *
1701 *                                                                   *
1702 *                                default: no histograms             *
1703 *                                                                   *
1704 *********************************************************************
1705
1706   540 CONTINUE
1707       DO 541 J=1,6
1708          IF ((WHAT(J).GE.100).AND.(WHAT(J).LE.150)) THEN
1709             IHISPP(INT(WHAT(J))-100) = 1
1710          ELSEIF ((ABS(WHAT(J)).GE.200).AND.(ABS(WHAT(J)).LE.250)) THEN
1711             IHISXS(INT(ABS(WHAT(J)))-200) = 1
1712             IF (WHAT(J).LT.ZERO) IXSTBL = 1
1713          ENDIF
1714   541 CONTINUE
1715       GOTO 10
1716
1717 *********************************************************************
1718 *                                                                   *
1719 *               control card:  codewd = XS-TABLE                    *
1720 *                                                                   *
1721 *    output of cross section table for requested interaction        *
1722 *              - particle production deactivated ! -                *
1723 *                                                                   *
1724 *       what (1)      lower energy limit for tabulation             *
1725 *                > 0  Lab. frame                                    *
1726 *                < 0  nucleon-nucleon cms                           *
1727 *       what (2)      upper energy limit for tabulation             *
1728 *                > 0  Lab. frame                                    *
1729 *                < 0  nucleon-nucleon cms                           *
1730 *       what (3) > 0  # of equidistant lin. bins in E               *
1731 *                < 0  # of equidistant log. bins in E               *
1732 *       what (4)      lower limit of particle virtuality (photons)  *
1733 *       what (5)      upper limit of particle virtuality (photons)  *
1734 *       what (6) > 0  # of equidistant lin. bins in Q^2             *
1735 *                < 0  # of equidistant log. bins in Q^2             *
1736 *                                                                   *
1737 *********************************************************************
1738
1739   550 CONTINUE
1740       IF (WHAT(1).EQ.99999.0D0) THEN
1741          IRATIO = INT(WHAT(2))
1742          GOTO 10
1743       ENDIF
1744       CMENER = ABS(WHAT(2))
1745       IF (.NOT.LXSTAB) THEN
1746          CALL DT_BERTTP
1747          CALL DT_INCINI
1748       ENDIF
1749       IF ((.NOT.LXSTAB).OR.(CMENER.NE.CMEOLD)) THEN
1750          CMEOLD = CMENER
1751          IF (WHAT(2).GT.ZERO)
1752      &      CMENER = SQRT(2.0D0*AAM(1)**2+2.0D0*WHAT(2)*AAM(1))
1753          EPN = ZERO
1754          PPN = ZERO
1755 C        WRITE(LOUT,*) 'CMENER = ',CMENER
1756          CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,CMENER,1)
1757          CALL DT_PHOINI
1758       ENDIF
1759       CALL DT_XSTABL(WHAT,IXSQEL,IRATIO)
1760       IXSQEL = 0
1761       LXSTAB = .TRUE.
1762       GOTO 10
1763
1764 *********************************************************************
1765 *                                                                   *
1766 *               control card:  codewd = GLAUB-PAR                   *
1767 *                                                                   *
1768 *                parameters in Glauber-formalism                    *
1769 *                                                                   *
1770 *    what (1)  # of nucleon configurations sampled in integration   *
1771 *              over nuclear desity                default: 1000     *
1772 *    what (2)  # of bins for integration over impact-parameter and  *
1773 *              for profile-function calculation   default: 49       *
1774 *    what (3)  = 1 calculation of tot., el. and qel. cross sections *
1775 *                                                 default: 0        *
1776 *    what (4)  = 1   read pre-calculated impact-parameter distrib.  *
1777 *                    from "sdum".glb                                *
1778 *              =-1   dump pre-calculated impact-parameter distrib.  *
1779 *                    into "sdum".glb                                *
1780 *              = 100 read pre-calculated impact-parameter distrib.  *
1781 *                    for variable projectile/target/energy runs     *
1782 *                    from "sdum".glb                                *
1783 *                                                 default: 0        *
1784 *    what (5..6)   no meaning                                       *
1785 *    sdum      if |what (4)| = 1 name of in/output-file (sdum.glb)  *
1786 *                                                                   *
1787 *********************************************************************
1788
1789   560 CONTINUE
1790       IF (WHAT(1).GT.ZERO) JSTATB = INT(WHAT(1))
1791       IF (WHAT(2).GT.ZERO) JBINSB = INT(WHAT(2))
1792       IF (WHAT(3).EQ.ONE) LPROD = .FALSE.
1793       IF ((ABS(WHAT(4)).EQ.ONE).OR.(WHAT(4).EQ.100)) THEN
1794          IOGLB = INT(WHAT(4))
1795          CGLB  = SDUM
1796       ENDIF
1797       GOTO 10
1798
1799 *********************************************************************
1800 *                                                                   *
1801 *               control card:  codewd = GLAUB-INI                   *
1802 *                                                                   *
1803 *             pre-initialization of profile function                *
1804 *                                                                   *
1805 *       what (1)      lower energy limit for initialization         *
1806 *                > 0  Lab. frame                                    *
1807 *                < 0  nucleon-nucleon cms                           *
1808 *       what (2)      upper energy limit for initialization         *
1809 *                > 0  Lab. frame                                    *
1810 *                < 0  nucleon-nucleon cms                           *
1811 *       what (3) > 0  # of equidistant lin. bins in E               *
1812 *                < 0  # of equidistant log. bins in E               *
1813 *       what (4)      maximum projectile mass number for which the  *
1814 *                     Glauber data are initialized for each         *
1815 *                     projectile mass number                        *
1816 *                     (if <= mass given with the PROJPAR-card)      *
1817 *                                              default: 18          *
1818 *       what (5)      steps in mass number starting from what (4)   *
1819 *                     up to mass number defined with PROJPAR-card   *
1820 *                     for which Glauber data are initialized        *
1821 *                                              default: 5           *
1822 *       what (6)      no meaning                                    *
1823 *       sdum          no meaning                                    *
1824 *                                                                   *
1825 *********************************************************************
1826
1827   565 CONTINUE
1828       IOGLB = -100
1829       CALL DT_GLBINI(WHAT)
1830       GOTO 10
1831
1832 *********************************************************************
1833 *                                                                   *
1834 *               control card:  codewd = VDM-PAR2                    *
1835 *                                                                   *
1836 *      parameters in gamma-nucleus cross section calculation        *
1837 *                                                                   *
1838 *      what (1) = 0 no suppression of shadowing by direct photon    *
1839 *                   processes                                       *
1840 *               = 1 suppression ..                   default: 1     *
1841 *      what (2) = 0 no suppression of shadowing by anomalous        *
1842 *                   component if photon-F_2                         *
1843 *               = 1 suppression ..                   default: 1     *
1844 *      what (3) = 0 no suppression of shadowing by coherence        *
1845 *                   length of the photon                            *
1846 *               = 1 suppression ..                   default: 1     *
1847 *      what (4) = 1 longitudinal polarized photons are taken into   *
1848 *                   account                                         *
1849 *                   eps*R*Q^2/M^2 = what(4)*Q^2/M^2  default: 0     *
1850 *      what (5..6), sdum    no meaning                              *
1851 *                                                                   *
1852 *********************************************************************
1853
1854   570 CONTINUE
1855       IF ((WHAT(1).EQ.ZERO).OR.(WHAT(1).EQ.ONE)) ISHAD(1) = INT(WHAT(1))
1856       IF ((WHAT(2).EQ.ZERO).OR.(WHAT(2).EQ.ONE)) ISHAD(2) = INT(WHAT(2))
1857       IF ((WHAT(3).EQ.ZERO).OR.(WHAT(3).EQ.ONE)) ISHAD(3) = INT(WHAT(3))
1858       EPSPOL  = WHAT(4)
1859       GOTO 10
1860
1861 *********************************************************************
1862 *                                                                   *
1863 *               control card:  XS-QELPRO                            *
1864 *                                                                   *
1865 *     what (1..6), sdum    no meaning                               *
1866 *                                                                   *
1867 *********************************************************************
1868
1869   580 CONTINUE
1870       IXSQEL = ABS(WHAT(1))
1871       GOTO 10
1872
1873 *********************************************************************
1874 *                                                                   *
1875 *               control card:  RNDMINIT                             *
1876 *                                                                   *
1877 *           initialization of random number generator               *
1878 *                                                                   *
1879 *     what (1..4)    values for initialization (= 1..168)           *
1880 *     what (5..6), sdum    no meaning                               *
1881 *                                                                   *
1882 *********************************************************************
1883
1884   590 CONTINUE
1885       IF ((WHAT(1).LT.1.0D0).OR.(WHAT(1).GT.168.0D0)) THEN
1886          NA1 = 22
1887       ELSE
1888          NA1 = WHAT(1)
1889       ENDIF
1890       IF ((WHAT(2).LT.1.0D0).OR.(WHAT(2).GT.168.0D0)) THEN
1891          NA2 = 54
1892       ELSE
1893          NA2 = WHAT(2)
1894       ENDIF
1895       IF ((WHAT(3).LT.1.0D0).OR.(WHAT(3).GT.168.0D0)) THEN
1896          NA3 = 76
1897       ELSE
1898          NA3 = WHAT(3)
1899       ENDIF
1900       IF ((WHAT(4).LT.1.0D0).OR.(WHAT(4).GT.168.0D0)) THEN
1901          NA4 = 92
1902       ELSE
1903          NA4 = WHAT(4)
1904       ENDIF
1905       CALL DT_RNDMST(NA1,NA2,NA3,NA4)
1906       GOTO 10
1907
1908 *********************************************************************
1909 *                                                                   *
1910 *               control card:  codewd = LEPTO-CUT                   *
1911 *                                                                   *
1912 *          set parameter CUT in LEPTO-common /LEPTOU/               *
1913 *                                                                   *
1914 *       what (1) =  index in CUT-array                              *
1915 *       what (2) =  new value of CUT( int(what(1)) )                *
1916 *       what (3), what(4) and what (5), what(6) further             *
1917 *                   parameter in the same way as what (1) and       *
1918 *                   what (2)                                        *
1919 *                        default: default-LEPTO parameters          *
1920 *                                                                   *
1921 *********************************************************************
1922
1923   600 CONTINUE
1924       IF (WHAT(1).GT.ZERO) CUT(INT(WHAT(1))) = WHAT(2)
1925       IF (WHAT(3).GT.ZERO) CUT(INT(WHAT(3))) = WHAT(4)
1926       IF (WHAT(5).GT.ZERO) CUT(INT(WHAT(5))) = WHAT(6)
1927       GOTO 10
1928
1929 *********************************************************************
1930 *                                                                   *
1931 *               control card:  codewd = LEPTO-LST                   *
1932 *                                                                   *
1933 *          set parameter LST in LEPTO-common /LEPTOU/               *
1934 *                                                                   *
1935 *       what (1) =  index in LST-array                              *
1936 *       what (2) =  new value of LST( int(what(1)) )                *
1937 *       what (3), what(4) and what (5), what(6) further             *
1938 *                   parameter in the same way as what (1) and       *
1939 *                   what (2)                                        *
1940 *                        default: default-LEPTO parameters          *
1941 *                                                                   *
1942 *********************************************************************
1943
1944   610 CONTINUE
1945       IF (WHAT(1).GT.ZERO) LST(INT(WHAT(1))) = INT(WHAT(2))
1946       IF (WHAT(3).GT.ZERO) LST(INT(WHAT(3))) = INT(WHAT(4))
1947       IF (WHAT(5).GT.ZERO) LST(INT(WHAT(5))) = INT(WHAT(6))
1948       GOTO 10
1949
1950 *********************************************************************
1951 *                                                                   *
1952 *               control card:  codewd = LEPTO-PARL                  *
1953 *                                                                   *
1954 *          set parameter PARL in LEPTO-common /LEPTOU/              *
1955 *                                                                   *
1956 *       what (1) =  index in PARL-array                             *
1957 *       what (2) =  new value of PARL( int(what(1)) )               *
1958 *       what (3), what(4) and what (5), what(6) further             *
1959 *                   parameter in the same way as what (1) and       *
1960 *                   what (2)                                        *
1961 *                        default: default-LEPTO parameters          *
1962 *                                                                   *
1963 *********************************************************************
1964
1965   620 CONTINUE
1966       IF (WHAT(1).GT.ZERO) PARL(INT(WHAT(1))) = WHAT(2)
1967       IF (WHAT(3).GT.ZERO) PARL(INT(WHAT(3))) = WHAT(4)
1968       IF (WHAT(5).GT.ZERO) PARL(INT(WHAT(5))) = WHAT(6)
1969       GOTO 10
1970
1971 *********************************************************************
1972 *                                                                   *
1973 *               control card:  codewd = START                       *
1974 *                                                                   *
1975 *       what (1) =   number of events                default: 100.  *
1976 *       what (2) = 0 Glauber initialization follows                 *
1977 *                = 1 Glauber initialization supressed, fitted       *
1978 *                    results are used instead                       *
1979 *                    (this does not apply if emulsion-treatment     *
1980 *                     is requested)                                 *
1981 *                = 2 Glauber initialization is written to           *
1982 *                    output-file shmakov.out                        *
1983 *                = 3 Glauber initialization is read from input-file *
1984 *                    shmakov.out                     default: 0     *
1985 *       what (3..6)  no meaning                                     *
1986 *       what (3..6)  no meaning                                     *
1987 *                                                                   *
1988 *********************************************************************
1989
1990   630 CONTINUE
1991
1992 * check for cross-section table output only
1993       IF (LXSTAB) STOP
1994
1995       NCASES = INT(WHAT(1))
1996       IF (NCASES.LE.0) NCASES = 100
1997       IGLAU = INT(WHAT(2))
1998       IF ((IGLAU.NE.1).AND.(IGLAU.NE.2).AND.(IGLAU.NE.3))
1999      &                                            IGLAU = 0
2000
2001       NPMASS = IP
2002       NPCHAR = IPZ
2003       NTMASS = IT
2004       NTCHAR = ITZ
2005       IDP    = IJPROJ
2006       IDT    = IJTARG
2007       IF (IDP.LE.0) IDP = 1
2008 * muon neutrinos: temporary (missing index)
2009 * (new patch in projpar: therefore the following this is probably not
2010 *  necessary anymore..)
2011 C     IF (IDP.EQ.26) IDP = 5
2012 C     IF (IDP.EQ.27) IDP = 6
2013
2014 * redefine collision energy
2015       IF (LEINP) THEN
2016          IF (ABS(VAREHI).GT.ZERO) THEN
2017             PDUM = ZERO
2018             IF (VARELO.LT.EHADLO) VARELO = EHADLO
2019             CALL DT_LTINI(IDP,IDT,VARELO,PDUM,VARCLO,1)
2020             PDUM = ZERO
2021             CALL DT_LTINI(IDP,IDT,VAREHI,PDUM,VARCHI,1)
2022          ENDIF
2023          CALL DT_LTINI(IDP,IDT,EPN,PPN,CMENER,1)
2024       ELSE
2025          WRITE(LOUT,1003)
2026  1003    FORMAT(1X,'INIT:   collision energy not defined!',/,
2027      &          1X,'              -program stopped-      ')
2028          STOP
2029       ENDIF
2030
2031 * switch off evaporation (even if requested) if central coll. requ.
2032       IF ((ICENTR.EQ.-1).OR.(ICENTR.GT.0).OR.(XSFRAC.LT.0.5D0)) THEN
2033          IF (LEVPRT) THEN
2034             WRITE(LOUT,1004)
2035  1004       FORMAT(1X,/,'Warning!  Evaporation request rejected since',
2036      &             ' central collisions forced.')
2037             LEVPRT = .FALSE.
2038             LDEEXG = .FALSE.
2039             LHEAVY = .FALSE.
2040          ENDIF
2041       ENDIF
2042
2043 * initialization of evaporation-module
2044
2045       WRITE(LOUT,1010)
2046  1010 FORMAT(1X,/,'Warning!  No evaporation performed since',
2047      &       ' evaporation modules not available with this version.')
2048       LEVPRT = .FALSE.
2049       LDEEXG = .FALSE.
2050       LHEAVY = .FALSE.
2051       LFRMBK = .FALSE.
2052       IFISS  = 0
2053       IEVFSS = 0
2054       CALL DT_BERTTP
2055       CALL DT_INCINI
2056
2057 * save the default JETSET-parameter
2058       CALL DT_JSPARA(0)
2059
2060 * force use of phojet for g-A
2061       IF ((IDP.EQ.7).AND.(MCGENE.NE.3)) MCGENE = 2
2062 * initialization of nucleon-nucleon event generator
2063       IF (MCGENE.EQ.2) CALL DT_PHOINI
2064 * initialization of LEPTO event generator
2065       IF (MCGENE.EQ.3) THEN
2066
2067          STOP ' This version does not contain LEPTO !'
2068
2069       ENDIF
2070
2071 * initialization of quasi-elastic neutrino scattering
2072       IF (MCGENE.EQ.4) THEN
2073          IF (IJPROJ.EQ.5) THEN
2074             NEUTYP = 1
2075          ELSEIF (IJPROJ.EQ.6) THEN
2076             NEUTYP = 2
2077          ELSEIF (IJPROJ.EQ.135) THEN
2078             NEUTYP = 3
2079          ELSEIF (IJPROJ.EQ.136) THEN
2080             NEUTYP = 4
2081          ELSEIF (IJPROJ.EQ.133) THEN
2082             NEUTYP = 5
2083          ELSEIF (IJPROJ.EQ.134) THEN
2084             NEUTYP = 6
2085          ENDIF
2086       ENDIF
2087
2088 * normalize fractions of emulsion components
2089       IF (NCOMPO.GT.0) THEN
2090          SUMFRA = ZERO
2091          DO 491 I=1,NCOMPO
2092             SUMFRA = SUMFRA+EMUFRA(I)
2093   491    CONTINUE
2094          IF (SUMFRA.GT.ZERO) THEN
2095             DO 492 I=1,NCOMPO
2096                EMUFRA(I) = EMUFRA(I)/SUMFRA
2097   492       CONTINUE
2098          ENDIF
2099       ENDIF
2100
2101 * disallow Cronin's multiple scattering for nucleus-nucleus interactions
2102       IF ((IP.GT.1).AND. (IT.GT.1) .AND. (MKCRON.GT.0)) THEN
2103          WRITE(LOUT,1005)
2104  1005    FORMAT(/,1X,'INIT:  multiple scattering disallowed',/)
2105          MKCRON = 0
2106       ENDIF
2107
2108 * initialization of Glauber-formalism (moved to xAEVT, sr 26.3.96)
2109 C     IF (NCOMPO.LE.0) THEN
2110 C        CALL DT_SHMAKI(IP,IPZ,IT,ITZ,IDP,PPN,IGLAU)
2111 C     ELSE
2112 C        DO 493 I=1,NCOMPO
2113 C           CALL DT_SHMAKI(IP,IPZ,IEMUMA(I),IEMUCH(I),IDP,PPN,0)
2114 C 493    CONTINUE
2115 C     ENDIF
2116
2117 * pre-tabulation of elastic cross-sections
2118       CALL DT_SIGTBL(JDUM,JDUM,DUM,DUM,-1)
2119
2120       CALL DT_XTIME
2121
2122       RETURN
2123
2124 *********************************************************************
2125 *                                                                   *
2126 *               control card:  codewd = STOP                        *
2127 *                                                                   *
2128 *               stop of the event generation                        *
2129 *                                                                   *
2130 *       what (1..6)  no meaning                                     *
2131 *                                                                   *
2132 *********************************************************************
2133
2134  9999 CONTINUE
2135       WRITE(LOUT,9000)
2136  9000 FORMAT(1X,'---> unexpected end of input !')
2137
2138   640 CONTINUE
2139       STOP
2140
2141       END
2142
2143 *$ CREATE DT_KKINC.FOR
2144 *COPY DT_KKINC
2145 *
2146 *===kkinc==============================================================*
2147 *
2148       SUBROUTINE DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,
2149      &                                                         IREJ)
2150
2151 ************************************************************************
2152 * Treatment of complete nucleus-nucleus or hadron-nucleus scattering   *
2153 * This subroutine is an update of the previous version written         *
2154 * by J. Ranft/ H.-J. Moehring.                                         *
2155 * This version dated 19.11.95 is written by S. Roesler                 *
2156 ************************************************************************
2157
2158       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2159       SAVE
2160       PARAMETER ( LINP = 10 ,
2161      &            LOUT = 6 ,
2162      &            LDAT = 9 )
2163       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY5=1.0D-5,
2164      &           TINY2=1.0D-2,TINY3=1.0D-3)
2165
2166       LOGICAL LFZC
2167
2168 * event history
2169
2170       PARAMETER (NMXHEP=4000)
2171       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2172      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
2173      &                VHEP(4,NMXHEP), NSD1, NSD2, NDD
2174
2175       PARAMETER (NMXHKK=200000)
2176       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2177      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2178      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2179 * extended event history
2180       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2181      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2182      &                IHIST(2,NMXHKK)
2183 * particle properties (BAMJET index convention)
2184       CHARACTER*8  ANAME
2185       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2186      &                IICH(210),IIBAR(210),K1(210),K2(210)
2187 * properties of interacting particles
2188       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2189 * Lorentz-parameters of the current interaction
2190       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
2191      &                UMO,PPCM,EPROJ,PPROJ
2192 * flags for input different options
2193       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2194       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2195      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2196 * flags for particle decays
2197       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2198      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2199      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2200 * cuts for variable energy runs
2201       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2202 * Glauber formalism: flags and parameters for statistics
2203       LOGICAL LPROD
2204       CHARACTER*8 CGLB
2205       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2206
2207       DIMENSION WHAT(6)
2208
2209       IREJ  = 0
2210       ILOOP = 0
2211       NSD1  = 0
2212       NSD2  = 0
2213       NDD   = 0
2214   100 CONTINUE
2215       IF (ILOOP.EQ.4) THEN
2216          WRITE(LOUT,1000) NEVHKK
2217  1000    FORMAT(1X,'KKINC: event ',I8,' rejected!')
2218          GOTO 9999
2219       ENDIF
2220       ILOOP = ILOOP+1
2221
2222 * variable energy-runs, recalculate parameters for LT's
2223       IF ((ABS(VAREHI).GT.ZERO).OR.(IOGLB.EQ.100)) THEN
2224          PDUM = ZERO
2225          CDUM = ZERO
2226          CALL DT_LTINI(IDP,1,EPN,PDUM,CDUM,1)
2227       ENDIF
2228       IF (EPN.GT.EPROJ) THEN
2229          WRITE(LOUT,'(A,E9.3,2A,E9.3,A)')
2230      &      ' Requested energy (',EPN,'GeV) exceeds',
2231      &      ' initialization energy (',EPROJ,'GeV) !'
2232          STOP
2233       ENDIF
2234
2235 * re-initialize /DTPRTA/
2236       IP  = NPMASS
2237       IPZ = NPCHAR
2238       IT  = NTMASS
2239       ITZ = NTCHAR
2240       IJPROJ = IDP
2241       IBPROJ = IIBAR(IJPROJ)
2242
2243 * calculate nuclear potentials (common /DTNPOT/)
2244       CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
2245
2246 * initialize treatment for residual nuclei
2247       CALL DT_RESNCL(EPN,NLOOP,1)
2248
2249 * sample hadron/nucleus-nucleus interaction
2250       CALL DT_KKEVNT(KKMAT,IREJ1)
2251       IF (IREJ1.GT.0) THEN
2252          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKINC'
2253          GOTO 9999
2254       ENDIF
2255
2256       IF ((NPMASS.GT.1).OR.(NTMASS.GT.1)) THEN
2257
2258 * intranuclear cascade of final state particles for KTAUGE generations
2259 * of secondaries
2260          CALL DT_FOZOCA(LFZC,IREJ1)
2261          IF (IREJ1.GT.0) THEN
2262             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKINC'
2263             GOTO 9999
2264          ENDIF
2265
2266 * baryons unable to escape the nuclear potential are treated as
2267 * excited nucleons (ISTHKK=15,16)
2268          CALL DT_SCN4BA
2269
2270 * decay of resonances produced in intranuclear cascade processes
2271 **sr 15-11-95 should be obsolete
2272 C        IF (LFZC) CALL DT_DECAY1
2273
2274   101    CONTINUE
2275 * treatment of residual nuclei
2276          CALL DT_RESNCL(EPN,NLOOP,2)
2277
2278 * evaporation / fission / fragmentation
2279 * (if intranuclear cascade was sampled only)
2280          IF (LFZC) THEN
2281             CALL DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ1)
2282             IF (IREJ1.GT.1) GOTO 101
2283             IF (IREJ1.EQ.1) GOTO 100
2284          ENDIF
2285
2286       ENDIF
2287
2288 * rejection of unphysical configurations
2289       CALL DT_REJUCO(1,IREJ1)
2290       IF (IREJ1.GT.0) THEN
2291          IF (IOULEV(1).GT.0)
2292      &      WRITE(LOUT,*) 'rejected 3 in KKINC: too large x'
2293          GOTO 100
2294       ENDIF
2295
2296 * transform finale state into Lab.
2297       IFLAG = 2
2298       CALL DT_BEAMPR(WHAT,DUM,IFLAG)
2299       IF ((IFRAME.EQ.1).AND.(IFLAG.EQ.-1)) CALL DT_LT2LAB
2300
2301       IF (IPI0.EQ.1) CALL DT_DECPI0
2302
2303 C     IF (NEVHKK.EQ.5) CALL DT_EVTOUT(4)
2304       RETURN
2305  9999 CONTINUE
2306       IREJ = 1
2307
2308       RETURN
2309       END
2310
2311 *$ CREATE DT_DEFAUL.FOR
2312 *COPY DT_DEFAUL
2313 *
2314 *===defaul=============================================================*
2315 *
2316       SUBROUTINE DT_DEFAUL(EPN,PPN)
2317
2318 ************************************************************************
2319 * Variables are set to default values.                                 *
2320 * This version dated 8.5.95 is written by S. Roesler.                  *
2321 ************************************************************************
2322
2323       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2324       SAVE
2325       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
2326       PARAMETER (TWOPI  = 6.283185307179586454D+00)
2327
2328 * particle properties (BAMJET index convention)
2329       CHARACTER*8  ANAME
2330       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2331      &                IICH(210),IIBAR(210),K1(210),K2(210)
2332 * nuclear potential
2333       LOGICAL LFERMI
2334       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
2335      &                EBINDP(2),EBINDN(2),EPOT(2,210),
2336      &                ETACOU(2),ICOUL,LFERMI
2337 * interface HADRIN-DPM
2338       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
2339 * central particle production, impact parameter biasing
2340       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
2341 * properties of interacting particles
2342       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2343 * properties of photon/lepton projectiles
2344       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2345       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2346 * emulsion treatment
2347       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2348      &                NCOMPO,IEMUL
2349 * parameter for intranuclear cascade
2350       LOGICAL LPAULI
2351       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
2352 * various options for treatment of partons (DTUNUC 1.x)
2353 * (chain recombination, Cronin,..)
2354       LOGICAL LCO2CR,LINTPT
2355       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
2356      &                LCO2CR,LINTPT
2357 * threshold values for x-sampling (DTUNUC 1.x)
2358       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
2359      &                SSMIMQ,VVMTHR
2360 * flags for input different options
2361       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2362       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2363      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2364 * n-n cross section fluctuations
2365       PARAMETER (NBINS = 1000)
2366       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
2367 * flags for particle decays
2368       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2369      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2370      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2371 * diquark-breaking mechanism
2372       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
2373 * nucleon-nucleon event-generator
2374       CHARACTER*8 CMODEL
2375       LOGICAL LPHOIN
2376       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2377 * flags for diffractive interactions (DTUNUC 1.x)
2378       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
2379 * VDM parameter for photon-nucleus interactions
2380       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
2381 * Glauber formalism: flags and parameters for statistics
2382       LOGICAL LPROD
2383       CHARACTER*8 CGLB
2384       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2385 * kinematical cuts for lepton-nucleus interactions
2386       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2387      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2388 * flags for activated histograms
2389       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2390 * cuts for variable energy runs
2391       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2392 * parameters for hA-diffraction
2393       COMMON /DTDIHA/ DIBETA,DIALPH
2394 * LEPTO
2395       REAL RPPN
2396       COMMON /LEPTOI/ RPPN,LEPIN,INTER
2397 * steering flags for qel neutrino scattering modules
2398       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
2399 * event flag
2400       COMMON /DTEVNO/ NEVENT,ICASCA
2401
2402       DATA POTMES /0.002D0/
2403
2404 * common /DTNPOT/
2405       DO 10 I=1,2
2406          PFERMP(I) = ZERO
2407          PFERMN(I) = ZERO
2408          EBINDP(I) = ZERO
2409          EBINDN(I) = ZERO
2410          DO 11 J=1,210
2411             EPOT(I,J) = ZERO
2412    11    CONTINUE
2413 * nucleus independent meson potential
2414          EPOT(I,13) = POTMES
2415          EPOT(I,14) = POTMES
2416          EPOT(I,15) = POTMES
2417          EPOT(I,16) = POTMES
2418          EPOT(I,23) = POTMES
2419          EPOT(I,24) = POTMES
2420          EPOT(I,25) = POTMES
2421    10 CONTINUE
2422       FERMOD    = 0.55D0
2423       ETACOU(1) = ZERO
2424       ETACOU(2) = ZERO
2425       ICOUL     = 1
2426       LFERMI    = .TRUE.
2427
2428 * common /HNTHRE/
2429       EHADTH = -99.0D0
2430       EHADLO = 4.06D0
2431       EHADHI = 6.0D0
2432       INTHAD = 1
2433       IDXTA  = 2
2434
2435 * common /DTIMPA/
2436       ICENTR = 0
2437       BIMIN  = ZERO
2438       BIMAX  = 1.0D10
2439       XSFRAC = 1.0D0
2440
2441 * common /DTPRTA/
2442       IP  = 1
2443       IPZ = 1
2444       IT  = 1
2445       ITZ = 1
2446       IJPROJ = 1
2447       IBPROJ = 1
2448       IJTARG = 1
2449       IBTARG = 1
2450 * common /DTGPRO/
2451       VIRT = ZERO
2452       DO 14 I=1,4
2453          PGAMM(I)  = ZERO
2454          PLEPT0(I) = ZERO
2455          PLEPT1(I) = ZERO
2456          PNUCL(I)  = ZERO
2457    14 CONTINUE
2458       IDIREC   = 0
2459
2460 * common /DTFOTI/
2461 **sr 7.4.98: changed after corrected B-sampling
2462 C     TAUFOR = 4.4D0
2463       TAUFOR = 3.5D0
2464       KTAUGE = 25
2465       ITAUVE = 1
2466       INCMOD = 1
2467       LPAULI = .TRUE.
2468
2469 * common /DTCHAI/
2470       SEASQ  = ONE
2471       MKCRON = 1
2472       CRONCO = 0.64D0
2473       ISICHA = 0
2474       CUTOF  = 100.0D0
2475       LCO2CR = .FALSE.
2476       IRECOM = 1
2477       LINTPT = .TRUE.
2478
2479 * common /DTXCUT/
2480 *  definition of soft quark distributions
2481       XSEACU = 0.05D0
2482       UNON   = 2.0D0
2483       UNOM   = 1.5D0
2484       UNOSEA = 5.0D0
2485 *  cutoff parameters for x-sampling
2486       CVQ    = 1.0D0
2487       CDQ    = 2.0D0
2488 C     CSEA   = 0.3D0
2489       CSEA   = 0.1D0
2490       SSMIMA = 1.2D0
2491       SSMIMQ = SSMIMA**2
2492       VVMTHR = 2.0D0
2493
2494 * common /DTXSFL/
2495       IFLUCT = 0
2496
2497 * common /DTFRPA/
2498       PDB = 0.15D0
2499       PDBSEA(1) = 0.0D0
2500       PDBSEA(2) = 0.0D0
2501       PDBSEA(3) = 0.0D0
2502       ISIG0 = 0
2503       IPI0  = 0
2504       NMSTU = 0
2505       NPARU = 0
2506       NMSTJ = 0
2507       NPARJ = 0
2508
2509 * common /DTDIQB/
2510       DO 15 I=1,8
2511          DBRKR(1,I) = 5.0D0
2512          DBRKR(2,I) = 5.0D0
2513          DBRKR(3,I) = 10.0D0
2514          DBRKA(1,I) = ZERO
2515          DBRKA(2,I) = ZERO
2516          DBRKA(3,I) = ZERO
2517    15 CONTINUE
2518       CHAM1 = 0.2D0
2519       CHAM3 = 0.5D0
2520       CHAB1 = 0.7D0
2521       CHAB3 = 1.0D0
2522
2523 * common /DTFLG3/
2524       ISINGD = 0
2525       IDOUBD = 0
2526       IFLAGD = 0
2527       IDIFF  = 0
2528
2529 * common /DTMODL/
2530       MCGENE    = 2
2531       CMODEL(1) = 'DTUNUC  '
2532       CMODEL(2) = 'PHOJET  '
2533       CMODEL(3) = 'LEPTO   '
2534       CMODEL(4) = 'QNEUTRIN'
2535       LPHOIN    = .TRUE.
2536       ELOJET    = 5.0D0
2537
2538 * common /DTLCUT/
2539       ECMIN  = 3.5D0
2540       ECMAX  = 1.0D10
2541       XBJMIN = ZERO
2542       ELMIN = ZERO
2543       EGMIN = ZERO
2544       EGMAX = 1.0D10
2545       YMIN  = TINY10
2546       YMAX  = 0.999D0
2547       Q2MIN = TINY10
2548       Q2MAX = 10.0D0
2549       THMIN = ZERO
2550       THMAX = TWOPI
2551       Q2LI  = ZERO
2552       Q2HI  = 1.0D10
2553       ECMLI = ZERO
2554       ECMHI = 1.0D10
2555
2556 * common /DTVDMP/
2557       RL2       = 2.0D0
2558       INTRGE(1) = 1
2559       INTRGE(2) = 3
2560       IDPDF     = 2212
2561       MODEGA    = 4
2562       ISHAD(1)  = 1
2563       ISHAD(2)  = 1
2564       ISHAD(3)  = 1
2565       EPSPOL    = ZERO
2566
2567 * common /DTGLGP/
2568       JSTATB = 1000
2569       JBINSB = 49
2570       CGLB   = '        '
2571       IF (ITRSPT.EQ.1) THEN
2572          IOGLB  = 100
2573       ELSE
2574          IOGLB  = 0
2575       ENDIF
2576       LPROD  = .TRUE.
2577
2578 * common /DTHIS3/
2579       DO 16 I=1,50
2580          IHISPP(I) = 0
2581          IHISXS(I) = 0
2582    16 CONTINUE
2583       IXSTBL = 0
2584
2585 * common /DTVARE/
2586       VARELO = ZERO
2587       VAREHI = ZERO
2588       VARCLO = ZERO
2589       VARCHI = ZERO
2590
2591 * common /DTDIHA/
2592       DIBETA = -1.0D0
2593       DIALPH = ZERO
2594
2595 * common /LEPTOI/
2596       RPPN  = 0.0
2597       LEPIN = 0
2598       INTER = 0
2599
2600 * common /QNEUTO/
2601       NEUTYP = 1
2602       NEUDEC = 0
2603
2604 * common /DTEVNO/
2605       NEVENT = 1
2606       IF (ITRSPT.EQ.1) THEN
2607          ICASCA = 1
2608       ELSE
2609          ICASCA = 0
2610       ENDIF
2611
2612 * default Lab.-energy
2613       EPN = 200.0D0
2614       PPN = SQRT((EPN-AAM(IJPROJ))*(EPN+AAM(IJPROJ)))
2615
2616       RETURN
2617       END
2618
2619 *$ CREATE DT_AAEVT.FOR
2620 *COPY DT_AAEVT
2621 *
2622 *===aaevt==============================================================*
2623 *
2624       SUBROUTINE DT_AAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2625      &                                             IDP,IGLAU)
2626
2627 ************************************************************************
2628 * This version dated 22.03.96 is written by S. Roesler.                *
2629 ************************************************************************
2630
2631       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2632       SAVE
2633       PARAMETER ( LINP = 10 ,
2634      &            LOUT = 6 ,
2635      &            LDAT = 9 )
2636
2637       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2638 * emulsion treatment
2639       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2640      &                NCOMPO,IEMUL
2641 * event flag
2642       COMMON /DTEVNO/ NEVENT,ICASCA
2643       CHARACTER*8 DATE,HHMMSS
2644       DIMENSION IDMNYR(3)
2645       NSD1 = 0
2646       NSD2 = 0
2647       NDD  = 0
2648       KKMAT  = 1
2649       NMSG   = MAX(NEVTS/100,1)
2650
2651 * initialization of run-statistics and histograms
2652       CALL DT_STATIS(1)
2653       CALL PHO_PHIST(1000,DUM)
2654
2655 * initialization of Glauber-formalism
2656       IF (NCOMPO.LE.0) THEN
2657          CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2658       ELSE
2659          DO 1 I=1,NCOMPO
2660             CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2661     1    CONTINUE
2662       ENDIF
2663       CALL DT_SIGEMU
2664
2665       CALL IDATE(IDMNYR)
2666       WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2667      &   IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2668       CALL ITIME(IDMNYR)
2669       WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2670      &   IDMNYR(1),IDMNYR(2),IDMNYR(3)
2671       WRITE(LOUT,1001) DATE,HHMMSS
2672  1001 FORMAT(/,' DT_AAEVT: Initialisation finished. ( Date: ',A8,
2673      &       '   Time: ',A8,' )')
2674
2675 * generate NEVTS events
2676       DO 2 IEVT=1,NEVTS
2677
2678 *  print run-status message
2679          IF (MOD(IEVT,NMSG).EQ.0) THEN
2680             CALL IDATE(IDMNYR)
2681             WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2682      &         IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2683             CALL ITIME(IDMNYR)
2684             WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2685      &         IDMNYR(1),IDMNYR(2),IDMNYR(3)
2686             WRITE(LOUT,1000) IEVT-1,NEVTS,DATE,HHMMSS
2687  1000       FORMAT(/,1X,I8,' out of ',I8,' events sampled ( Date: ',A,
2688      &             '   Time: ',A,' )',/)
2689 C           WRITE(LOUT,1000) IEVT-1
2690 C1000       FORMAT(1X,I8,' events sampled')
2691          ENDIF
2692          NEVENT = IEVT
2693 *  treat nuclear emulsions
2694          IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
2695 *  composite targets only
2696          KKMAT = -KKMAT
2697 *  sample this event
2698          CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,IREJ)
2699
2700          CALL PHO_PHIST(2000,DUM)
2701
2702          write(6,*) "Diffractive collisions", NSD1, NSD2, NDD
2703
2704     2 CONTINUE
2705
2706 * print run-statistics and histograms to output-unit 6
2707       CALL PHO_PHIST(3000,DUM)
2708       CALL DT_STATIS(2)
2709       RETURN
2710       END
2711
2712 *$ CREATE DT_LAEVT.FOR
2713 *COPY DT_LAEVT
2714 *
2715 *===laevt==============================================================*
2716 *
2717       SUBROUTINE DT_LAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2718      &                                             IDP,IGLAU)
2719
2720 ************************************************************************
2721 * Interface to run DPMJET for lepton-nucleus interactions.             *
2722 * Kinematics is sampled using the equivalent photon approximation      *
2723 * Based on GPHERA-routine by R. Engel.                                 *
2724 * This version dated 23.03.96 is written by S. Roesler.                *
2725 ************************************************************************
2726
2727       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2728       SAVE
2729       PARAMETER ( LINP = 10 ,
2730      &            LOUT = 6 ,
2731      &            LDAT = 9 )
2732       PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,
2733      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
2734       PARAMETER (TWOPI  = 6.283185307179586454D+00,
2735      &           PI     = TWOPI/TWO,
2736      &           ALPHEM = ONE/137.0D0)
2737
2738 C     CHARACTER*72 HEADER
2739
2740 * particle properties (BAMJET index convention)
2741       CHARACTER*8  ANAME
2742       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2743      &                IICH(210),IIBAR(210),K1(210),K2(210)
2744 * event history
2745       PARAMETER (NMXHKK=200000)
2746       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2747      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2748      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2749 * extended event history
2750       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2751      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2752      &                IHIST(2,NMXHKK)
2753 * kinematical cuts for lepton-nucleus interactions
2754       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2755      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2756 * properties of interacting particles
2757       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2758 * properties of photon/lepton projectiles
2759       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2760 * kinematics at lepton-gamma vertex
2761       COMMON /DTLGVX/ PPL0(4),PPL1(4),PPG(4),PPA(4)
2762 * flags for activated histograms
2763       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2764       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2765 * emulsion treatment
2766       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2767      &                NCOMPO,IEMUL
2768 * Glauber formalism: cross sections
2769       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
2770      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
2771      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
2772      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
2773      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
2774      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
2775      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
2776      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
2777      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
2778      &                BSLOPE,NEBINI,NQBINI
2779 * nucleon-nucleon event-generator
2780       CHARACTER*8 CMODEL
2781       LOGICAL LPHOIN
2782       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2783 * flags for input different options
2784       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2785       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2786      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2787 * event flag
2788       COMMON /DTEVNO/ NEVENT,ICASCA
2789
2790       DIMENSION XDUMB(40),BGTA(4)
2791
2792 * LEPTO
2793       IF (MCGENE.EQ.3) THEN
2794          STOP ' This version does not contain LEPTO !'
2795       ENDIF
2796
2797       KKMAT  = 1
2798       NMSG   = MAX(NEVTS/10,1)
2799
2800 * mass of incident lepton
2801       AMLPT  = AAM(IDP)
2802       AMLPT2 = AMLPT**2
2803       IDPPDG = IDT_IPDGHA(IDP)
2804
2805 * consistency of kinematical limits
2806       Q2MIN  = MAX(Q2MIN,TINY10)
2807       Q2MAX  = MAX(Q2MAX,TINY10)
2808       YMIN   = MIN(MAX(YMIN,TINY10),0.999D0)
2809       YMAX   = MIN(MAX(YMAX,TINY10),0.999D0)
2810
2811 * total energy of the lepton-nucleon system
2812       PTOTLN = SQRT( (PLEPT0(1)+PNUCL(1))**2+(PLEPT0(2)+PNUCL(2))**2
2813      &                                      +(PLEPT0(3)+PNUCL(3))**2 )
2814       ETOTLN = PLEPT0(4)+PNUCL(4)
2815       ECMLN  = SQRT((ETOTLN-PTOTLN)*(ETOTLN+PTOTLN))
2816       ECMAX  = MIN(ECMAX,ECMLN)
2817       WRITE(LOUT,1003) ECMIN,ECMAX,YMIN,YMAX,Q2MIN,Q2MAX,EGMIN,
2818      &                 THMIN,THMAX,ELMIN
2819  1003 FORMAT(1X,'LAEVT:',16X,'kinematical cuts',/,22X,
2820      &       '------------------',/,9X,'W (min)   =',
2821      &       F7.1,' GeV    (max) =',F7.1,' GeV',/,9X,'y (min)   =',
2822      &       F7.3,8X,'(max) =',F7.3,/,9X,'Q^2 (min) =',F7.1,
2823      &       ' GeV^2  (max) =',F7.1,' GeV^2',/,' (Lab)   E_g (min) ='
2824      &       ,F7.1,' GeV',/,' (Lab) theta (min) =',F7.4,8X,'(max) =',
2825      &       F7.4,'   for E_lpt >',F7.1,' GeV',/)
2826
2827 * Lorentz-parameter for transf. into Lab
2828       BGTA(1) = PNUCL(1)/AAM(1)
2829       BGTA(2) = PNUCL(2)/AAM(1)
2830       BGTA(3) = PNUCL(3)/AAM(1)
2831       BGTA(4) = PNUCL(4)/AAM(1)
2832 * LT of incident lepton into Lab and dump it in DTEVT1
2833       CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
2834      &            PLEPT0(1),PLEPT0(2),PLEPT0(3),PLEPT0(4),
2835      &            PLTOT,PPL0(1),PPL0(2),PPL0(3),PPL0(4))
2836       CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
2837      &            PNUCL(1),PNUCL(2),PNUCL(3),PNUCL(4),
2838      &            PLTOT,PPA(1),PPA(2),PPA(3),PPA(4))
2839 * maximum energy of photon nucleon system
2840       PTOTGN = SQRT((YMAX*PPL0(1)+PPA(1))**2+(YMAX*PPL0(2)+PPA(2))**2
2841      &                                      +(YMAX*PPL0(3)+PPA(3))**2)
2842       ETOTGN = YMAX*PPL0(4)+PPA(4)
2843       EGNMAX = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
2844       EGNMAX = MIN(EGNMAX,ECMAX)
2845 * minimum energy of photon nucleon system
2846       PTOTGN = SQRT((YMIN*PPL0(1)+PPA(1))**2+(YMIN*PPL0(2)+PPA(2))**2
2847      &                                      +(YMIN*PPL0(3)+PPA(3))**2)
2848       ETOTGN = YMIN*PPL0(4)+PPA(4)
2849       EGNMIN = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
2850       EGNMIN = MAX(EGNMIN,ECMIN)
2851
2852 * limits for Glauber-initialization
2853       Q2LI  = Q2MIN
2854       Q2HI  = MAX(Q2LI,MIN(Q2HI,Q2MAX))
2855       ECMLI = MAX(EGNMIN,THREE)
2856       ECMHI = EGNMAX
2857       WRITE(LOUT,1004) EGNMIN,EGNMAX,ECMLI,ECMHI,Q2LI,Q2HI
2858  1004 FORMAT(1X,'resulting limits:',/,9X,'W (min)   =',F7.1,
2859      &       ' GeV    (max) =',F7.1,' GeV',/,/,' limits for ',
2860      &       'Glauber-initialization:',/,9X,'W (min)   =',F7.1,
2861      &       ' GeV    (max) =',F7.1,' GeV',/,9X,'Q^2 (min) =',F7.1,
2862      &       ' GeV^2  (max) =',F7.1,' GeV^2',/)
2863 * initialization of Glauber-formalism
2864       IF (NCOMPO.LE.0) THEN
2865          CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2866       ELSE
2867          DO 9 I=1,NCOMPO
2868             CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2869     9    CONTINUE
2870       ENDIF
2871       CALL DT_SIGEMU
2872
2873 * initialization of run-statistics and histograms
2874       CALL DT_STATIS(1)
2875       CALL PHO_PHIST(1000,DUM)
2876
2877 * maximum photon-nucleus cross section
2878       I1  = 1
2879       I2  = 1
2880       RAT = ONE
2881       IF (EGNMAX.GE.ECMNN(NEBINI)) THEN
2882          I1  = NEBINI
2883          I2  = NEBINI
2884          RAT = ONE
2885       ELSEIF (EGNMAX.GT.ECMNN(1)) THEN
2886          DO 5 I=2,NEBINI
2887             IF (EGNMAX.LT.ECMNN(I)) THEN
2888                I1  = I-1
2889                I2  = I
2890                RAT = (EGNMAX-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
2891                GOTO 6
2892             ENDIF
2893     5    CONTINUE
2894     6    CONTINUE
2895       ENDIF
2896       SIGMAX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
2897       EGNXX  = EGNMAX
2898       I1  = 1
2899       I2  = 1
2900       RAT = ONE
2901       IF (EGNMIN.GE.ECMNN(NEBINI)) THEN
2902          I1  = NEBINI
2903          I2  = NEBINI
2904          RAT = ONE
2905       ELSEIF (EGNMIN.GT.ECMNN(1)) THEN
2906          DO 7 I=2,NEBINI
2907             IF (EGNMIN.LT.ECMNN(I)) THEN
2908                I1  = I-1
2909                I2  = I
2910                RAT = (EGNMIN-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
2911                GOTO 8
2912             ENDIF
2913     7    CONTINUE
2914     8    CONTINUE
2915       ENDIF
2916       SIGXX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
2917       IF (SIGXX.GT.SIGMAX) EGNXX = EGNMIN
2918       SIGMAX = MAX(SIGMAX,SIGXX)
2919       WRITE(LOUT,'(9X,A,F8.3,A)') 'Sigma_tot (max) =',SIGMAX,' mb'
2920
2921 * plot photon flux table
2922       AYMIN = LOG(YMIN)
2923       AYMAX = LOG(YMAX)
2924       AYRGE = AYMAX-AYMIN
2925       MAXTAB = 50
2926       ADY    = LOG(YMAX/YMIN)/DBLE(MAXTAB-1)
2927 C     WRITE(LOUT,'(/,1X,A)') 'LAEVT:   photon flux '
2928       DO 1 I=1,MAXTAB
2929          Y     = EXP(AYMIN+ADY*DBLE(I-1))
2930          Q2LOW = MAX(Q2MIN,AMLPT2*Y**2/(ONE-Y))
2931          FF1   = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2932      &                           -TWO*AMLPT2*Y*(ONE/Q2LOW-ONE/Q2MAX))
2933          FF2   = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2934      &                           -TWO*(ONE-Y)/Y*(ONE-Q2LOW/Q2MAX))
2935 C        WRITE(LOUT,'(5X,3E15.4)') Y,FF1,FF2
2936     1 CONTINUE
2937
2938 * maximum residual weight for flux sampling (dy/y)
2939       YY     = YMIN
2940       Q2LOW  = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
2941       WGHMAX = (ONE+(ONE-YY)**2)*LOG(Q2MAX/Q2LOW)
2942      &         -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
2943
2944       CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY0)
2945       CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY1)
2946       CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY2)
2947       CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ0)
2948       CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ1)
2949       CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ2)
2950       CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE0)
2951       CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE1)
2952       CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE2)
2953       CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU0)
2954       CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU1)
2955       CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU2)
2956       XBLOW = 0.001D0
2957       CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX0)
2958       CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX1)
2959       CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX2)
2960
2961       ITRY = 0
2962       ITRW = 0
2963       NC0  = 0
2964       NC1  = 0
2965
2966 * generate events
2967       DO 2 IEVT=1,NEVTS
2968          IF (MOD(IEVT,NMSG).EQ.0) THEN
2969 C           OPEN(LDAT,FILE='/scrtch3/hr/sroesler/statusd5.out',
2970 C    &                                         STATUS='UNKNOWN')
2971             WRITE(LOUT,'(1X,I8,A)') IEVT-1,' events sampled'
2972 C           CLOSE(LDAT)
2973          ENDIF
2974          NEVENT = IEVT
2975
2976   100    CONTINUE
2977          ITRY = ITRY+1
2978
2979 *  sample y
2980   101    CONTINUE
2981          ITRW  = ITRW+1
2982          YY    = EXP(AYRGE*DT_RNDM(RAT)+AYMIN)
2983          Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
2984          Q2LOG = LOG(Q2MAX/Q2LOW)
2985          WGH   = (ONE+(ONE-YY)**2)*Q2LOG
2986      &           -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
2987          IF (WGHMAX.LT.WGH) WRITE(LOUT,1000) YY,WGHMAX,WGH
2988  1000    FORMAT(1X,'LAEVT:   weight error!',3E12.5)
2989          IF (DT_RNDM(YY)*WGHMAX.GT.WGH) GOTO 101
2990
2991 *  sample Q2
2992          YEFF = ONE+(ONE-YY)**2
2993   102    CONTINUE
2994          Q2  = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
2995          WGH = (YEFF-TWO*(ONE-YY)*Q2LOW/Q2)/YEFF
2996          IF (WGH.LT.DT_RNDM(Q2)) GOTO 102
2997
2998 c        NC0 = NC0+1
2999 c        CALL DT_FILHGR(YY,ONE,IHFLY0,NC0)
3000 c        CALL DT_FILHGR(Q2,ONE,IHFLQ0,NC0)
3001
3002 *  kinematics at lepton-photon vertex
3003 *   scattered electron
3004          YQ2 = SQRT((ONE-YY)*Q2)
3005          Q2E = Q2/(4.0D0*PLEPT0(4))
3006          E1Y = (ONE-YY)*PLEPT0(4)
3007          CALL DT_DSFECF(SIF,COF)
3008          PLEPT1(1) = YQ2*COF
3009          PLEPT1(2) = YQ2*SIF
3010          PLEPT1(3) = E1Y-Q2E
3011          PLEPT1(4) = E1Y+Q2E
3012 C        THETA = ACOS( (E1Y-Q2E)/(E1Y+Q2E) )
3013 *   radiated photon
3014          PGAMM(1) = -PLEPT1(1)
3015          PGAMM(2) = -PLEPT1(2)
3016          PGAMM(3) = PLEPT0(3)-PLEPT1(3)
3017          PGAMM(4) = PLEPT0(4)-PLEPT1(4)
3018 *   E_cm cut
3019          PTOTGN = SQRT( (PGAMM(1)+PNUCL(1))**2+(PGAMM(2)+PNUCL(2))**2
3020      &                                        +(PGAMM(3)+PNUCL(3))**2 )
3021          ETOTGN = PGAMM(4)+PNUCL(4)
3022          ECMGN  = (ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)
3023          IF (ECMGN.LT.0.1D0) GOTO 101
3024          ECMGN  = SQRT(ECMGN)
3025          IF ((ECMGN.LT.ECMIN).OR.(ECMGN.GT.ECMAX)) GOTO 101
3026
3027 *  Lorentz-transformation into nucleon-rest system
3028          CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3029      &               PGAMM(1),PGAMM(2),PGAMM(3),PGAMM(4),
3030      &               PGTOT,PPG(1),PPG(2),PPG(3),PPG(4))
3031          CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3032      &               PLEPT1(1),PLEPT1(2),PLEPT1(3),PLEPT1(4),
3033      &               PLTOT,PPL1(1),PPL1(2),PPL1(3),PPL1(4))
3034 *  temporary checks..
3035          Q2TMP = ABS(PPG(4)**2-PGTOT**2)
3036          IF (ABS(Q2-Q2TMP).GT.0.01D0) WRITE(LOUT,1001) Q2,Q2TMP
3037  1001    FORMAT(1X,'LAEVT:    inconsistent kinematics (Q2,Q2TMP) ',
3038      &          2F10.4)
3039          ECMTMP = SQRT((PPG(4)+AAM(1)-PGTOT)*(PPG(4)+AAM(1)+PGTOT))
3040          IF (ABS(ECMGN-ECMTMP).GT.TINY10) WRITE(LOUT,1002) ECMGN,ECMTMP
3041  1002    FORMAT(1X,'LAEVT:    inconsistent kinematics (ECMGN,ECMTMP) ',
3042      &          2F10.2)
3043          YYTMP = PPG(4)/PPL0(4)
3044          IF (ABS(YY-YYTMP).GT.0.01D0) WRITE(LOUT,1005) YY,YYTMP
3045  1005    FORMAT(1X,'LAEVT:    inconsistent kinematics (YY,YYTMP) ',
3046      &          2F10.4)
3047
3048 *  lepton tagger (Lab)
3049          THETA = ACOS( PPL1(3)/PLTOT )
3050          IF (PPL1(4).GT.ELMIN) THEN
3051             IF ((THETA.LT.THMIN).OR.(THETA.GT.THMAX)) GOTO 101
3052          ENDIF
3053 *  photon energy-cut (Lab)
3054          IF (PPG(4).LT.EGMIN) GOTO 101
3055          IF (PPG(4).GT.EGMAX) GOTO 101
3056 *   x_Bj cut
3057          XBJ = ABS(Q2/(1.876D0*PPG(4)))
3058          IF (XBJ.LT.XBJMIN) GOTO 101
3059
3060          NC0 = NC0+1
3061          CALL DT_FILHGR(    Q2,ONE,IHFLQ0,NC0)
3062          CALL DT_FILHGR(    YY,ONE,IHFLY0,NC0)
3063          CALL DT_FILHGR(   XBJ,ONE,IHFLX0,NC0)
3064          CALL DT_FILHGR(PPG(4),ONE,IHFLU0,NC0)
3065          CALL DT_FILHGR( ECMGN,ONE,IHFLE0,NC0)
3066
3067 *  rotation angles against z-axis
3068          COD = PPG(3)/PGTOT
3069 C        SID = SQRT((ONE-COD)*(ONE+COD))
3070          PPT = SQRT(PPG(1)**2+PPG(2)**2)
3071          SID = PPT/PGTOT
3072          COF = ONE
3073          SIF = ZERO
3074          IF (PGTOT*SID.GT.TINY10) THEN
3075             COF   = PPG(1)/(SID*PGTOT)
3076             SIF   = PPG(2)/(SID*PGTOT)
3077             ANORF = SQRT(COF*COF+SIF*SIF)
3078             COF   = COF/ANORF
3079             SIF   = SIF/ANORF
3080          ENDIF
3081
3082          IF (IXSTBL.EQ.0) THEN
3083 *  change to photon projectile
3084             IJPROJ = 7
3085 *  set virtuality
3086             VIRT = Q2
3087 *  re-initialize LTs with new kinematics
3088 *  !!PGAMM ist set in cms (ECMGN) along z
3089             EPN = ZERO
3090             PPN = ZERO
3091             CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,ECMGN,0)
3092 *  force Lab-system
3093             IFRAME = 1
3094 *  get emulsion component if requested
3095             IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
3096 *  convolute with cross section
3097             CALL DT_SIGGAT(Q2LOW,EGNXX,STOTX,KKMAT)
3098             CALL DT_SIGGAT(Q2,ECMGN,STOT,KKMAT)
3099             IF (STOTX.LT.STOT) WRITE(LOUT,'(1X,A,/,6E12.3)')
3100      &         'LAEVT: warning STOTX<STOT ! ',Q2LOW,EGNMAX,STOTX,
3101      &                                        Q2,ECMGN,STOT
3102             IF (DT_RNDM(Q2)*STOTX.GT.STOT) GOTO 100
3103             NC1 = NC1+1
3104             CALL DT_FILHGR(    Q2,ONE,IHFLQ1,NC1)
3105             CALL DT_FILHGR(    YY,ONE,IHFLY1,NC1)
3106             CALL DT_FILHGR(   XBJ,ONE,IHFLX1,NC1)
3107             CALL DT_FILHGR(PPG(4),ONE,IHFLU1,NC1)
3108             CALL DT_FILHGR( ECMGN,ONE,IHFLE1,NC1)
3109 *  composite targets only
3110             KKMAT = -KKMAT
3111 *  sample this event
3112             CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IJPROJ,EPN,KKMAT,
3113      &                                                            IREJ)
3114 *  rotate momenta of final state particles back in photon-nucleon syst.
3115             DO 4 I=NPOINT(4),NHKK
3116                IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
3117      &                                      (ISTHKK(I).EQ.1001)) THEN
3118                   PX = PHKK(1,I)
3119                   PY = PHKK(2,I)
3120                   PZ = PHKK(3,I)
3121                   CALL DT_MYTRAN(1,PX,PY,PZ,COD,SID,COF,SIF,
3122      &                        PHKK(1,I),PHKK(2,I),PHKK(3,I))
3123                ENDIF
3124     4       CONTINUE
3125          ENDIF
3126
3127          CALL DT_FILHGR(    Q2,ONE,IHFLQ2,NC1)
3128          CALL DT_FILHGR(    YY,ONE,IHFLY2,NC1)
3129          CALL DT_FILHGR(   XBJ,ONE,IHFLX2,NC1)
3130          CALL DT_FILHGR(PPG(4),ONE,IHFLU2,NC1)
3131          CALL DT_FILHGR( ECMGN,ONE,IHFLE2,NC1)
3132
3133 *  dump this event to histograms
3134          CALL PHO_PHIST(2000,DUM)
3135
3136     2 CONTINUE
3137
3138       WGY    = ALPHEM/TWOPI*WGHMAX*DBLE(ITRY)/DBLE(ITRW)
3139       WGY    = WGY*LOG(YMAX/YMIN)
3140       WEIGHT = WGY*SIGMAX*DBLE(NEVTS)/DBLE(ITRY)
3141
3142 C     HEADER = ' LAEVT:  Q^2 distribution 0'
3143 C     CALL DT_OUTHGR(IHFLQ0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3144 C     HEADER = ' LAEVT:  Q^2 distribution 1'
3145 C     CALL DT_OUTHGR(IHFLQ1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3146 C     HEADER = ' LAEVT:  Q^2 distribution 2'
3147 C     CALL DT_OUTHGR(IHFLQ2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3148 C     HEADER = ' LAEVT:  y   distribution 0'
3149 C     CALL DT_OUTHGR(IHFLY0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3150 C     HEADER = ' LAEVT:  y   distribution 1'
3151 C     CALL DT_OUTHGR(IHFLY1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3152 C     HEADER = ' LAEVT:  y   distribution 2'
3153 C     CALL DT_OUTHGR(IHFLY2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3154 C     HEADER = ' LAEVT:  x   distribution 0'
3155 C     CALL DT_OUTHGR(IHFLX0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3156 C     HEADER = ' LAEVT:  x   distribution 1'
3157 C     CALL DT_OUTHGR(IHFLX1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3158 C     HEADER = ' LAEVT:  x   distribution 2'
3159 C     CALL DT_OUTHGR(IHFLX2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3160 C     HEADER = ' LAEVT:  E_g distribution 0'
3161 C     CALL DT_OUTHGR(IHFLU0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3162 C     HEADER = ' LAEVT:  E_g distribution 1'
3163 C     CALL DT_OUTHGR(IHFLU1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3164 C     HEADER = ' LAEVT:  E_g distribution 2'
3165 C     CALL DT_OUTHGR(IHFLU2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3166 C     HEADER = ' LAEVT:  E_c distribution 0'
3167 C     CALL DT_OUTHGR(IHFLE0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3168 C     HEADER = ' LAEVT:  E_c distribution 1'
3169 C     CALL DT_OUTHGR(IHFLE1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3170 C     HEADER = ' LAEVT:  E_c distribution 2'
3171 C     CALL DT_OUTHGR(IHFLE2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3172
3173 * print run-statistics and histograms to output-unit 6
3174       CALL PHO_PHIST(3000,DUM)
3175       IF (IXSTBL.EQ.0) CALL DT_STATIS(2)
3176
3177       RETURN
3178       END
3179
3180 *$ CREATE DT_DTUINI.FOR
3181 *COPY DT_DTUINI
3182 *
3183 *===dtuini=============================================================*
3184 *
3185       SUBROUTINE DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
3186      &                                               IDP,IEMU)
3187
3188       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3189       SAVE
3190
3191       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
3192 * emulsion treatment
3193       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
3194      &                NCOMPO,IEMUL
3195 * Glauber formalism: flags and parameters for statistics
3196       LOGICAL LPROD
3197       CHARACTER*8 CGLB
3198       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
3199
3200       CALL DT_INIT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IGLAU)
3201       CALL DT_STATIS(1)
3202       CALL PHO_PHIST(1000,DUM)
3203       IF (NCOMPO.LE.0) THEN
3204          CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
3205       ELSE
3206          DO 1 I=1,NCOMPO
3207             CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
3208     1    CONTINUE
3209       ENDIF
3210       IF (IOGLB.NE.100) CALL DT_SIGEMU
3211       IEMU = IEMUL
3212
3213       RETURN
3214       END
3215
3216 *$ CREATE DT_DTUOUT.FOR
3217 *COPY DT_DTUOUT
3218 *
3219 *===dtuout=============================================================*
3220 *
3221       SUBROUTINE DT_DTUOUT
3222
3223       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3224       SAVE
3225
3226       CALL PHO_PHIST(3000,DUM)
3227       CALL DT_STATIS(2)
3228
3229       RETURN
3230       END
3231
3232 *$ CREATE DT_BEAMPR.FOR
3233 *COPY DT_BEAMPR
3234 *
3235 *===beampr=============================================================*
3236 *
3237       SUBROUTINE DT_BEAMPR(WHAT,PLAB,MODE)
3238
3239 ************************************************************************
3240 * Initialization of event generation                                   *
3241 * This version dated  7.4.98  is written by S. Roesler.                *
3242 ************************************************************************
3243
3244       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3245       SAVE
3246
3247       PARAMETER ( LINP = 10 ,
3248      &            LOUT = 6 ,
3249      &            LDAT = 9 )
3250       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3251       PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3252
3253       LOGICAL LBEAM
3254
3255 * event history
3256       PARAMETER (NMXHKK=200000)
3257       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3258      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3259      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3260 * extended event history
3261       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3262      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3263      &                IHIST(2,NMXHKK)
3264 * properties of interacting particles
3265       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3266 * particle properties (BAMJET index convention)
3267       CHARACTER*8  ANAME
3268       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3269      &                IICH(210),IIBAR(210),K1(210),K2(210)
3270 * beam momenta
3271       COMMON /DTBEAM/ P1(4),P2(4)
3272
3273 C     DIMENSION WHAT(6),P1(4),P2(4),P1CMS(4),P2CMS(4)
3274       DIMENSION WHAT(6),P1CMS(4),P2CMS(4)
3275
3276       DATA LBEAM /.FALSE./
3277
3278       GOTO (1,2) MODE
3279
3280     1 CONTINUE
3281
3282       E1  = WHAT(1)
3283       IF (E1.LT.ZERO) E1 = DBLE(IPZ)/DBLE(IP)*ABS(WHAT(1))
3284       E2  = WHAT(2)
3285       IF (E2.LT.ZERO) E2 = DBLE(ITZ)/DBLE(IT)*ABS(WHAT(2))
3286       PP1 = SQRT( (E1+AAM(IJPROJ))*(E1-AAM(IJPROJ)) )
3287       PP2 = SQRT( (E2+AAM(IJTARG))*(E2-AAM(IJTARG)) )
3288       TH  = 1.D-6*WHAT(3)/2.D0
3289       PH  = WHAT(4)*BOG
3290       P1(1) = PP1*SIN(TH)*COS(PH)
3291       P1(2) = PP1*SIN(TH)*SIN(PH)
3292       P1(3) = PP1*COS(TH)
3293       P1(4) = E1
3294       P2(1) = PP2*SIN(TH)*COS(PH)
3295       P2(2) = PP2*SIN(TH)*SIN(PH)
3296       P2(3) = -PP2*COS(TH)
3297       P2(4) = E2
3298       ECM  = SQRT( (P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
3299      &                                              -(P1(3)+P2(3))**2 )
3300       ELAB = (ECM**2-AAM(IJPROJ)**2-AAM(IJTARG)**2)/(2.0D0*AAM(IJTARG))
3301       PLAB = SQRT( (ELAB+AAM(IJPROJ))*(ELAB-AAM(IJPROJ)) )
3302       BGX  = (P1(1)+P2(1))/ECM
3303       BGY  = (P1(2)+P2(2))/ECM
3304       BGZ  = (P1(3)+P2(3))/ECM
3305       BGE  = (P1(4)+P2(4))/ECM
3306       CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P1(1),P1(2),P1(3),P1(4),
3307      &            P1TOT,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4))
3308       CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P2(1),P2(2),P2(3),P2(4),
3309      &            P2TOT,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4))
3310       COD = P1CMS(3)/P1TOT
3311 C     SID = SQRT((ONE-COD)*(ONE+COD))
3312       PPT = SQRT(P1CMS(1)**2+P1CMS(2)**2)
3313       SID = PPT/P1TOT
3314       COF = ONE
3315       SIF = ZERO
3316       IF (P1TOT*SID.GT.TINY10) THEN
3317          COF   = P1CMS(1)/(SID*P1TOT)
3318          SIF   = P1CMS(2)/(SID*P1TOT)
3319          ANORF = SQRT(COF*COF+SIF*SIF)
3320          COF   = COF/ANORF
3321          SIF   = SIF/ANORF
3322       ENDIF
3323 **check
3324 C     WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3325 C     WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3326 C     WRITE(LOUT,'(5E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),P1TOT
3327 C     WRITE(LOUT,'(5E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),P2TOT
3328 C     PAX = ZERO
3329 C     PAY = ZERO
3330 C     PAZ = P1TOT
3331 C     PAE = SQRT(AAM(IJPROJ)**2+PAZ**2)
3332 C     PBX = ZERO
3333 C     PBY = ZERO
3334 C     PBZ = -P2TOT
3335 C     PBE = SQRT(AAM(IJTARG)**2+PBZ**2)
3336 C     WRITE(LOUT,'(4E15.4)') PAX,PAY,PAZ,PAE
3337 C     WRITE(LOUT,'(4E15.4)') PBX,PBY,PBZ,PBE
3338 C     CALL DT_MYTRAN(1,PAX,PAY,PAZ,COD,SID,COF,SIF,
3339 C    &            P1CMS(1),P1CMS(2),P1CMS(3))
3340 C     CALL DT_MYTRAN(1,PBX,PBY,PBZ,COD,SID,COF,SIF,
3341 C    &            P2CMS(1),P2CMS(2),P2CMS(3))
3342 C     WRITE(LOUT,'(4E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4)
3343 C     WRITE(LOUT,'(4E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4)
3344 C     CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),
3345 C    &            P1TOT,P1(1),P1(2),P1(3),P1(4))
3346 C     CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),
3347 C    &            P2TOT,P2(1),P2(2),P2(3),P2(4))
3348 C     WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3349 C     WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3350 C     STOP
3351 **
3352
3353       LBEAM = .TRUE.
3354
3355       RETURN
3356
3357     2 CONTINUE
3358
3359       IF (LBEAM) THEN
3360          IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3361          DO 20 I=NPOINT(4),NHKK
3362             IF ((ABS(ISTHKK(I)).EQ.1)  .OR.
3363      &           (ABS(ISTHKK(I)).EQ.2) .OR.
3364      &           (ISTHKK(I).EQ.1000)   .OR.
3365      &           (ISTHKK(I).EQ.1001)) THEN
3366
3367                CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I),
3368      &                     COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS)
3369                PECMS = PHKK(4,I)
3370                CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS,
3371      &                     PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I))
3372             ENDIF
3373    20    CONTINUE
3374       ELSE
3375          MODE = -1
3376       ENDIF
3377
3378       RETURN
3379       END
3380
3381 *$ CREATE DT_REJUCO.FOR
3382 *COPY DT_REJUCO
3383 *
3384 *===rejuco=============================================================*
3385 *
3386       SUBROUTINE DT_REJUCO(MODE,IREJ)
3387
3388 ************************************************************************
3389 * REJection of Unphysical COnfigurations                               *
3390 *     MODE = 1  rejection of particles with unphysically large energy  *
3391 *                                                                      *
3392 * This version dated 27.12.2006 is written by S. Roesler.              *
3393 ************************************************************************
3394
3395       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3396       SAVE
3397
3398       PARAMETER ( LINP = 10 ,
3399      &            LOUT = 6 ,
3400      &            LDAT = 9 )
3401       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3402       PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3403
3404 * maximum x_cms of final state particle
3405       PARAMETER (XCMSMX = 1.4D0)
3406
3407 * event history
3408       PARAMETER (NMXHKK=200000)
3409       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3410      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3411      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3412 * extended event history
3413       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3414      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3415      &                IHIST(2,NMXHKK)
3416 * Lorentz-parameters of the current interaction
3417       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
3418      &                UMO,PPCM,EPROJ,PPROJ
3419
3420       IREJ = 0
3421
3422       IF (MODE.EQ.1) THEN
3423          IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3424          ECMHLF = UMO/2.0D0
3425          DO 10 I=NPOINT(4),NHKK
3426             IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDHKK(I).NE.80000)) THEN
3427                XCMS = ABS(PHKK(4,I))/ECMHLF
3428                IF (XCMS.GT.XCMSMX) GOTO 9999
3429             ENDIF
3430    10    CONTINUE
3431       ENDIF
3432
3433       RETURN
3434  9999 CONTINUE
3435       IREJ = 1
3436       RETURN
3437       END
3438
3439 *$ CREATE DT_EVENTB.FOR
3440 *COPY DT_EVENTB
3441 *
3442 *===eventb=============================================================*
3443 *
3444       SUBROUTINE DT_EVENTB(NCSY,IREJ)
3445
3446 ************************************************************************
3447 * Treatment of nucleon-nucleon interactions with full two-component    *
3448 * Dual Parton Model.                                                   *
3449 *          NCSY     number of nucleon-nucleon interactions             *
3450 *          IREJ     rejection flag                                     *
3451 * This version dated 14.01.2000 is written by S. Roesler               *
3452 ************************************************************************
3453
3454       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3455       SAVE
3456       PARAMETER ( LINP = 10 ,
3457      &            LOUT = 6 ,
3458      &            LDAT = 9 )
3459       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
3460
3461 * event history
3462       PARAMETER (NMXHKK=200000)
3463       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3464      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3465      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3466 * extended event history
3467       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3468      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3469      &                IHIST(2,NMXHKK)
3470 *! uncomment this line for internal phojet-fragmentation
3471 C #include "dtu_dtevtp.inc"
3472 * particle properties (BAMJET index convention)
3473       CHARACTER*8  ANAME
3474       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3475      &                IICH(210),IIBAR(210),K1(210),K2(210)
3476 * flags for input different options
3477       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
3478       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
3479      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
3480 * rejection counter
3481       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
3482      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
3483      &                IREXCI(3),IRDIFF(2),IRINC
3484 * properties of interacting particles
3485       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3486 * properties of photon/lepton projectiles
3487       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
3488 * various options for treatment of partons (DTUNUC 1.x)
3489 * (chain recombination, Cronin,..)
3490       LOGICAL LCO2CR,LINTPT
3491       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
3492      &                LCO2CR,LINTPT
3493 * statistics
3494       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
3495      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
3496      &                ICEVTG(8,0:30)
3497 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
3498       COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
3499 * Glauber formalism: collision properties
3500       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
3501      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
3502 * flags for diffractive interactions (DTUNUC 1.x)
3503       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
3504 * statistics: double-Pomeron exchange
3505       COMMON /DTFLG2/ INTFLG,IPOPO
3506 * flags for particle decays
3507       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
3508      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
3509      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
3510 * nucleon-nucleon event-generator
3511       CHARACTER*8 CMODEL
3512       LOGICAL LPHOIN
3513       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
3514 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
3515       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
3516       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
3517       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
3518      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
3519 C  model switches and parameters
3520       CHARACTER*8 MDLNA
3521       INTEGER ISWMDL,IPAMDL
3522       DOUBLE PRECISION PARMDL
3523       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3524 C  initial state parton radiation (internal part)
3525       INTEGER MXISR3,MXISR4
3526       PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
3527       INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
3528       DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
3529       COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
3530      &                ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
3531      &                IFL1(2,MXISR3),IFL2(2,MXISR3),
3532      &                IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
3533 C  event debugging information
3534       INTEGER NMAXD
3535       PARAMETER (NMAXD=100)
3536       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3537      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3538       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3539      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3540 C  general process information
3541       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3542       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3543
3544       DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4),
3545      &          PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4),
3546      &          PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4),
3547      &          KPRON(15),ISINGL(2000)
3548
3549 * initial values for max. number of phojet scatterings and dtunuc chains
3550 * to be fragmented with one pyexec call
3551       DATA MXPHFR,MXDTFR /10,100/
3552
3553       IREJ      = 0
3554 * pointer to first parton of the first chain in dtevt common
3555       NPOINT(3) = NHKK+1
3556 * special flag for double-Pomeron statistics
3557       IPOPO = 1
3558 * counter for low-mass (DTUNUC) interactions
3559       NDTUSC = 0
3560 * counter for interactions treated by PHOJET
3561       NPHOSC = 0
3562
3563 * scan interactions for single nucleon-nucleon interactions
3564 * (this has to be checked here because Cronin modifies parton momenta)
3565       NC = NPOINT(2)
3566       IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! '
3567       DO 8 I=1,NCSY
3568          ISINGL(I) = 0
3569          MOP = JMOHKK(1,NC)
3570          MOT = JMOHKK(1,NC+1)
3571          DIFF1 = ABS(PHKK(4,MOP)-PHKK(4,  NC)-PHKK(4,NC+2))
3572          DIFF2 = ABS(PHKK(4,MOT)-PHKK(4,NC+1)-PHKK(4,NC+3))
3573          IF ((DIFF1.LT.TINY10).AND.(DIFF2.LT.TINY10)) ISINGL(I) = 1
3574          NC = NC+4
3575     8 CONTINUE
3576
3577 * multiple scattering of chain ends
3578       IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
3579       IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
3580
3581 * switch to PHOJET-settings for JETSET parameter
3582       CALL DT_INITJS(1)
3583
3584 * loop over nucleon-nucleon interaction
3585       NC = NPOINT(2)
3586       DO 2 I=1,NCSY
3587 *
3588 *   pick up one nucleon-nucleon interaction from DTEVT1
3589 *     ppnn  / ptnn   - momenta of the interacting nucleons (cms)
3590 *     ptotnn         - total momentum of the interacting nucleons (cms)
3591 *     pp1,2 / pt1,2  - momenta of the four partons
3592 *     pp    / pt     - total momenta of the proj / targ partons
3593 *     ptot           - total momentum of the four partons
3594          MOP = JMOHKK(1,NC)
3595          MOT = JMOHKK(1,NC+1)
3596          DO 3 K=1,4
3597             PPNN(K)   = PHKK(K,MOP)
3598             PTNN(K)   = PHKK(K,MOT)
3599             PTOTNN(K) = PPNN(K)+PTNN(K)
3600             PP1(K)    = PHKK(K,NC)
3601             PT1(K)    = PHKK(K,NC+1)
3602             PP2(K)    = PHKK(K,NC+2)
3603             PT2(K)    = PHKK(K,NC+3)
3604             PP(K)     = PP1(K)+PP2(K)
3605             PT(K)     = PT1(K)+PT2(K)
3606             PTOT(K)   = PP(K)+PT(K)
3607     3    CONTINUE
3608 *
3609 *-----------------------------------------------------------------------
3610 *   this is a complete nucleon-nucleon interaction
3611 *
3612          IF (ISINGL(I).EQ.1) THEN
3613 *
3614 *     initialize PHOJET-variables for remnant/valence-partons
3615             IHFLD(1,1) = 0
3616             IHFLD(1,2) = 0
3617             IHFLD(2,1) = 0
3618             IHFLD(2,2) = 0
3619             IHFLS(1) = 1
3620             IHFLS(2) = 1
3621 *     save current settings of PHOJET process and min. bias flags
3622             DO 9 K=1,11
3623                KPRON(K) = IPRON(K,1)
3624     9       CONTINUE
3625             ISWSAV   = ISWMDL(2)
3626 *
3627 *     check if forced sampling of diffractive interaction requested
3628             IF (ISINGD.LT.-1) THEN
3629                DO 90 K=1,11
3630                   IPRON(K,1) = 0
3631    90          CONTINUE
3632                IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-3)) IPRON(5,1) = 1
3633                IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-4)) IPRON(6,1) = 1
3634                IF (ISINGD.EQ.-5) IPRON(4,1) = 1
3635             ENDIF
3636 *
3637 *     for photons: a direct/anomalous interaction is not sampled
3638 *     in PHOJET but already in Glauber-formalism. Here we check if such
3639 *     an interaction is requested
3640             IF (IJPROJ.EQ.7) THEN
3641 *       first switch off direct interactions
3642                IPRON(8,1) = 0
3643 *       this is a direct interactions
3644                IF (IDIREC.EQ.1) THEN
3645                   DO 12 K=1,11
3646                      IPRON(K,1) = 0
3647    12             CONTINUE
3648                   IPRON(8,1) = 1
3649 *       this is an anomalous interactions
3650 *         (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) )
3651                ELSEIF (IDIREC.EQ.2) THEN
3652                   ISWMDL(2) = 0
3653                ENDIF
3654             ELSE
3655                IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! '
3656             ENDIF
3657 *
3658 *     make sure that total momenta of partons, pp and pt, are on mass
3659 *     shell (Cronin may have srewed this up..)
3660             CALL DT_MASHEL(PP,PT,PHKK(5,MOP),PHKK(5,MOT),PPNN,PTNN,IR1)
3661             IF (IR1.NE.0) THEN
3662                IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)')
3663      &              'EVENTB:  mass shell correction rejected'
3664                GOTO 9999
3665             ENDIF
3666 *
3667 *     initialize the incoming particles in PHOJET
3668             IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3669                CALL PHO_SETPAR(1,22,0,VIRT)
3670             ELSE
3671                CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO)
3672             ENDIF
3673             CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO)
3674 *
3675 *     initialize rejection loop counter for anomalous processes
3676             IRJANO = 0
3677   800       CONTINUE
3678             IRJANO = IRJANO+1
3679 *
3680 *     temporary fix for ifano problem
3681             IFANO(1) = 0
3682             IFANO(2) = 0
3683 *
3684 *     generate complete hadron/nucleon/photon-nucleon event with PHOJET
3685             CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1)
3686 *
3687 *     for photons: special consistency check for anomalous interactions
3688             IF (IJPROJ.EQ.7) THEN
3689                IF (IRJANO.LT.30) THEN
3690                   IF (IFANO(1).NE.0) THEN
3691 *       here, an anomalous interaction was generated. Check if it
3692 *       was also requested. Otherwise reject this event.
3693                      IF (IDIREC.EQ.0) GOTO 800
3694                   ELSE
3695 *       here, an anomalous interaction was not generated. Check if it
3696 *       was requested in which case we need to reject this event.
3697                      IF (IDIREC.EQ.2) GOTO 800
3698                   ENDIF
3699                ELSE
3700                   WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ',
3701      &                          IRJANO,IDIREC,NEVHKK
3702                ENDIF
3703             ENDIF
3704 *
3705 *     copy back original settings of PHOJET process and min. bias flags
3706             DO 10 K=1,11
3707                IPRON(K,1) = KPRON(K)
3708    10       CONTINUE
3709             ISWMDL(2) = ISWSAV
3710 *
3711 *     check if PHOJET has rejected this event
3712             IF (IREJ1.NE.0) THEN
3713 C              IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3714                WRITE(LOUT,'(1X,A,I4)')
3715      &            'EVENTB:  chain system rejected',IDIREC
3716                CALL PHO_PREVNT(0)
3717                GOTO 9999
3718             ENDIF
3719 *
3720 *     copy partons and strings from PHOJET common back into DTEVT for
3721 *     external fragmentation
3722             MO1 = NC
3723             MO2 = NC+3
3724 *!      uncomment this line for internal phojet-fragmentation
3725 C           CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1)
3726             NPHOSC = NPHOSC+1
3727             CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1)
3728             IF (IREJ1.NE.0) THEN
3729                IF (IOULEV(1).GT.0)
3730      &         WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1'
3731                GOTO 9999
3732             ENDIF
3733 *
3734 *     update statistics counter
3735             ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1
3736 *
3737 *-----------------------------------------------------------------------
3738 *   this interaction involves "remnants"
3739 *
3740          ELSE
3741 *
3742 *     total mass of this system
3743             PPTOT  = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2)
3744             AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT)
3745             IF (AMTOT2.LT.ZERO) THEN
3746                AMTOT = ZERO
3747             ELSE
3748                AMTOT = SQRT(AMTOT2)
3749             ENDIF
3750 *
3751 *     systems with masses larger than elojet are treated with PHOJET
3752             IF (AMTOT.GT.ELOJET) THEN
3753 *
3754 *     initialize PHOJET-variables for remnant/valence-partons
3755 *       projectile parton flavors and valence flag
3756                IHFLD(1,1) = IDHKK(NC)
3757                IHFLD(1,2) = IDHKK(NC+2)
3758                IHFLS(1)   = 0
3759                IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7)
3760      &                            .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1
3761 *       target parton flavors and valence flag
3762                IHFLD(2,1) = IDHKK(NC+1)
3763                IHFLD(2,2) = IDHKK(NC+3)
3764                IHFLS(2)   = 0
3765                IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5)
3766      &                            .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1
3767 *       flag signalizing PHOJET how to treat the remnant:
3768 *         iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld
3769 *         iremn > -1 valence remnant: PHOJET assumes flavors according
3770 *                    to mother particle
3771                IREMN1 = IHFLS(1)-1
3772                IREMN2 = IHFLS(2)-1
3773 *
3774 *     initialize the incoming particles in PHOJET
3775                IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3776                   CALL PHO_SETPAR(1,22,IREMN1,VIRT)
3777                ELSE
3778                   CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO)
3779                ENDIF
3780                CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO)
3781 *
3782 *     calculate Lorentz parameter of the nucleon-nucleon cm-system
3783                PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2)
3784                AMNN   = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) )
3785                BGX    = PTOTNN(1)/AMNN
3786                BGY    = PTOTNN(2)/AMNN
3787                BGZ    = PTOTNN(3)/AMNN
3788                GAM    = PTOTNN(4)/AMNN
3789 *     transform interacting nucleons into nucleon-nucleon cm-system
3790                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3791      &                     PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS,
3792      &                     PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4))
3793                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3794      &                     PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS,
3795      &                     PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4))
3796 *     transform (total) momenta of the proj and targ partons into
3797 *     nucleon-nucleon cm-system
3798                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3799      &                     PP(1),PP(2),PP(3),PP(4),
3800      &                     PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4))
3801                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3802      &                     PT(1),PT(2),PT(3),PT(4),
3803      &                     PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4))
3804 *     energy fractions of the proj and targ partons
3805                XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE)
3806                XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE)
3807 ***
3808 * testprint
3809 c              PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
3810 c    &                        (PPTCMS(2)+PTTCMS(2))**2 +
3811 c    &                        (PPTCMS(3)+PTTCMS(3))**2 )
3812 c              EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
3813 c    &                        (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
3814 c              PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
3815 c    &                        (PPSUB(2)+PTSUB(2))**2 +
3816 c    &                        (PPSUB(3)+PTSUB(3))**2 )
3817 c              EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
3818 c    &                        (PPSUB(4)+PTSUB(4)+PTOTSU) )
3819 ***
3820 *
3821 *     save current settings of PHOJET process and min. bias flags
3822                DO 7 K=1,11
3823                   KPRON(K) = IPRON(K,1)
3824     7          CONTINUE
3825 *     disallow direct photon int. (does not make sense here anyway)
3826                IPRON(8,1) = 0
3827 *     disallow double pomeron processes (due to technical problems
3828 *     in PHOJET, needs to be solved sometime)
3829                IPRON(4,1) = 0
3830 *     disallow diffraction for sea-diquarks
3831                IF ((IABS(IHFLD(1,1)).GT.1100).AND.
3832      &             (IABS(IHFLD(1,2)).GT.1100)) THEN
3833                   IPRON(3,1) = 0
3834                   IPRON(6,1) = 0
3835                ENDIF
3836                IF ((IABS(IHFLD(2,1)).GT.1100).AND.
3837      &             (IABS(IHFLD(2,2)).GT.1100)) THEN
3838                   IPRON(3,1) = 0
3839                   IPRON(5,1) = 0
3840                ENDIF
3841 *
3842 *     we need massless partons: transform them on mass shell
3843                XMP = ZERO
3844                XMT = ZERO
3845                DO 6 K=1,4
3846                   PPTMP(K) = PPSUB(K)
3847                   PTTMP(K) = PTSUB(K)
3848     6          CONTINUE
3849                CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1)
3850                PPSUTO  = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2)
3851                PTSUTO  = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2)
3852                PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+
3853      &                  (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2)
3854 *     total energy of the subsysten after mass transformation
3855 *      (should be the same as before..)
3856                SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)*
3857      &                      (PPSUB(4)+PTSUB(4)+PSUTOT) )
3858 *
3859 *     after mass shell transformation the x_sub - relation has to be
3860 *     corrected. We therefore create "pseudo-momenta" of mother-nucleons.
3861 *
3862 *     The old version was to scale based on the original x_sub and the
3863 *     4-momenta of the subsystem. At very high energy this could lead to
3864 *     "pseudo-cm energies" of the parent system considerably exceeding
3865 *     the true cm energy. Now we keep the true cm energy and calculate
3866 *     new x_sub instead.
3867 C old version  PPTCMS(4) = PPSUB(4)/XPSUB
3868                PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4))
3869                XPSUB = PPSUB(4)/PPTCMS(4)
3870                IF (IJPROJ.EQ.7) THEN
3871                   AMP2  = PHKK(5,MOT)**2
3872                   PTOT1 = SQRT(PPTCMS(4)**2-AMP2)
3873                ELSE
3874 *???????
3875                   PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP))
3876      &                        *(PPTCMS(4)+PHKK(5,MOP)))
3877 C                 PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT))
3878 C    &                        *(PPTCMS(4)+PHKK(5,MOT)))
3879                ENDIF
3880 C old version  PTTCMS(4) = PTSUB(4)/XTSUB
3881                PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4))
3882                XTSUB = PTSUB(4)/PTTCMS(4)
3883                PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT))
3884      &                     *(PTTCMS(4)+PHKK(5,MOT)))
3885                DO 4 K=1,3
3886                   PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO
3887                   PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO
3888     4          CONTINUE
3889 ***
3890 * testprint
3891 *
3892 *     ppnn  / ptnn   - momenta of the int. nucleons (cms, negl. Fermi)
3893 *     ptotnn         - total momentum of the int. nucleons (cms, negl. Fermi)
3894 *     pptcms/ pttcms - momenta of the interacting nucleons (cms)
3895 *     pp1,2 / pt1,2  - momenta of the four partons
3896 *
3897 *     pp    / pt     - total momenta of the pr/ta partons (cms, negl. Fermi)
3898 *     ptot           - total momentum of the four partons (cms, negl. Fermi)
3899 *     ppsub / ptsub  - total momenta of the proj / targ partons (cms)
3900 *
3901 c              PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
3902 c    &                        (PPTCMS(2)+PTTCMS(2))**2 +
3903 c    &                        (PPTCMS(3)+PTTCMS(3))**2 )
3904 c              ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
3905 c    &                        (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
3906 c              PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
3907 c    &                        (PPSUB(2)+PTSUB(2))**2 +
3908 c    &                        (PPSUB(3)+PTSUB(3))**2 )
3909 c              ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
3910 c    &                        (PPSUB(4)+PTSUB(4)+PTOTSU) )
3911 c              IF (ENEWCM/EOLDCM.GT.1.1D0) THEN
3912 c                 WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM
3913 c                 WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU
3914 c                 WRITE(*,*) ' XPSUB,  XTSUB  : ',XPSUB,XTSUB
3915 c              ENDIF
3916 c              BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM
3917 c              BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM
3918 c              BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM
3919 c              BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM
3920 *     transform interacting nucleons into nucleon-nucleon cm-system
3921 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3922 c    &                    PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT,
3923 c    &                     PPNEW1,PPNEW2,PPNEW3,PPNEW4)
3924 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3925 c    &                    PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT,
3926 c    &                     PTNEW1,PTNEW2,PTNEW3,PTNEW4)
3927 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3928 c    &                     PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT,
3929 c    &                     PPSUB1,PPSUB2,PPSUB3,PPSUB4)
3930 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3931 c    &                     PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT,
3932 c    &                     PTSUB1,PTSUB2,PTSUB3,PTSUB4)
3933 c              PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 +
3934 c    &                        (PPNEW2+PTNEW2)**2 +
3935 c    &                        (PPNEW3+PTNEW3)**2 )
3936 c              ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) *
3937 c    &                        (PPNEW4+PTNEW4+PTSTCM) )
3938 c              PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 +
3939 c    &                        (PPSUB2+PTSUB2)**2 +
3940 c    &                        (PPSUB3+PTSUB3)**2 )
3941 c              ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) *
3942 c    &                        (PPSUB4+PTSUB4+PTSTSU) )
3943 C              WRITE(*,*) ' mother cmE :'
3944 C              WRITE(*,*) ETSTCM,ENEWCM
3945 C              WRITE(*,*) ' subsystem cmE :'
3946 C              WRITE(*,*) ETSTSU,ENEWSU
3947 C              WRITE(*,*) ' projectile mother :'
3948 C              WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4
3949 C              WRITE(*,*) ' target mother :'
3950 C              WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4
3951 C              WRITE(*,*) ' projectile subsystem:'
3952 C              WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4
3953 C              WRITE(*,*) ' target subsystem:'
3954 C              WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4
3955 C              WRITE(*,*) ' projectile subsystem should be:'
3956 C              WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0,
3957 C    &                    XPSUB*ETSTCM/2.0D0
3958 C              WRITE(*,*) ' target subsystem should be:'
3959 C              WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0,
3960 C    &                    XTSUB*ETSTCM/2.0D0
3961 C              WRITE(*,*) ' subsystem cmE should be: '
3962 C              WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB
3963 ***
3964 *
3965 *     generate complete remnant - nucleon/remnant event with PHOJET
3966                CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1)
3967 *
3968 *     copy back original settings of PHOJET process flags
3969                DO 11 K=1,11
3970                   IPRON(K,1) = KPRON(K)
3971    11          CONTINUE
3972 *
3973 *     check if PHOJET has rejected this event
3974                IF (IREJ1.NE.0) THEN
3975                   IF (IOULEV(1).GT.0)
3976      &            WRITE(LOUT,'(1X,A)') 'EVENTB:  chain system rejected'
3977                   WRITE(LOUT,*)
3978      &                 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT
3979                   CALL PHO_PREVNT(0)
3980                   GOTO 9999
3981                ENDIF
3982 *
3983 *     copy partons and strings from PHOJET common back into DTEVT for
3984 *     external fragmentation
3985                MO1 = NC
3986                MO2 = NC+3
3987 *!      uncomment this line for internal phojet-fragmentation
3988 C              CALL DT_GETFSP(MO1,MO2,PP,PT,1)
3989                NPHOSC = NPHOSC+1
3990                CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1)
3991                IF (IREJ1.NE.0) THEN
3992                   IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3993      &               'EVENTB: chain system rejected 2'
3994                   GOTO 9999
3995                ENDIF
3996 *
3997 *     update statistics counter
3998                ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1
3999 *
4000 *-----------------------------------------------------------------------
4001 * two-chain approx. for smaller systems
4002 *
4003             ELSE
4004 *
4005                NDTUSC = NDTUSC+1
4006 *   special flag for double-Pomeron statistics
4007                IPOPO = 0
4008 *
4009 *   pick up flavors at the ends of the two chains
4010                IFP1 = IDHKK(NC)
4011                IFT1 = IDHKK(NC+1)
4012                IFP2 = IDHKK(NC+2)
4013                IFT2 = IDHKK(NC+3)
4014 *   ..and the indices of the mothers
4015                MOP1 = NC
4016                MOT1 = NC+1
4017                MOP2 = NC+2
4018                MOT2 = NC+3
4019                CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
4020      &                     IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
4021 *
4022 *   check if this chain system was rejected
4023                IF (IREJ1.GT.0) THEN
4024                   IF (IOULEV(1).GT.0) THEN
4025                      WRITE(LOUT,*) 'rejected 1 in EVENTB'
4026                      WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)')
4027      &                  IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT
4028                   ENDIF
4029                   IRHHA = IRHHA+1
4030                   GOTO 9999
4031                ENDIF
4032 *   the following lines are for sea-sea chains rejected in GETCSY
4033                IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1
4034                ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1
4035             ENDIF
4036 *
4037          ENDIF
4038 *
4039 *     update statistics counter
4040          ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1
4041 *
4042          NC = NC+4
4043 *
4044     2 CONTINUE
4045 *
4046 *-----------------------------------------------------------------------
4047 * treatment of low-mass chains (if there are any)
4048 *
4049       IF (NDTUSC.GT.0) THEN
4050 *
4051 *   correct chains of very low masses for possible resonances
4052          IF (IRESCO.EQ.1) THEN
4053             CALL DT_EVTRES(IREJ1)
4054             IF (IREJ1.GT.0) THEN
4055                IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB'
4056                IRRES(1) = IRRES(1)+1
4057                GOTO 9999
4058             ENDIF
4059          ENDIF
4060 *   fragmentation of low-mass chains
4061 *!  uncomment this line for internal phojet-fragmentation
4062 *   (of course it will still be fragmented by DPMJET-routines but it
4063 *    has to be done here instead of further below)
4064 C        CALL DT_EVTFRA(IREJ1)
4065 C        IF (IREJ1.GT.0) THEN
4066 C           IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB'
4067 C           IRFRAG = IRFRAG+1
4068 C           GOTO 9999
4069 C        ENDIF
4070       ELSE
4071 *! uncomment this line for internal phojet-fragmentation
4072 C        NPOINT(4) = NHKK+1
4073          IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
4074       ENDIF
4075 *
4076 *-----------------------------------------------------------------------
4077 * new di-quark breaking mechanisms
4078 *
4079       MXLEFT = 2
4080       CALL DT_CHASTA(0)
4081       IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
4082      &                        .OR.(PDBSEA(3).GT.0.0D0)) THEN
4083          CALL DT_DIQBRK
4084          MXLEFT = 4
4085       ENDIF
4086 *
4087 *-----------------------------------------------------------------------
4088 * hadronize this event
4089 *
4090 *   hadronize PHOJET chain systems
4091       NPYMAX = 0
4092       NPJE   = NPHOSC/MXPHFR
4093       IF (MXPHFR.LT.MXLEFT) MXLEFT = 2
4094       IF (NPJE.GT.1) THEN
4095          NLEFT = NPHOSC-NPJE*MXPHFR
4096          DO 20 JFRG=1,NPJE
4097             NFRG = JFRG*MXPHFR
4098             IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN
4099                CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4100                IF (IREJ1.GT.0) GOTO 22
4101                NLEFT = 0
4102             ELSE
4103                CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1)
4104                IF (IREJ1.GT.0) GOTO 22
4105             ENDIF
4106             IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4107    20    CONTINUE
4108          IF (NLEFT.GT.0) THEN
4109             CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4110             IF (IREJ1.GT.0) GOTO 22
4111             IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4112          ENDIF
4113       ELSE
4114          CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4115          IF (IREJ1.GT.0) GOTO 22
4116          IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4117       ENDIF
4118 *
4119 *   check max. filling level of jetset common and
4120 *   reduce mxphfr if necessary
4121       IF (NPYMAX.GT.3000) THEN
4122          IF (NPYMAX.GT.3500) THEN
4123             MXPHFR = MAX(1,MXPHFR-2)
4124          ELSE
4125             MXPHFR = MAX(1,MXPHFR-1)
4126          ENDIF
4127 C        WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR
4128       ENDIF
4129 *
4130 *   hadronize DTUNUC chain systems
4131    23 CONTINUE
4132       IBACK = MXDTFR
4133       CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2)
4134       IF (IREJ2.GT.0) GOTO 22
4135 *
4136 *   check max. filling level of jetset common and
4137 *   reduce mxdtfr if necessary
4138       IF (NPYMEM.GT.3000) THEN
4139          IF (NPYMEM.GT.3500) THEN
4140             MXDTFR = MAX(1,MXDTFR-20)
4141          ELSE
4142             MXDTFR = MAX(1,MXDTFR-10)
4143          ENDIF
4144 C        WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR
4145       ENDIF
4146 *
4147       IF (IBACK.EQ.-1) GOTO 23
4148 *
4149    22 CONTINUE
4150 C     CALL DT_EVTFRG(1,IREJ1)
4151 C     CALL DT_EVTFRG(2,IREJ2)
4152       IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN
4153          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB'
4154          IRFRAG = IRFRAG+1
4155          GOTO 9999
4156       ENDIF
4157 *
4158 * get final state particles from /DTEVTP/
4159 *! uncomment this line for internal phojet-fragmentation
4160 C     CALL DT_GETFSP(IDUM,IDUM,PP,PT,2)
4161
4162       IF (IJPROJ.NE.7)
4163      &   CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3)
4164 C     IF (IREJ3.NE.0) GOTO 9999
4165
4166       RETURN
4167
4168  9999 CONTINUE
4169       IREVT = IREVT+1
4170       IREJ  = 1
4171       RETURN
4172       END
4173
4174 *$ CREATE DT_GETPJE.FOR
4175 *COPY DT_GETPJE
4176 *
4177 *===getpje=============================================================*
4178 *
4179       SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ)
4180
4181 ************************************************************************
4182 * This subroutine copies PHOJET partons and strings from POEVT1 into   *
4183 * DTEVT1.                                                              *
4184 *      MO1,MO2   indices of first and last mother-parton in DTEVT1     *
4185 *      PP,PT     4-momenta of projectile/target being handled by       *
4186 *                PHOJET                                                *
4187 * This version dated 11.12.99 is written by S. Roesler                 *
4188 ************************************************************************
4189
4190       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4191       SAVE
4192       PARAMETER ( LINP = 10 ,
4193      &            LOUT = 6 ,
4194      &            LDAT = 9 )
4195       PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1,
4196      &           ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0)
4197
4198       LOGICAL LFLIP
4199
4200 * event history
4201       PARAMETER (NMXHKK=200000)
4202       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4203      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4204      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4205 * extended event history
4206       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4207      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4208      &                IHIST(2,NMXHKK)
4209 * Lorentz-parameters of the current interaction
4210       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4211      &                UMO,PPCM,EPROJ,PPROJ
4212 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
4213       COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
4214 * flags for input different options
4215       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4216       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4217      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4218 * statistics: double-Pomeron exchange
4219       COMMON /DTFLG2/ INTFLG,IPOPO
4220 * statistics
4221       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
4222      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
4223      &                ICEVTG(8,0:30)
4224 * rejection counter
4225       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
4226      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
4227      &                IREXCI(3),IRDIFF(2),IRINC
4228 C  standard particle data interface
4229       INTEGER NMXHEP
4230       PARAMETER (NMXHEP=4000)
4231       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
4232       DOUBLE PRECISION PHEP,VHEP
4233       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
4234      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
4235      &                VHEP(4,NMXHEP), NSD1, NSD2, NDD
4236 C  extension to standard particle data interface (PHOJET specific)
4237       INTEGER IMPART,IPHIST,ICOLOR
4238       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
4239 C  color string configurations including collapsed strings and hadrons
4240       INTEGER MSTR
4241       PARAMETER (MSTR=500)
4242       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
4243       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
4244      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
4245      &                NNCH(MSTR),IBHAD(MSTR),ISTR
4246 C  general process information
4247       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4248       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4249 C  model switches and parameters
4250       CHARACTER*8 MDLNA
4251       INTEGER ISWMDL,IPAMDL
4252       DOUBLE PRECISION PARMDL
4253       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4254 C  event debugging information
4255       INTEGER NMAXD
4256       PARAMETER (NMAXD=100)
4257       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4258      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4259       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4260      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4261
4262       DIMENSION PP(4),PT(4)
4263       DATA MAXLOP /10000/
4264
4265       INHKK = NHKK
4266       LFLIP = .TRUE.
4267     1 CONTINUE
4268       NPVAL = 0
4269       NTVAL = 0
4270       IREJ  = 0
4271
4272 *   store initial momenta for energy-momentum conservation check
4273       IF (LEMCCK) THEN
4274          CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2)
4275          CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2)
4276       ENDIF
4277 * copy partons and strings from POEVT1 into DTEVT1
4278       DO 11 I=1,ISTR
4279 C        IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN
4280          IF (NCODE(I).EQ.-99) THEN
4281             IDXSTG = NPOS(1,I)
4282             IDSTG  = IDHEP(IDXSTG)
4283             PX = PHEP(1,IDXSTG)
4284             PY = PHEP(2,IDXSTG)
4285             PZ = PHEP(3,IDXSTG)
4286             PE = PHEP(4,IDXSTG)
4287             IF (MODE.LT.0) THEN
4288                ISTAT = 70000+IPJE
4289                CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE,
4290      &                        11,IDSTG,0)
4291                IF (LEMCCK) THEN
4292                   PX = -PX
4293                   PY = -PY
4294                   PZ = -PZ
4295                   PE = -PE
4296                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4297                ENDIF
4298             ELSE
4299                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4300      &                        PPX,PPY,PPZ,PPE)
4301                ISTAT = 70000+IPJE
4302                CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE,
4303      &                        11,IDSTG,0)
4304                IF (LEMCCK) THEN
4305                   PX = -PPX
4306                   PY = -PPY
4307                   PZ = -PPZ
4308                   PE = -PPE
4309                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4310                ENDIF
4311             ENDIF
4312             NOBAM(NHKK)   = 0
4313             IHIST(1,NHKK) = IPHIST(1,IDXSTG)
4314             IHIST(2,NHKK) = 0
4315          ELSEIF (NCODE(I).GE.0) THEN
4316 *   indices of partons and string in POEVT1
4317             IDX1 = ABS(JMOHEP(1,NPOS(1,I)))
4318             IDX2 = ABS(JMOHEP(2,NPOS(1,I)))
4319             IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN
4320                WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2,
4321      &         ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! '
4322                STOP ' GETPJE 1'
4323             ENDIF
4324             IDXSTG = NPOS(1,I)
4325 *   find "mother" string of the string
4326             IDXMS1 = ABS(JMOHEP(1,IDX1))
4327             IDXMS2 = ABS(JMOHEP(1,IDX2))
4328             IF (IDXMS1.NE.IDXMS2) THEN
4329                IDXMS1 = IDXSTG
4330                IDXMS2 = IDXSTG
4331 C              STOP ' GETPJE: IDXMS1.NE.IDXMS2 !'
4332             ENDIF
4333 *   search POEVT1 for the original hadron of the parton
4334             ILOOP = 0
4335             IPOM1 = 0
4336    14       CONTINUE
4337             ILOOP = ILOOP+1
4338             IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1
4339             IDXMS1 = ABS(JMOHEP(1,IDXMS1))
4340             IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND.
4341      &          (ILOOP.LT.MAXLOP)) GOTO 14
4342             IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! '
4343             IPOM2 = 0
4344             ILOOP = 0
4345    15       CONTINUE
4346             ILOOP = ILOOP+1
4347             IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1
4348             IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN
4349                IDXMS2 = ABS(JMOHEP(2,IDXMS2))
4350             ELSE
4351                IDXMS2 = ABS(JMOHEP(1,IDXMS2))
4352             ENDIF
4353             IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND.
4354      &          (ILOOP.LT.MAXLOP)) GOTO 15
4355             IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! '
4356 *   parton 1
4357             IF (IDXMS1.EQ.1) THEN
4358                ISPTN1 = ISTHKK(MO1)
4359                M1PTN1 = MO1
4360                M2PTN1 = MO1+2
4361             ELSE
4362                ISPTN1 = ISTHKK(MO2)
4363                M1PTN1 = MO2-2
4364                M2PTN1 = MO2
4365             ENDIF
4366 *   parton 2
4367             IF (IDXMS2.EQ.1) THEN
4368                ISPTN2 = ISTHKK(MO1)
4369                M1PTN2 = MO1
4370                M2PTN2 = MO1+2
4371             ELSE
4372                ISPTN2 = ISTHKK(MO2)
4373                M1PTN2 = MO2-2
4374                M2PTN2 = MO2
4375             ENDIF
4376 *   check for mis-identified mothers and switch mother indices if necessary
4377             IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6)
4378      &          .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND.
4379      &          (LFLIP)) THEN
4380                IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN
4381                   ISPTN1 = ISTHKK(MO1)
4382                   M1PTN1 = MO1
4383                   M2PTN1 = MO1+2
4384                   ISPTN2 = ISTHKK(MO2)
4385                   M1PTN2 = MO2-2
4386                   M2PTN2 = MO2
4387                ELSE
4388                   ISPTN1 = ISTHKK(MO2)
4389                   M1PTN1 = MO2-2
4390                   M2PTN1 = MO2
4391                   ISPTN2 = ISTHKK(MO1)
4392                   M1PTN2 = MO1
4393                   M2PTN2 = MO1+2
4394                ENDIF
4395             ENDIF
4396 *   register partons in temporary common
4397 *     parton at chain end
4398             PX = PHEP(1,IDX1)
4399             PY = PHEP(2,IDX1)
4400             PZ = PHEP(3,IDX1)
4401             PE = PHEP(4,IDX1)
4402 * flag only partons coming from Pomeron with 41/42
4403 C           IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4404             IF (IPOM1.NE.0) THEN
4405                ISTX = ABS(ISPTN1)/10
4406                IMO  = ABS(ISPTN1)-10*ISTX
4407                ISPTN1 = -(40+IMO)
4408             ELSE
4409                IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN
4410                   ISTX = ABS(ISPTN1)/10
4411                   IMO  = ABS(ISPTN1)-10*ISTX
4412                   IF ((IDHEP(IDX1).EQ.21).OR.
4413      &                (ABS(IPHIST(1,IDX1)).GE.100)) THEN
4414                      ISPTN1 = -(60+IMO)
4415                   ELSE
4416                      ISPTN1 = -(50+IMO)
4417                   ENDIF
4418                ENDIF
4419             ENDIF
4420             IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1
4421             IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1
4422             IF (MODE.LT.0) THEN
4423                CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY,
4424      &                        PZ,PE,0,0,0)
4425             ELSE
4426                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4427      &                        PPX,PPY,PPZ,PPE)
4428                CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY,
4429      &                        PPZ,PPE,0,0,0)
4430             ENDIF
4431             IHIST(1,NHKK) = IPHIST(1,IDX1)
4432             IHIST(2,NHKK) = 0
4433             DO 19 KK=1,4
4434                VHKK(KK,NHKK) = VHKK(KK,M2PTN1)
4435                WHKK(KK,NHKK) = WHKK(KK,M1PTN1)
4436    19       CONTINUE
4437             VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB
4438             WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB
4439             M1STRG = NHKK
4440 *     gluon kinks
4441             NGLUON = IDX2-IDX1-1
4442             IF (NGLUON.GT.0) THEN
4443                DO 17 IGLUON=1,NGLUON
4444                   IDX   = IDX1+IGLUON
4445                   IDXMS = ABS(JMOHEP(1,IDX))
4446                   IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN
4447                      ILOOP = 0
4448    16                CONTINUE
4449                      ILOOP = ILOOP+1
4450                      IDXMS = ABS(JMOHEP(1,IDXMS))
4451                      IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND.
4452      &                   (ILOOP.LT.MAXLOP)) GOTO 16
4453                      IF (ILOOP.EQ.MAXLOP)
4454      &                  WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! '
4455                   ENDIF
4456                   IF (IDXMS.EQ.1) THEN
4457                      ISPTN = ISTHKK(MO1)
4458                      M1PTN = MO1
4459                      M2PTN = MO1+2
4460                   ELSE
4461                      ISPTN = ISTHKK(MO2)
4462                      M1PTN = MO2-2
4463                      M2PTN = MO2
4464                   ENDIF
4465                   PX = PHEP(1,IDX)
4466                   PY = PHEP(2,IDX)
4467                   PZ = PHEP(3,IDX)
4468                   PE = PHEP(4,IDX)
4469                   IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN
4470                      ISTX = ABS(ISPTN)/10
4471                      IMO  = ABS(ISPTN)-10*ISTX
4472                      IF ((IDHEP(IDX).EQ.21).OR.
4473      &                   (ABS(IPHIST(1,IDX)).GE.100)) THEN
4474                         ISPTN = -(60+IMO)
4475                      ELSE
4476                         ISPTN = -(50+IMO)
4477                      ENDIF
4478                   ENDIF
4479                   IF (ISPTN.EQ.-21) NPVAL = NPVAL+1
4480                   IF (ISPTN.EQ.-22) NTVAL = NTVAL+1
4481                   IF (MODE.LT.0) THEN
4482                      CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4483      &                              PX,PY,PZ,PE,0,0,0)
4484                   ELSE
4485                      CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4486      &                              PPX,PPY,PPZ,PPE)
4487                      CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4488      &                              PPX,PPY,PPZ,PPE,0,0,0)
4489                   ENDIF
4490                   IHIST(1,NHKK) = IPHIST(1,IDX)
4491                   IHIST(2,NHKK) = 0
4492                   DO 20 KK=1,4
4493                      VHKK(KK,NHKK) = VHKK(KK,M2PTN)
4494                      WHKK(KK,NHKK) = WHKK(KK,M1PTN)
4495    20             CONTINUE
4496                   VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB
4497                   WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB
4498    17          CONTINUE
4499             ENDIF
4500 *     parton at chain end
4501             PX = PHEP(1,IDX2)
4502             PY = PHEP(2,IDX2)
4503             PZ = PHEP(3,IDX2)
4504             PE = PHEP(4,IDX2)
4505 * flag only partons coming from Pomeron with 41/42
4506 C           IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4507             IF (IPOM2.NE.0) THEN
4508                ISTX = ABS(ISPTN2)/10
4509                IMO  = ABS(ISPTN2)-10*ISTX
4510                ISPTN2 = -(40+IMO)
4511             ELSE
4512                IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN
4513                   ISTX = ABS(ISPTN2)/10
4514                   IMO  = ABS(ISPTN2)-10*ISTX
4515                   IF ((IDHEP(IDX2).EQ.21).OR.
4516      &                (ABS(IPHIST(1,IDX2)).GE.100)) THEN
4517                      ISPTN2 = -(60+IMO)
4518                   ELSE
4519                      ISPTN2 = -(50+IMO)
4520                   ENDIF
4521                ENDIF
4522             ENDIF
4523             IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1
4524             IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1
4525             IF (MODE.LT.0) THEN
4526                CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4527      &                        PX,PY,PZ,PE,0,0,0)
4528             ELSE
4529                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4530      &                        PPX,PPY,PPZ,PPE)
4531                CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4532      &                        PPX,PPY,PPZ,PPE,0,0,0)
4533             ENDIF
4534             IHIST(1,NHKK) = IPHIST(1,IDX2)
4535             IHIST(2,NHKK) = 0
4536             DO 21 KK=1,4
4537                VHKK(KK,NHKK) = VHKK(KK,M2PTN2)
4538                WHKK(KK,NHKK) = WHKK(KK,M1PTN2)
4539    21       CONTINUE
4540             VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB
4541             WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB
4542             M2STRG = NHKK
4543 *   register string
4544             JSTRG = 100*IPROCE+NCODE(I)
4545             PX = PHEP(1,IDXSTG)
4546             PY = PHEP(2,IDXSTG)
4547             PZ = PHEP(3,IDXSTG)
4548             PE = PHEP(4,IDXSTG)
4549             IF (MODE.LT.0) THEN
4550                ISTAT = 70000+IPJE
4551                CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4552      &                        PX,PY,PZ,PE,0,0,0)
4553                IF (LEMCCK) THEN
4554                   PX = -PX
4555                   PY = -PY
4556                   PZ = -PZ
4557                   PE = -PE
4558                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4559                ENDIF
4560             ELSE
4561                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4562      &                        PPX,PPY,PPZ,PPE)
4563                ISTAT = 70000+IPJE
4564                CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4565      &                        PPX,PPY,PPZ,PPE,0,0,0)
4566                IF (LEMCCK) THEN
4567                   PX = -PPX
4568                   PY = -PPY
4569                   PZ = -PPZ
4570                   PE = -PPE
4571                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4572                ENDIF
4573             ENDIF
4574             NOBAM(NHKK)   = 0
4575             IHIST(1,NHKK) = 0
4576             IHIST(2,NHKK) = 0
4577             DO 18 KK=1,4
4578                VHKK(KK,NHKK) = VHKK(KK,MO2)
4579                WHKK(KK,NHKK) = WHKK(KK,MO1)
4580    18       CONTINUE
4581             VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
4582             WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
4583          ENDIF
4584    11 CONTINUE
4585
4586       IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN
4587          NHKK  = INHKK
4588          LFLIP = .FALSE.
4589          GOTO 1
4590       ENDIF
4591
4592       IF (LEMCCK) THEN
4593          IF (UMO.GT.1.0D5) THEN
4594             CHKLEV = 1.0D0
4595          ELSE
4596             CHKLEV = TINY1
4597          ENDIF
4598          CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2)
4599          IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0)
4600       ENDIF
4601
4602 * internal statistics
4603 *   dble-Po statistics.
4604       IF (IPROCE.NE.4) IPOPO = 0
4605
4606       INTFLG = IPROCE
4607       IDCHSY = IDCH(MO1)
4608       IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN
4609          ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1
4610       ELSE
4611          WRITE(LOUT,1000) IPROCE,NEVHKK,MO1
4612  1000    FORMAT(1X,'GETFSP:   warning! incons. process id. (',I2,
4613      &          ') at evt(chain) ',I6,'(',I2,')')
4614       ENDIF
4615       IF (IPROCE.EQ.5) THEN
4616          IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN
4617             ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1
4618          ELSE
4619 C           WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4620  1001       FORMAT(1X,'GETFSP:   warning! incons. diffrac. id. ',
4621      &             '(IPROCE,IDIFR1,IDIFR2=',3I3,')')
4622          ENDIF
4623       ELSEIF (IPROCE.EQ.6) THEN
4624          IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4625             ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1
4626          ELSE
4627 C           WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4628          ENDIF
4629       ELSEIF (IPROCE.EQ.7) THEN
4630          IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND.
4631      &       (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4632             IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1))
4633      &         ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1
4634             IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2))
4635      &         ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1
4636             IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2))
4637      &         ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1
4638             IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1))
4639      &         ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1
4640          ELSE
4641             WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4642          ENDIF
4643       ENDIF
4644       IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3))
4645      &                                                       THEN
4646          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4647          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4648          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4649       ENDIF
4650       ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM
4651       ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM
4652       ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG
4653       ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG)
4654       ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO)
4655
4656       RETURN
4657
4658  9999 CONTINUE
4659       IREJ = 1
4660       RETURN
4661       END
4662
4663 *$ CREATE DT_PHOINI.FOR
4664 *COPY DT_PHOINI
4665 *
4666 *===phoini=============================================================*
4667 *
4668       SUBROUTINE DT_PHOINI
4669
4670 ************************************************************************
4671 * Initialization PHOJET-event generator for nucleon-nucleon interact.  *
4672 * This version dated 16.11.95 is written by S. Roesler                 *
4673 *                                                                      *
4674 * Last change 27.12.2006 by S. Roesler.                                *
4675 ************************************************************************
4676
4677       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4678       SAVE
4679       PARAMETER ( LINP = 10 ,
4680      &            LOUT = 6 ,
4681      &            LDAT = 9 )
4682       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
4683
4684 * nucleon-nucleon event-generator
4685       CHARACTER*8 CMODEL
4686       LOGICAL LPHOIN
4687       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
4688 * particle properties (BAMJET index convention)
4689       CHARACTER*8  ANAME
4690       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
4691      &                IICH(210),IIBAR(210),K1(210),K2(210)
4692 * Lorentz-parameters of the current interaction
4693       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4694      &                UMO,PPCM,EPROJ,PPROJ
4695 * properties of interacting particles
4696       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
4697 * properties of photon/lepton projectiles
4698       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
4699       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
4700 * emulsion treatment
4701       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
4702      &                NCOMPO,IEMUL
4703 * VDM parameter for photon-nucleus interactions
4704       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
4705 * nuclear potential
4706       LOGICAL LFERMI
4707       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
4708      &                EBINDP(2),EBINDN(2),EPOT(2,210),
4709      &                ETACOU(2),ICOUL,LFERMI
4710 * Glauber formalism: flags and parameters for statistics
4711       LOGICAL LPROD
4712       CHARACTER*8 CGLB
4713       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
4714 *
4715 * parameters for cascade calculations:
4716 * maximum mumber of PDF's which can be defined in phojet (limited
4717 * by the dimension of ipdfs in pho_setpdf)
4718       PARAMETER (MAXPDF = 20)
4719 * PDF parametrization and number of set for the first 30 hadrons in
4720 * the bamjet-code list
4721 *   negative numbers mean that the PDF is set in phojet,
4722 *   zero stands for "not a hadron"
4723       DIMENSION IPARPD(30),ISETPD(30)
4724 * PDF parametrization
4725       DATA IPARPD /
4726      &  -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5,
4727      &   5, 5,-5, 5, 5, 0, 0, 0, 0, 0/
4728 * number of set
4729       DATA ISETPD /
4730      &  -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6,
4731      &   6, 6,-2, 2, 2, 0, 0, 0, 0, 0/
4732
4733 **PHOJET105a
4734 C     COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
4735 C     PARAMETER ( MAXPRO = 16 )
4736 C     PARAMETER ( MAXTAB = 20 )
4737 C     COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO),
4738 C    &                MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB
4739 C     CHARACTER*8 MDLNA
4740 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
4741 C     COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15)
4742 **PHOJET110
4743 C  global event kinematics and particle IDs
4744       INTEGER IFPAP,IFPAB
4745       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
4746       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
4747 C  hard cross sections and MC selection weights
4748       INTEGER Max_pro_2
4749       PARAMETER ( Max_pro_2 = 16 )
4750       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
4751      &  MH_acc_1,MH_acc_2
4752       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
4753       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
4754      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
4755      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
4756      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
4757      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
4758 C  model switches and parameters
4759       CHARACTER*8 MDLNA
4760       INTEGER ISWMDL,IPAMDL
4761       DOUBLE PRECISION PARMDL
4762       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4763 C  general process information
4764       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4765       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4766 **
4767       DIMENSION PP(4),PT(4)
4768
4769       LOGICAL LSTART
4770       DATA LSTART /.TRUE./
4771
4772       IJP = IJPROJ
4773       IJT = IJTARG
4774       Q2  = VIRT
4775 * lepton-projectiles: initialize real photon instead
4776       IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN
4777          IJP = 7
4778          Q2  = ZERO
4779       ENDIF
4780       IF (LPHOIN) CALL PHO_INIT(-1,LOUT,IDUM)
4781 * switch Reggeon off
4782 C     IPAMDL(3)= 0
4783       IF (IP.EQ.1) THEN
4784          IFPAP(1) = IDT_IPDGHA(IJP)
4785          IFPAB(1) = IJP
4786       ELSE
4787          IFPAP(1) = 2212
4788          IFPAB(1) = IDT_ICIHAD(IFPAP(1))
4789       ENDIF
4790       PMASS(1) = AAM(IFPAB(1))-SQRT(Q2)
4791       PVIRT(1) = PMASS(1)**2
4792       IF (IT.EQ.1) THEN
4793          IFPAP(2) = IDT_IPDGHA(IJT)
4794          IFPAB(2) = IJT
4795       ELSE
4796          IFPAP(2) = 2212
4797          IFPAB(2) = IDT_ICIHAD(IFPAP(2))
4798       ENDIF
4799       PMASS(2) = AAM(IFPAB(2))
4800       PVIRT(2) = ZERO
4801       DO 1 K=1,4
4802          PP(K) = ZERO
4803          PT(K) = ZERO
4804     1 CONTINUE
4805 * get max. possible momenta of incoming particles to be used for PHOJET ini.
4806       PPF = ZERO
4807       PTF = ZERO
4808       SCPF= 1.5D0
4809       IF (UMO.GE.1.E5) THEN
4810          SCPF= 5.0D0
4811       ENDIF
4812       IF (NCOMPO.GT.0) THEN
4813          DO 2 I=1,NCOMPO
4814             IF (IT.GT.1) THEN
4815                CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0)
4816             ELSE
4817                CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0)
4818             ENDIF
4819             PPFTMP = MAX(PFERMP(1),PFERMN(1))
4820             PTFTMP = MAX(PFERMP(2),PFERMN(2))
4821             IF (PPFTMP.GT.PPF) PPF = PPFTMP
4822             IF (PTFTMP.GT.PTF) PTF = PTFTMP
4823     2    CONTINUE
4824       ELSE
4825          CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
4826          PPF = MAX(PFERMP(1),PFERMN(1))
4827          PTF = MAX(PFERMP(2),PFERMN(2))
4828       ENDIF
4829       PTF = -PTF
4830       PPF = SCPF*PPF
4831       PTF = SCPF*PTF
4832       IF (IJP.EQ.7) THEN
4833          AMP2  = SIGN(PMASS(1)**2,PMASS(1))
4834          PP(3) = PPCM
4835          PP(4) = SQRT(AMP2+PP(3)**2)
4836       ELSE
4837          EPF = SQRT(PPF**2+PMASS(1)**2)
4838          CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2)
4839       ENDIF
4840       ETF = SQRT(PTF**2+PMASS(2)**2)
4841       CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3)
4842       ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
4843      &              (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
4844       IF (LSTART) THEN
4845          WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP
4846  1001    FORMAT(
4847      &      ' DT_PHOINI:    PHOJET initialized for projectile A,Z = ',
4848      &      I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
4849          IF (NCOMPO.GT.0) THEN
4850             WRITE(LOUT,1002) SCPF,PTF,PT
4851          ELSE
4852             WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT
4853          ENDIF
4854  1002    FORMAT(
4855      &      ' DT_PHOINI:    PHOJET initialized for target emulsion  ',
4856      &          /,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
4857  1003    FORMAT(
4858      &      ' DT_PHOINI:    PHOJET initialized for target     A,Z = ',
4859      &      I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
4860          WRITE(LOUT,1004) ECMINI
4861  1004    FORMAT(' E_cm = ',E10.3)
4862          IF (IJP.EQ.8) WRITE(LOUT,1005)
4863  1005    FORMAT(
4864      &      ' DT_PHOINI: warning! proton parameters used for neutron',
4865      &          ' projectile')
4866          LSTART = .FALSE.
4867       ENDIF
4868 * switch off new diffractive cross sections at low energies for nuclei
4869 * (temporary solution)
4870       IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN
4871          WRITE(LOUT,'(1X,A)')
4872      &      ' DT_PHOINI: model-switch 30 for nuclei re-set !'
4873          CALL PHO_SETMDL(30,0,1)
4874       ENDIF
4875 *
4876 C     IF (IJP.EQ.7) THEN
4877 C        AMP2  = SIGN(PMASS(1)**2,PMASS(1))
4878 C        PP(3) = PPCM
4879 C        PP(4) = SQRT(AMP2+PP(3)**2)
4880 C     ELSE
4881 C        PFERMX = ZERO
4882 C        IF (IP.GT.1) PFERMX = 0.5D0
4883 C        EFERMX = SQRT(PFERMX**2+PMASS(1)**2)
4884 C        CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2)
4885 C     ENDIF
4886 C     PFERMX = ZERO
4887 C     IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0
4888 C     EFERMX = SQRT(PFERMX**2+PMASS(2)**2)
4889 C     CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3)
4890 **sr 26.10.96
4891       ISAV = IPAMDL(13)
4892       IF ((ISHAD(2).EQ.1).AND.
4893      &   ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR.
4894      &    (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1
4895 **
4896       CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1)
4897 **sr 26.10.96
4898       IPAMDL(13) = ISAV
4899 **
4900 *
4901 * patch for cascade calculations:
4902 * define parton distribution functions for other hadrons, i.e. other
4903 * then defined already in phojet
4904       IF (IOGLB.EQ.100) THEN
4905          WRITE(LOUT,1006)
4906  1006    FORMAT(/,1X,'PHOINI: additional parton distribution functions',
4907      &          ' assiged (ID,IPAR,ISET)',/)
4908          NPDF = 0
4909          DO 3 I=1,30
4910             IF (IPARPD(I).NE.0) THEN
4911                NPDF = NPDF+1
4912                IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !'
4913                IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN
4914                   IDPDG = IDT_IPDGHA(I)
4915                   IPAR  = IPARPD(I)
4916                   ISET  = ISETPD(I)
4917                   WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET
4918                   CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1)
4919                ENDIF
4920             ENDIF
4921     3    CONTINUE
4922       ENDIF
4923
4924 C     CALL PHO_PHIST(-1,SIGMAX)
4925       IF (IREJ1.NE.0) THEN
4926          WRITE(LOUT,1000)
4927  1000    FORMAT(1X,'PHOINI:   PHOJET event-initialization failed!')
4928          STOP
4929       ENDIF
4930
4931       RETURN
4932       END
4933
4934 *$ CREATE DT_EVENTD.FOR
4935 *COPY DT_EVENTD
4936 *
4937 *===eventd=============================================================*
4938 *
4939       SUBROUTINE DT_EVENTD(IREJ)
4940
4941 ************************************************************************
4942 * Quasi-elastic neutrino nucleus scattering.                           *
4943 * This version dated 29.04.00 is written by S. Roesler.                *
4944 ************************************************************************
4945
4946       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4947       SAVE
4948       PARAMETER ( LINP = 10 ,
4949      &            LOUT = 6 ,
4950      &            LDAT = 9 )
4951       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5)
4952       PARAMETER (SQTINF=1.0D+15)
4953
4954       LOGICAL LFIRST
4955
4956 * event history
4957       PARAMETER (NMXHKK=200000)
4958       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4959      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4960      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4961 * extended event history
4962       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4963      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4964      &                IHIST(2,NMXHKK)
4965 * flags for input different options
4966       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4967       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4968      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4969       PARAMETER (MAXLND=4000)
4970       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
4971 * properties of interacting particles
4972       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
4973 * Lorentz-parameters of the current interaction
4974       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4975      &                UMO,PPCM,EPROJ,PPROJ
4976 * nuclear potential
4977       LOGICAL LFERMI
4978       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
4979      &                EBINDP(2),EBINDN(2),EPOT(2,210),
4980      &                ETACOU(2),ICOUL,LFERMI
4981 * steering flags for qel neutrino scattering modules
4982       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
4983       COMMON /QNPOL/ POLARX(4),PMODUL
4984       INTEGER PYK
4985
4986       DATA LFIRST /.TRUE./
4987
4988       IREJ = 0
4989
4990       IF (LFIRST) THEN
4991          LFIRST = .FALSE.
4992          CALL DT_MASS_INI
4993       ENDIF
4994
4995 * JETSET parameter
4996       CALL DT_INITJS(0)
4997
4998 * interacting target nucleon
4999       LTYP = NEUTYP
5000       IF (NEUDEC.LE.9) THEN
5001          IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN
5002             NUCTYP = 2112
5003             NUCTOP = 2
5004          ELSE
5005             NUCTYP = 2212
5006             NUCTOP = 1
5007          ENDIF
5008       ELSE
5009          RTYP  = DT_RNDM(RTYP)
5010          ZFRAC = DBLE(ITZ)/DBLE(IT)
5011          IF (RTYP.LE.ZFRAC) THEN
5012             NUCTYP = 2212
5013             NUCTOP = 1
5014          ELSE
5015             NUCTYP = 2112
5016             NUCTOP = 2
5017          ENDIF
5018       ENDIF
5019
5020 * select first nucleon in list with matching id and reset all other
5021 * nucleons which have been marked as "wounded" by ININUC
5022       IFOUND = 0
5023       DO 1 I=1,NHKK
5024          IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN
5025             ISTHKK(I) = 12
5026             IFOUND    = 1
5027             IDX = I
5028          ELSE
5029             IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14
5030          ENDIF
5031     1 CONTINUE
5032       IF (IFOUND.EQ.0)
5033      &   STOP ' EVENTD: interacting target nucleon not found! '
5034
5035 * correct position of proj. lepton: assume position of target nucleon
5036       DO 3 I=1,4
5037          VHKK(I,1) = VHKK(I,IDX)
5038          WHKK(I,1) = WHKK(I,IDX)
5039     3 CONTINUE
5040
5041 * load initial momenta for conservation check
5042       IF (LEMCCK) THEN
5043          CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM)
5044          CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX),
5045      &                                                      2,IDUM,IDUM)
5046       ENDIF
5047
5048 * quasi-elastic scattering
5049       IF (NEUDEC.LT.9) THEN
5050          CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),
5051      &                                          PHKK(4,IDX),PHKK(5,IDX))
5052 *  CC event on p or n
5053       ELSEIF (NEUDEC.EQ.10) THEN
5054          CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX),
5055      &                     PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5056 *  NC event on p or n
5057       ELSEIF (NEUDEC.EQ.11) THEN
5058          CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX),
5059      &                     PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5060       ENDIF
5061
5062 * get final state particles from Lund-common and write them into HKKEVT
5063       NPOINT(1) = NHKK+1
5064       NPOINT(4) = NHKK+1
5065       NLINES = PYK(0,1)
5066       NHKK0  = NHKK+1
5067       DO 4 I=4,NLINES
5068          IF (K(I,1).EQ.1) THEN
5069             ID = K(I,2)
5070             PX = P(I,1)
5071             PY = P(I,2)
5072             PZ = P(I,3)
5073             PE = P(I,4)
5074             CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0)
5075             IDBJ = IDT_ICIHAD(ID)
5076             EKIN = PHKK(4,NHKK)-PHKK(5,NHKK)
5077             IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN
5078                IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16
5079             ENDIF
5080             VHKK(1,NHKK) = VHKK(1,IDX)
5081             VHKK(2,NHKK) = VHKK(2,IDX)
5082             VHKK(3,NHKK) = VHKK(3,IDX)
5083             VHKK(4,NHKK) = VHKK(4,IDX)
5084 C           IF (I.EQ.4) THEN
5085 C              WHKK(1,NHKK) = POLARX(1)
5086 C              WHKK(2,NHKK) = POLARX(2)
5087 C              WHKK(3,NHKK) = POLARX(3)
5088 C              WHKK(4,NHKK) = POLARX(4)
5089 C           ELSE
5090                WHKK(1,NHKK) = WHKK(1,IDX)
5091                WHKK(2,NHKK) = WHKK(2,IDX)
5092                WHKK(3,NHKK) = WHKK(3,IDX)
5093                WHKK(4,NHKK) = WHKK(4,IDX)
5094 C           ENDIF
5095             IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
5096          ENDIF
5097     4 CONTINUE
5098
5099       IF (LEMCCK) THEN
5100          CHKLEV = TINY5
5101          CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1)
5102          IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
5103       ENDIF
5104
5105 * transform momenta into cms (as required for inc etc.)
5106       DO 5 I=NHKK0,NHKK
5107          IF (ISTHKK(I).EQ.1) THEN
5108             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3)
5109             PHKK(3,I) = PZ
5110             PHKK(4,I) = PE
5111          ENDIF
5112     5 CONTINUE
5113
5114       RETURN
5115       END
5116
5117 *$ CREATE DT_KKEVNT.FOR
5118 *COPY DT_KKEVNT
5119 *
5120 *===kkevnt=============================================================*
5121 *
5122       SUBROUTINE DT_KKEVNT(KKMAT,IREJ)
5123
5124 ************************************************************************
5125 * Treatment of complete nucleus-nucleus or hadron-nucleus scattering   *
5126 * without nuclear effects (one event).                                 *
5127 * This subroutine is an update of the previous version (KKEVT) written *
5128 * by J. Ranft/ H.-J. Moehring.                                         *
5129 * This version dated 20.04.95 is written by S. Roesler                 *
5130 ************************************************************************
5131
5132       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5133       SAVE
5134       PARAMETER ( LINP = 10 ,
5135      &            LOUT = 6 ,
5136      &            LDAT = 9 )
5137       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10)
5138
5139       PARAMETER ( MAXNCL = 260,
5140      &            MAXVQU = MAXNCL,
5141      &            MAXSQU = 20*MAXVQU,
5142      &            MAXINT = MAXVQU+MAXSQU)
5143 * event history
5144       PARAMETER (NMXHKK=200000)
5145       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5146      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5147      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5148 * extended event history
5149       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5150      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5151      &                IHIST(2,NMXHKK)
5152 * flags for input different options
5153       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5154       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5155      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5156 * rejection counter
5157       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
5158      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
5159      &                IREXCI(3),IRDIFF(2),IRINC
5160 * statistics
5161       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5162      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5163      &                ICEVTG(8,0:30)
5164 * properties of interacting particles
5165       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5166 * Lorentz-parameters of the current interaction
5167       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5168      &                UMO,PPCM,EPROJ,PPROJ
5169 * flags for diffractive interactions (DTUNUC 1.x)
5170       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5171 * interface HADRIN-DPM
5172       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5173 * nucleon-nucleon event-generator
5174       CHARACTER*8 CMODEL
5175       LOGICAL LPHOIN
5176       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
5177 * coordinates of nucleons
5178       COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
5179 * interface between Glauber formalism and DPM
5180       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
5181      &                INTER1(MAXINT),INTER2(MAXINT)
5182 * Glauber formalism: collision properties
5183       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5184      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
5185      &                NCP,NCT
5186 * central particle production, impact parameter biasing
5187       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5188 **temporary
5189 * statistics: Glauber-formalism
5190       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5191 **
5192
5193       DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/
5194
5195       IREJ   = 0
5196       ICREQU = ICREQU+1
5197       NC     = 0
5198       NCP    = 0
5199       NCT    = 0
5200
5201     1 CONTINUE
5202       ICSAMP = ICSAMP+1
5203       NC     = NC+1
5204       IF (MOD(NC,10).EQ.0) THEN
5205          WRITE(LOUT,1000) NEVHKK
5206  1000    FORMAT(1X,'KKEVNT: event ',I8,' rejected!')
5207          GOTO 9999
5208       ENDIF
5209
5210 * initialize DTEVT1/DTEVT2
5211       CALL DT_EVTINI
5212
5213 * We need the following only in order to sample nucleon coordinates.
5214 * However we don't have parameters (cross sections, slope etc.)
5215 * for neutrinos available. Therefore switch projectile to proton
5216 * in this case.
5217       IF (MCGENE.EQ.4) THEN
5218          JJPROJ = 1
5219       ELSE
5220          JJPROJ = IJPROJ
5221       ENDIF
5222
5223    10 CONTINUE
5224       IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR.
5225 * make sure that Glauber-formalism is called each time the interaction
5226 * configuration changed
5227      &     (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR.
5228      &     (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN
5229 * sample number of nucleon-nucleon coll. according to Glauber-form.
5230          CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT)
5231          NWTSAM = NN
5232          NWASAM = NP
5233          NWBSAM = NT
5234          NEVOLD = NEVHKK
5235          IPOLD  = IP
5236          ITOLD  = IT
5237          JJPOLD = JJPROJ
5238          EPROLD = EPROJ
5239          DO 8 I=1, IP
5240             NCP = NCP+JSSH(I)
5241 *           WRITE(6,*)' PROJ.NUCL. ',I,' NCOLL = ',NCP
5242     8 CONTINUE
5243          DO 9 I=1, IT
5244             NCT = NCT+JTSH(I)
5245 *           WRITE(6,*)' TAR.NUCL. ',I,' NCOLL = ',NCT
5246     9 CONTINUE
5247       ENDIF
5248
5249 * force diffractive particle production in h-K interactions
5250       IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND.
5251      &    (IP.EQ.1).AND.(NN.NE.1)) THEN
5252          NEVOLD = 0
5253          GOTO 10
5254       ENDIF
5255
5256 * check number of involved proj. nucl. (NP) if central prod.is requested
5257       IF (ICENTR.GT.0) THEN
5258          CALL DT_CHKCEN(IP,IT,NP,NT,IBACK)
5259          IF (IBACK.GT.0) GOTO 10
5260       ENDIF
5261
5262 * get initial nucleon-configuration in projectile and target
5263 * rest-system (including Fermi-momenta if requested)
5264       CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1)
5265       MODE = 2
5266       IF (EPROJ.LE.EHADTH) MODE = 3
5267       CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE)
5268
5269       IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN
5270
5271 * activate HADRIN at low energies (implemented for h-N scattering only)
5272          IF (EPROJ.LE.EHADHI) THEN
5273             IF (EHADTH.LT.ZERO) THEN
5274 *   smooth transition btwn. DPM and HADRIN
5275                FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO)
5276                RR   = DT_RNDM(FRAC)
5277                IF (RR.GT.FRAC) THEN
5278                   IF (IP.EQ.1) THEN
5279                      CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5280                      IF (IREJ1.GT.0) GOTO 1
5281                      RETURN
5282                   ELSE
5283                      WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5284                   ENDIF
5285                ENDIF
5286             ELSE
5287 *   fixed threshold for onset of production via HADRIN
5288                IF (EPROJ.LE.EHADTH) THEN
5289                   IF (IP.EQ.1) THEN
5290                      CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5291                      IF (IREJ1.GT.0) GOTO 1
5292                      RETURN
5293                   ELSE
5294                      WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5295                   ENDIF
5296                ENDIF
5297             ENDIF
5298          ENDIF
5299  1001    FORMAT(1X,'KKEVNT:   warning! interaction of proj. (m=',
5300      &          I3,') with target (m=',I3,')',/,11X,
5301      &          'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1,
5302      &          'GeV) cannot be handled')
5303
5304 * sampling of momentum-x fractions & flavors of chain ends
5305          CALL DT_SPLPTN(NN)
5306
5307 * Lorentz-transformation of wounded nucleons into nucl.-nucl. cms
5308          CALL DT_NUC2CM
5309
5310 * collect momenta of chain ends and put them into DTEVT1
5311          CALL DT_GETPTN(IP,NN,NCSY,IREJ1)
5312          IF (IREJ1.NE.0) GOTO 1
5313
5314       ENDIF
5315
5316 * handle chains including fragmentation (two-chain approximation)
5317       IF (MCGENE.EQ.1) THEN
5318 *  two-chain approximation
5319          CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1)
5320          IF (IREJ1.NE.0) THEN
5321             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT'
5322             GOTO 1
5323          ENDIF
5324       ELSEIF (MCGENE.EQ.2) THEN
5325 *  multiple-Po exchange including minijets
5326          CALL DT_EVENTB(NCSY,IREJ1)
5327          IF (IREJ1.NE.0) THEN
5328             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT'
5329             GOTO 1
5330          ENDIF
5331       ELSEIF (MCGENE.EQ.3) THEN
5332          STOP ' This version does not contain LEPTO !'
5333       ELSEIF (MCGENE.EQ.4) THEN
5334 *  quasi-elastic neutrino scattering
5335          CALL DT_EVENTD(IREJ1)
5336          IF (IREJ1.NE.0) THEN
5337             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT'
5338             GOTO 1
5339          ENDIF
5340       ELSE
5341          WRITE(LOUT,1002) MCGENE
5342  1002    FORMAT(1X,'KKEVNT:   warning! event-generator',I4,
5343      &         ' not available - program stopped')
5344          STOP
5345       ENDIF
5346
5347       RETURN
5348
5349  9999 CONTINUE
5350       IREJ = 1
5351       RETURN
5352       END
5353
5354 *$ CREATE DT_CHKCEN.FOR
5355 *COPY DT_CHKCEN
5356 *
5357 *===chkcen=============================================================*
5358 *
5359       SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK)
5360
5361 ************************************************************************
5362 * Check of number of involved projectile nucleons if central production*
5363 * is requested.                                                        *
5364 * Adopted from a part of the old KKEVT routine which was written by    *
5365 * J. Ranft/H.-J.Moehring.                                              *
5366 * This version dated 13.01.95 is written by S. Roesler                 *
5367 ************************************************************************
5368
5369       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5370       SAVE
5371       PARAMETER ( LINP = 10 ,
5372      &            LOUT = 6 ,
5373      &            LDAT = 9 )
5374
5375 * statistics
5376       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5377      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5378      &                ICEVTG(8,0:30)
5379 * central particle production, impact parameter biasing
5380       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5381
5382       IBACK = 0
5383
5384 * old version
5385       IF (ICENTR.EQ.2) THEN
5386          IF (IP.LT.IT) THEN
5387             IF (IP.LE.8) THEN
5388                IF (NP.LT.IP-1) IBACK = 1
5389             ELSEIF (IP.LE.16) THEN
5390                IF (NP.LT.IP-2) IBACK = 1
5391             ELSEIF (IP.LE.32) THEN
5392                IF (NP.LT.IP-3) IBACK = 1
5393             ELSEIF (IP.GE.33) THEN
5394                IF (NP.LT.IP-5) IBACK = 1
5395             ENDIF
5396          ELSEIF (IP.EQ.IT) THEN
5397             IF (IP.EQ.32) THEN
5398                IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5399             ELSE
5400                IF (NP.LT.IP-IP/8) IBACK = 1
5401             ENDIF
5402          ELSEIF (ABS(IP-IT).LT.3) THEN
5403             IF (NP.LT.IP-IP/8) IBACK = 1
5404          ENDIF
5405       ELSE
5406 * new version (DPMJET, 5.6.99)
5407          IF (IP.LT.IT) THEN
5408             IF (IP.LE.8) THEN
5409                IF (NP.LT.IP-1) IBACK = 1
5410             ELSEIF (IP.LE.16) THEN
5411                IF (NP.LT.IP-2) IBACK = 1
5412             ELSEIF (IP.LT.32) THEN
5413                IF (NP.LT.IP-3) IBACK = 1
5414             ELSEIF (IP.GE.32) THEN
5415                IF (IT.LE.150) THEN
5416 *   Example: S-Ag
5417                   IF (NP.LT.IP-1) IBACK = 1
5418                ELSE
5419 *   Example: S-Au
5420                   IF (NP.LT.IP) IBACK = 1
5421                ENDIF
5422             ENDIF
5423          ELSEIF (IP.EQ.IT) THEN
5424 *   Example: S-S
5425            IF (IP.EQ.32) THEN
5426               IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5427 *   Example: Pb-Pb
5428            ELSE
5429               IF (NP.LT.IP-IP/4) IBACK = 1
5430            ENDIF
5431          ELSEIF (ABS(IP-IT).LT.3) THEN
5432             IF (NP.LT.IP-IP/8) IBACK = 1
5433          ENDIF
5434       ENDIF
5435
5436       ICCPRO = ICCPRO+1
5437
5438       RETURN
5439       END
5440
5441 *$ CREATE DT_ININUC.FOR
5442 *COPY DT_ININUC
5443 *
5444 *===ininuc=============================================================*
5445 *
5446       SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE)
5447
5448 ************************************************************************
5449 * Samples initial configuration of nucleons in nucleus with mass NMASS *
5450 * including Fermi-momenta (if reqested).                               *
5451 *          ID             BAMJET-code for hadrons (instead of nuclei)  *
5452 *          NMASS          mass number of nucleus (number of nucleons)  *
5453 *          NCH            charge of nucleus                            *
5454 *          COORD(3,NMASS) coordinates of nucleons inside nucleus in fm *
5455 *          JS(NMASS) > 0  nucleon undergoes nucleon-nucleon interact.  *
5456 *          IMODE = 1      projectile nucleus                           *
5457 *                = 2      target     nucleus                           *
5458 *                = 3      target     nucleus (E_lab<E_thr for HADRIN)  *
5459 * Adopted from a part of the old KKEVT routine which was written by    *
5460 * J. Ranft/H.-J.Moehring.                                              *
5461 * This version dated 13.01.95 is written by S. Roesler                 *
5462 ************************************************************************
5463
5464       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5465       SAVE
5466       PARAMETER ( LINP = 10 ,
5467      &            LOUT = 6 ,
5468      &            LDAT = 9 )
5469       PARAMETER (FM2MM=1.0D-12)
5470
5471       PARAMETER ( MAXNCL = 260,
5472      &            MAXVQU = MAXNCL,
5473      &            MAXSQU = 20*MAXVQU,
5474      &            MAXINT = MAXVQU+MAXSQU)
5475 * event history
5476       PARAMETER (NMXHKK=200000)
5477       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5478      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5479      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5480 * extended event history
5481       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5482      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5483      &                IHIST(2,NMXHKK)
5484 * flags for input different options
5485       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5486       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5487      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5488 * auxiliary common for chain system storage (DTUNUC 1.x)
5489       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5490 * nuclear potential
5491       LOGICAL LFERMI
5492       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5493      &                EBINDP(2),EBINDN(2),EPOT(2,210),
5494      &                ETACOU(2),ICOUL,LFERMI
5495 * properties of photon/lepton projectiles
5496       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5497 * particle properties (BAMJET index convention)
5498       CHARACTER*8  ANAME
5499       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5500      &                IICH(210),IIBAR(210),K1(210),K2(210)
5501 * Glauber formalism: collision properties
5502       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5503      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5504 * flavors of partons (DTUNUC 1.x)
5505       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5506      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5507      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
5508      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5509      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
5510      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5511      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
5512 * interface HADRIN-DPM
5513       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5514
5515       DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL)
5516
5517 * number of neutrons
5518       NNEU = NMASS-NCH
5519 * initializations
5520       NP = 0
5521       NN = 0
5522       DO 1 K=1,4
5523          PFTOT(K) = 0.0D0
5524     1 CONTINUE
5525       MODE   = IMODE
5526       IF (IMODE.GT.2) MODE = 2
5527 **sr 29.5. new NPOINT(1)-definition
5528 C     IF (IMODE.GE.2) NPOINT(1) = NHKK+1
5529 **
5530       NHADRI = 0
5531       NC     = NHKK
5532
5533 * get initial configuration
5534       DO 2 I=1,NMASS
5535          NHKK = NHKK+1
5536          IF (JS(I).GT.0) THEN
5537             ISTHKK(NHKK) = 10+MODE
5538             IF (IMODE.EQ.3) THEN
5539 *   additional treatment if HADRIN-generator is requested
5540                NHADRI = NHADRI+1
5541                IF (NHADRI.EQ.1) IDXTA  = NHKK
5542                IF (NHADRI.GT.1) ISTHKK(NHKK) = 14
5543             ENDIF
5544          ELSE
5545             ISTHKK(NHKK) = 12+MODE
5546          ENDIF
5547          IF (NMASS.GE.2) THEN
5548 *   treatment for nuclei
5549             FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS)
5550             RR   = DT_RNDM(FRAC)
5551             IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN
5552                IDX = 8
5553                NN  = NN+1
5554             ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN
5555                IDX = 1
5556                NP  = NP+1
5557             ELSEIF (NN.LT.NNEU) THEN
5558                IDX = 8
5559                NN  = NN+1
5560             ELSEIF (NP.LT.NCH)  THEN
5561                IDX = 1
5562                NP  = NP+1
5563             ENDIF
5564             IDHKK(NHKK) = IDT_IPDGHA(IDX)
5565             IDBAM(NHKK) = IDX
5566             IF (MODE.EQ.1) THEN
5567                IPOSP(I)  = NHKK
5568                KKPROJ(I) = IDX
5569             ELSE
5570                IPOST(I)  = NHKK
5571                KKTARG(I) = IDX
5572             ENDIF
5573             IF (IDX.EQ.1) THEN
5574                PFER = PFERMP(MODE)
5575                PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1))
5576             ELSE
5577                PFER = PFERMN(MODE)
5578                PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8))
5579             ENDIF
5580             CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX)
5581             DO 3 K=1,4
5582                PFTOT(K) = PFTOT(K)+PF(K)
5583                PHKK(K,NHKK) = PF(K)
5584     3       CONTINUE
5585             PHKK(5,NHKK) = AAM(IDX)
5586          ELSE
5587 *   treatment for hadrons
5588             IDHKK(NHKK)  = IDT_IPDGHA(ID)
5589             IDBAM(NHKK)  = ID
5590             PHKK(4,NHKK) = AAM(ID)
5591             PHKK(5,NHKK) = AAM(ID)
5592 C* VDM assumption
5593 C            IF (IDHKK(NHKK).EQ.22) THEN
5594 C               PHKK(4,NHKK) = AAM(33)
5595 C               PHKK(5,NHKK) = AAM(33)
5596 C            ENDIF
5597             IF (MODE.EQ.1) THEN
5598                IPOSP(I)  = NHKK
5599                KKPROJ(I) = ID
5600                PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
5601             ELSE
5602                IPOST(I)  = NHKK
5603                KKTARG(I) = ID
5604             ENDIF
5605          ENDIF
5606          DO 4 K=1,3
5607             VHKK(K,NHKK) = COORD(K,I)*FM2MM
5608             WHKK(K,NHKK) = COORD(K,I)*FM2MM
5609     4    CONTINUE
5610          IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM
5611          IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM
5612          VHKK(4,NHKK) = 0.0D0
5613          WHKK(4,NHKK) = 0.0D0
5614     2 CONTINUE
5615
5616 * balance Fermi-momenta
5617       IF (NMASS.GE.2) THEN
5618          DO 5 I=1,NMASS
5619             NC = NC+1
5620             DO 6 K=1,3
5621                PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
5622     6       CONTINUE
5623             PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
5624      &                        PHKK(2,NC)**2+PHKK(3,NC)**2)
5625     5    CONTINUE
5626       ENDIF
5627
5628       RETURN
5629       END
5630
5631 *$ CREATE DT_FER4M.FOR
5632 *COPY DT_FER4M
5633 *
5634 *===fer4m==============================================================*
5635 *
5636       SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
5637
5638 ************************************************************************
5639 * Sampling of nucleon Fermi-momenta from distributions at T=0.         *
5640 *                                   processed by S. Roesler, 17.10.95  *
5641 ************************************************************************
5642
5643       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5644       SAVE
5645       PARAMETER ( LINP = 10 ,
5646      &            LOUT = 6 ,
5647      &            LDAT = 9 )
5648
5649       LOGICAL LSTART
5650
5651 * particle properties (BAMJET index convention)
5652       CHARACTER*8  ANAME
5653       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5654      &                IICH(210),IIBAR(210),K1(210),K2(210)
5655 * nuclear potential
5656       LOGICAL LFERMI
5657       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5658      &                EBINDP(2),EBINDN(2),EPOT(2,210),
5659      &                ETACOU(2),ICOUL,LFERMI
5660
5661       DATA LSTART /.TRUE./
5662
5663       ILOOP = 0
5664       IF (LFERMI) THEN
5665          IF (LSTART) THEN
5666             WRITE(LOUT,1000)
5667  1000       FORMAT(/,1X,'FER4M:   sampling of Fermi-momenta activated')
5668             LSTART = .FALSE.
5669          ENDIF
5670     1    CONTINUE
5671          CALL DT_DFERMI(PABS)
5672          PABS = PFERM*PABS
5673 C        IF (PABS.GE.PBIND) THEN
5674 C           ILOOP = ILOOP+1
5675 C           IF (MOD(ILOOP,500).EQ.0) THEN
5676 C              WRITE(LOUT,1001) PABS,PBIND,ILOOP
5677 C1001          FORMAT(1X,'FER4M:    Fermi-mom. corr. for binding',
5678 C    &                ' energy ',2E12.3,I6)
5679 C           ENDIF
5680 C           GOTO 1
5681 C        ENDIF
5682          CALL DT_DPOLI(POLC,POLS)
5683          CALL DT_DSFECF(SFE,CFE)
5684          CXTA = POLS*CFE
5685          CYTA = POLS*SFE
5686          CZTA = POLC
5687          ET   = SQRT(PABS*PABS+AAM(KT)**2)
5688          PXT  = CXTA*PABS
5689          PYT  = CYTA*PABS
5690          PZT  = CZTA*PABS
5691       ELSE
5692          ET   = AAM(KT)
5693          PXT  = 0.0D0
5694          PYT  = 0.0D0
5695          PZT  = 0.0D0
5696       ENDIF
5697
5698       RETURN
5699       END
5700
5701 *$ CREATE DT_NUC2CM.FOR
5702 *COPY DT_NUC2CM
5703 *
5704 *===nuc2cm=============================================================*
5705 *
5706       SUBROUTINE DT_NUC2CM
5707
5708 ************************************************************************
5709 * Lorentz-transformation of all wounded nucleons from Lab. to nucl.-   *
5710 * nucl. cms. (This subroutine replaces NUCMOM.)                        *
5711 * This version dated 15.01.95 is written by S. Roesler                 *
5712 ************************************************************************
5713
5714       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5715       SAVE
5716       PARAMETER ( LINP = 10 ,
5717      &            LOUT = 6 ,
5718      &            LDAT = 9 )
5719       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
5720
5721 * event history
5722       PARAMETER (NMXHKK=200000)
5723       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5724      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5725      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5726 * extended event history
5727       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5728      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5729      &                IHIST(2,NMXHKK)
5730 * statistics
5731       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5732      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5733      &                ICEVTG(8,0:30)
5734 * properties of photon/lepton projectiles
5735       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5736 * particle properties (BAMJET index convention)
5737       CHARACTER*8  ANAME
5738       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5739      &                IICH(210),IIBAR(210),K1(210),K2(210)
5740 * Glauber formalism: collision properties
5741       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5742      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5743 **temporary
5744 * statistics: Glauber-formalism
5745       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5746 **
5747
5748       ICWP = 0
5749       ICWT = 0
5750       NWTACC = 0
5751       NWAACC = 0
5752       NWBACC = 0
5753
5754       NPOINT(1) = NHKK+1
5755       NEND      = NHKK
5756       DO 1 I=1,NEND
5757          IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN
5758             IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1
5759             IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1
5760             MODE = ISTHKK(I)-9
5761 C            IF (IDHKK(I).EQ.22) THEN
5762 C* VDM assumption
5763 C               PEIN = AAM(33)
5764 C               IDB  = 33
5765 C            ELSE
5766 C               PEIN = PHKK(4,I)
5767 C               IDB  = IDBAM(I)
5768 C            ENDIF
5769 C            CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
5770 C     &           PX,PY,PZ,PE,IDB,MODE)
5771             IF (PHKK(5,I).GT.ZERO) THEN
5772                CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
5773      &              PX,PY,PZ,PE,IDBAM(I),MODE)
5774             ELSE
5775                PX = PGAMM(1)
5776                PY = PGAMM(2)
5777                PZ = PGAMM(3)
5778                PE = PGAMM(4)
5779             ENDIF
5780             IST = ISTHKK(I)-2
5781             ID  = IDHKK(I)
5782 C* VDM assumption
5783 C            IF (ID.EQ.22) ID = 113
5784             CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0)
5785             IF (ISTHKK(I).EQ.11) ICWP = ICWP+1
5786             IF (ISTHKK(I).EQ.12) ICWT = ICWT+1
5787          ENDIF
5788     1 CONTINUE
5789
5790       NWTACC = MAX(NWAACC,NWBACC)
5791       ICDPR  = ICDPR+ICWP
5792       ICDTA  = ICDTA+ICWT
5793 **temporary
5794       IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
5795          CALL DT_EVTOUT(4)
5796          STOP
5797       ENDIF
5798
5799       RETURN
5800       END
5801
5802 *$ CREATE DT_SPLPTN.FOR
5803 *COPY DT_SPLPTN
5804 *
5805 *===splptn=============================================================*
5806 *
5807       SUBROUTINE DT_SPLPTN(NN)
5808
5809 ************************************************************************
5810 * SamPLing of ParToN momenta and flavors.                              *
5811 * This version dated 15.01.95 is written by S. Roesler                 *
5812 ************************************************************************
5813
5814       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5815       SAVE
5816       PARAMETER ( LINP = 10 ,
5817      &            LOUT = 6 ,
5818      &            LDAT = 9 )
5819
5820 * Lorentz-parameters of the current interaction
5821       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5822      &                UMO,PPCM,EPROJ,PPROJ
5823
5824 * sample flavors of sea-quarks
5825       CALL DT_SPLFLA(NN,1)
5826
5827 * sample x-values of partons at chain ends
5828       ECM = UMO
5829       CALL DT_XKSAMP(NN,ECM)
5830
5831 * samle flavors
5832       CALL DT_SPLFLA(NN,2)
5833
5834       RETURN
5835       END
5836
5837 *$ CREATE DT_SPLFLA.FOR
5838 *COPY DT_SPLFLA
5839 *
5840 *===splfla=============================================================*
5841 *
5842       SUBROUTINE DT_SPLFLA(NN,MODE)
5843
5844 ************************************************************************
5845 * SamPLing of FLAvors of partons at chain ends.                        *
5846 * This subroutine replaces FLKSAA/FLKSAM.                              *
5847 *            NN            number of nucleon-nucleon interactions      *
5848 *            MODE = 1      sea-flavors                                 *
5849 *                 = 2      valence-flavors                             *
5850 * Based on the original version written by J. Ranft/H.-J. Moehring.    *
5851 * This version dated 16.01.95 is written by S. Roesler                 *
5852 ************************************************************************
5853
5854       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5855       SAVE
5856       PARAMETER ( LINP = 10 ,
5857      &            LOUT = 6 ,
5858      &            LDAT = 9 )
5859
5860       PARAMETER ( MAXNCL = 260,
5861      &            MAXVQU = MAXNCL,
5862      &            MAXSQU = 20*MAXVQU,
5863      &            MAXINT = MAXVQU+MAXSQU)
5864 * flavors of partons (DTUNUC 1.x)
5865       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5866      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5867      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
5868      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5869      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
5870      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5871      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
5872 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5873       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
5874      &                IXPV,IXPS,IXTV,IXTS,
5875      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
5876      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
5877      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
5878      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
5879      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
5880      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
5881      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
5882      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
5883 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5884       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
5885      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
5886 * particle properties (BAMJET index convention)
5887       CHARACTER*8  ANAME
5888       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5889      &                IICH(210),IIBAR(210),K1(210),K2(210)
5890 * various options for treatment of partons (DTUNUC 1.x)
5891 * (chain recombination, Cronin,..)
5892       LOGICAL LCO2CR,LINTPT
5893       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
5894      &                LCO2CR,LINTPT
5895
5896       IF (MODE.EQ.1) THEN
5897 * sea-flavors
5898          DO 1 I=1,NN
5899             IPSQ(I)  = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5900             IPSAQ(I) = -IPSQ(I)
5901     1    CONTINUE
5902          DO 2 I=1,NN
5903             ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5904             ITSAQ(I)= -ITSQ(I)
5905     2    CONTINUE
5906       ELSEIF (MODE.EQ.2) THEN
5907 * valence flavors
5908          DO 3 I=1,IXPV
5909             CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
5910     3    CONTINUE
5911          DO 4 I=1,IXTV
5912             CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
5913     4    CONTINUE
5914       ENDIF
5915
5916       RETURN
5917       END
5918
5919 *$ CREATE DT_GETPTN.FOR
5920 *COPY DT_GETPTN
5921 *
5922 *===getptn=============================================================*
5923 *
5924       SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
5925
5926 ************************************************************************
5927 * This subroutine collects partons at chain ends from temporary        *
5928 * commons and puts them into DTEVT1.                                   *
5929 * This version dated 15.01.95 is written by S. Roesler                 *
5930 ************************************************************************
5931
5932       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5933       SAVE
5934       PARAMETER ( LINP = 10 ,
5935      &            LOUT = 6 ,
5936      &            LDAT = 9 )
5937       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
5938
5939       LOGICAL LCHK
5940
5941       PARAMETER ( MAXNCL = 260,
5942      &            MAXVQU = MAXNCL,
5943      &            MAXSQU = 20*MAXVQU,
5944      &            MAXINT = MAXVQU+MAXSQU)
5945 * event history
5946       PARAMETER (NMXHKK=200000)
5947       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5948      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5949      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5950 * extended event history
5951       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5952      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5953      &                IHIST(2,NMXHKK)
5954 * flags for input different options
5955       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5956       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5957      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5958 * auxiliary common for chain system storage (DTUNUC 1.x)
5959       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5960 * statistics
5961       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5962      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5963      &                ICEVTG(8,0:30)
5964 * flags for diffractive interactions (DTUNUC 1.x)
5965       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5966 * x-values of partons (DTUNUC 1.x)
5967       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
5968      &                XTVQ(MAXVQU),XTVD(MAXVQU),
5969      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
5970      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
5971 * flavors of partons (DTUNUC 1.x)
5972       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5973      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5974      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
5975      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5976      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
5977      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5978      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
5979 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5980       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
5981      &                IXPV,IXPS,IXTV,IXTS,
5982      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
5983      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
5984      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
5985      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
5986      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
5987      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
5988      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
5989      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
5990 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5991       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
5992      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
5993
5994       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
5995
5996       DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
5997
5998       IREJ      = 0
5999       NCSY      = 0
6000       NPOINT(2) = NHKK+1
6001
6002 * sea-sea chains
6003       DO 10 I=1,NSS
6004          IF (ISKPCH(1,I).EQ.99) GOTO 10
6005          ICCHAI(1,1) = ICCHAI(1,1)+2
6006          IDXP = INTSS1(I)
6007          IDXT = INTSS2(I)
6008          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6009          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6010          DO 11 K=1,4
6011             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6012             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6013             PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6014             PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6015    11    CONTINUE
6016          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6017      &                                  +(PP1(3)+PT1(3))**2)
6018          ECH   = PP1(4)+PT1(4)
6019          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6020          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6021      &                                  +(PP2(3)+PT2(3))**2)
6022          ECH   = PP2(4)+PT2(4)
6023          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6024          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6025             AM1 = SQRT(AM1)
6026             AM2 = SQRT(AM2)
6027             IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
6028 C              WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6029  5000          FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
6030             ENDIF
6031          ELSE
6032             WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6033          ENDIF
6034          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6035          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6036          IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6037          IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6038          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6039      &                                                    0,0,1)
6040          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6041      &                                                    0,0,1)
6042          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6043      &                                                    0,0,1)
6044          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6045      &                                                    0,0,1)
6046          NCSY = NCSY+1
6047    10 CONTINUE
6048
6049 * disea-sea chains
6050       DO 20 I=1,NDS
6051          IF (ISKPCH(2,I).EQ.99) GOTO 20
6052          ICCHAI(1,2) = ICCHAI(1,2)+2
6053          IDXP = INTDS1(I)
6054          IDXT = INTDS2(I)
6055          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6056          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6057          DO 21 K=1,4
6058             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6059             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6060             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6061             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6062    21    CONTINUE
6063          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6064      &                                  +(PP1(3)+PT1(3))**2)
6065          ECH   = PP1(4)+PT1(4)
6066          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6067          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6068      &                                  +(PP2(3)+PT2(3))**2)
6069          ECH   = PP2(4)+PT2(4)
6070          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6071          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6072             AM1 = SQRT(AM1)
6073             AM2 = SQRT(AM2)
6074             IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6075 C              WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6076  5001          FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
6077             ENDIF
6078          ELSE
6079             WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6080          ENDIF
6081          IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6082          IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6083          IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6084          IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6085          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6086      &                                                    0,0,2)
6087          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6088      &                                                    0,0,2)
6089          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6090      &                                                    0,0,2)
6091          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6092      &                                                    0,0,2)
6093          NCSY = NCSY+1
6094    20 CONTINUE
6095
6096 * sea-disea chains
6097       DO 30 I=1,NSD
6098          IF (ISKPCH(3,I).EQ.99) GOTO 30
6099          ICCHAI(1,3) = ICCHAI(1,3)+2
6100          IDXP = INTSD1(I)
6101          IDXT = INTSD2(I)
6102          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6103          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6104          DO 31 K=1,4
6105             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6106             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6107             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6108             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6109    31    CONTINUE
6110          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6111      &                                  +(PP1(3)+PT1(3))**2)
6112          ECH   = PP1(4)+PT1(4)
6113          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6114          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6115      &                                  +(PP2(3)+PT2(3))**2)
6116          ECH   = PP2(4)+PT2(4)
6117          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6118          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6119             AM1 = SQRT(AM1)
6120             AM2 = SQRT(AM2)
6121             IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6122 C              WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6123  5002          FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
6124             ENDIF
6125          ELSE
6126             WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6127          ENDIF
6128          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6129          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6130          IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6131          IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6132          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6133      &                                                    0,0,3)
6134          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6135      &                                                    0,0,3)
6136          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6137      &                                                    0,0,3)
6138          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6139      &                                                    0,0,3)
6140          NCSY = NCSY+1
6141    30 CONTINUE
6142
6143 * disea-valence chains
6144       DO 50 I=1,NDV
6145          IF (ISKPCH(5,I).EQ.99) GOTO 50
6146          ICCHAI(1,5) = ICCHAI(1,5)+2
6147          IDXP = INTDV1(I)
6148          IDXT = INTDV2(I)
6149          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6150          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6151          DO 51 K=1,4
6152             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6153             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6154             PT1(K) = XTVQ(IDXT) *PHKK(K,MOT)
6155             PT2(K) = XTVD(IDXT) *PHKK(K,MOT)
6156    51    CONTINUE
6157          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6158      &                                  +(PP1(3)+PT1(3))**2)
6159          ECH   = PP1(4)+PT1(4)
6160          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6161          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6162      &                                  +(PP2(3)+PT2(3))**2)
6163          ECH   = PP2(4)+PT2(4)
6164          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6165          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6166             AM1 = SQRT(AM1)
6167             AM2 = SQRT(AM2)
6168             IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6169 C              WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6170  5003          FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
6171             ENDIF
6172          ELSE
6173             WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6174          ENDIF
6175          IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6176          IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6177          IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6178          IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6179          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6180      &                                                    0,0,5)
6181          CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6182      &                                                    0,0,5)
6183          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6184      &                                                    0,0,5)
6185          CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6186      &                                                    0,0,5)
6187          NCSY = NCSY+1
6188    50 CONTINUE
6189
6190 * valence-sea chains
6191       DO 60 I=1,NVS
6192          IF (ISKPCH(6,I).EQ.99) GOTO 60
6193          ICCHAI(1,6) = ICCHAI(1,6)+2
6194          IDXP = INTVS1(I)
6195          IDXT = INTVS2(I)
6196          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6197          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6198          DO 61 K=1,4
6199             PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6200             PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6201             PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6202             PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6203    61    CONTINUE
6204          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6205          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6206          IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6207          IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6208          CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6209          IF (LCHK) THEN
6210             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6211      &                                                       0,0,6)
6212             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6213      &                                                       0,0,6)
6214             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6215      &                                                       0,0,6)
6216             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6217      &                                                       0,0,6)
6218             PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6219      &                                     +(PP1(3)+PT1(3))**2)
6220             ECH   = PP1(4)+PT1(4)
6221             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6222             PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6223      &                                     +(PP2(3)+PT2(3))**2)
6224             ECH   = PP2(4)+PT2(4)
6225             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6226          ELSE
6227             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6228      &                                                       0,0,6)
6229             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6230      &                                                       0,0,6)
6231             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6232      &                                                       0,0,6)
6233             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6234      &                                                       0,0,6)
6235             PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6236      &                                     +(PP1(3)+PT2(3))**2)
6237             ECH   = PP1(4)+PT2(4)
6238             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6239             PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6240      &                                     +(PP2(3)+PT1(3))**2)
6241             ECH   = PP2(4)+PT1(4)
6242             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6243          ENDIF
6244          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6245             AM1 = SQRT(AM1)
6246             AM2 = SQRT(AM2)
6247             IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
6248 C              WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6249  5004          FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
6250             ENDIF
6251          ELSE
6252             WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6253          ENDIF
6254          NCSY = NCSY+1
6255    60 CONTINUE
6256
6257 * sea-valence chains
6258       DO 40 I=1,NSV
6259          IF (ISKPCH(4,I).EQ.99) GOTO 40
6260          ICCHAI(1,4) = ICCHAI(1,4)+2
6261          IDXP = INTSV1(I)
6262          IDXT = INTSV2(I)
6263          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6264          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6265          DO 41 K=1,4
6266             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6267             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6268             PT1(K) = XTVD(IDXT) *PHKK(K,MOT)
6269             PT2(K) = XTVQ(IDXT) *PHKK(K,MOT)
6270    41    CONTINUE
6271          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6272      &                                  +(PP1(3)+PT1(3))**2)
6273          ECH   = PP1(4)+PT1(4)
6274          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6275          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6276      &                                  +(PP2(3)+PT2(3))**2)
6277          ECH   = PP2(4)+PT2(4)
6278          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6279          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6280             AM1 = SQRT(AM1)
6281             AM2 = SQRT(AM2)
6282             IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
6283 C              WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6284  5005          FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
6285             ENDIF
6286          ELSE
6287             WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6288          ENDIF
6289          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6290          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6291          IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6292          IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6293          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6294      &                                                    0,0,4)
6295          CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6296      &                                                    0,0,4)
6297          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6298      &                                                    0,0,4)
6299          CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6300      &                                                    0,0,4)
6301          NCSY = NCSY+1
6302    40 CONTINUE
6303
6304 * valence-disea chains
6305       DO 70 I=1,NVD
6306          IF (ISKPCH(7,I).EQ.99) GOTO 70
6307          ICCHAI(1,7) = ICCHAI(1,7)+2
6308          IDXP = INTVD1(I)
6309          IDXT = INTVD2(I)
6310          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6311          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6312          DO 71 K=1,4
6313             PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6314             PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6315             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6316             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6317    71    CONTINUE
6318          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6319          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6320          IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6321          IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6322          CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6323          IF (LCHK) THEN
6324             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6325      &                                                       0,0,7)
6326             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6327      &                                                       0,0,7)
6328             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6329      &                                                       0,0,7)
6330             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6331      &                                                       0,0,7)
6332             PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6333      &                                     +(PP1(3)+PT1(3))**2)
6334             ECH   = PP1(4)+PT1(4)
6335             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6336             PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6337      &                                     +(PP2(3)+PT2(3))**2)
6338             ECH   = PP2(4)+PT2(4)
6339             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6340          ELSE
6341             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6342      &                                                       0,0,7)
6343             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6344      &                                                       0,0,7)
6345             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6346      &                                                       0,0,7)
6347             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6348      &                                                       0,0,7)
6349             PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6350      &                                     +(PP1(3)+PT2(3))**2)
6351             ECH   = PP1(4)+PT2(4)
6352             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6353             PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6354      &                                     +(PP2(3)+PT1(3))**2)
6355             ECH   = PP2(4)+PT1(4)
6356             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6357          ENDIF
6358          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6359             AM1 = SQRT(AM1)
6360             AM2 = SQRT(AM2)
6361             IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6362 C              WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6363  5006          FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
6364             ENDIF
6365          ELSE
6366             WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6367          ENDIF
6368          NCSY = NCSY+1
6369    70 CONTINUE
6370
6371 * valence-valence chains
6372       DO 80 I=1,NVV
6373          IF (ISKPCH(8,I).EQ.99) GOTO 80
6374          ICCHAI(1,8) = ICCHAI(1,8)+2
6375          IDXP = INTVV1(I)
6376          IDXT = INTVV2(I)
6377          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6378          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6379          DO 81 K=1,4
6380             PP1(K) = XPVQ(IDXP)*PHKK(K,MOP)
6381             PP2(K) = XPVD(IDXP)*PHKK(K,MOP)
6382             PT1(K) = XTVD(IDXT)*PHKK(K,MOT)
6383             PT2(K) = XTVQ(IDXT)*PHKK(K,MOT)
6384    81    CONTINUE
6385          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6386          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6387          IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6388          IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6389
6390 * check for diffractive event
6391          IDIFF = 0
6392          IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
6393      &        (IP.EQ.1).AND.(NN.EQ.1)) THEN
6394             DO 800 K=1,4
6395                PP(K) = PP1(K)+PP2(K)
6396                PT(K) = PT1(K)+PT2(K)
6397   800       CONTINUE
6398             ISTCK = NHKK
6399             CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
6400      &                  IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
6401 C           IF (IREJ1.NE.0) GOTO 9999
6402             IF (IREJ1.NE.0) THEN
6403                IDIFF = 0
6404                NHKK  = ISTCK
6405             ENDIF
6406          ELSE
6407             IDIFF = 0
6408          ENDIF
6409
6410          IF (IDIFF.EQ.0) THEN
6411 *   valence-valence chain system
6412             CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6413             IF (LCHK) THEN
6414 *    baryon-baryon
6415                CALL DT_EVTPUT(-21,IFP1,MOP,0,
6416      &                     PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6417                CALL DT_EVTPUT(-22,IFT1,MOT,0,
6418      &                     PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6419                CALL DT_EVTPUT(-21,IFP2,MOP,0,
6420      &                     PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6421                CALL DT_EVTPUT(-22,IFT2,MOT,0,
6422      &                     PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6423                PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6424      &                                        +(PP1(3)+PT1(3))**2)
6425                ECH   = PP1(4)+PT1(4)
6426                AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6427                PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6428      &                                        +(PP2(3)+PT2(3))**2)
6429                ECH   = PP2(4)+PT2(4)
6430                AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6431             ELSE
6432 *    antibaryon-baryon
6433                CALL DT_EVTPUT(-21,IFP1,MOP,0,
6434      &                     PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6435                CALL DT_EVTPUT(-22,IFT2,MOT,0,
6436      &                     PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6437                CALL DT_EVTPUT(-21,IFP2,MOP,0,
6438      &                     PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6439                CALL DT_EVTPUT(-22,IFT1,MOT,0,
6440      &                     PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6441                PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6442      &                                        +(PP1(3)+PT2(3))**2)
6443                ECH   = PP1(4)+PT2(4)
6444                AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6445                PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6446      &                                        +(PP2(3)+PT1(3))**2)
6447                ECH   = PP2(4)+PT1(4)
6448                AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6449             ENDIF
6450             IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6451                AM1 = SQRT(AM1)
6452                AM2 = SQRT(AM2)
6453                IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
6454 C                 WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6455  5007             FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
6456                ENDIF
6457             ELSE
6458                WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6459             ENDIF
6460             NCSY = NCSY+1
6461          ENDIF
6462    80 CONTINUE
6463       IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
6464
6465 * energy-momentum & flavor conservation check
6466       IF (ABS(IDIFF).NE.1) THEN
6467          IF (IDIFF.NE.0) THEN
6468             IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0,
6469      &                                              1,3,10,IREJ)
6470          ELSE
6471             IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
6472      &                                              1,3,10,IREJ)
6473          ENDIF
6474          IF (IREJ.NE.0) THEN
6475             CALL DT_EVTOUT(4)
6476             STOP
6477          ENDIF
6478       ENDIF
6479
6480       RETURN
6481
6482  9999 CONTINUE
6483       IREJ  = 1
6484       RETURN
6485       END
6486
6487 *$ CREATE DT_CHKCSY.FOR
6488 *COPY DT_CHKCSY
6489 *
6490 *===chkcsy=============================================================*
6491 *
6492       SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
6493
6494 ************************************************************************
6495 * CHeCk Chain SYstem for consistency of partons at chain ends.         *
6496 *            ID1,ID2        PDG-numbers of partons at chain ends       *
6497 *            LCHK = .true.  consistent chain                           *
6498 *                 = .false. inconsistent chain                         *
6499 * This version dated 18.01.95 is written by S. Roesler                 *
6500 ************************************************************************
6501
6502       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6503       SAVE
6504       PARAMETER ( LINP = 10 ,
6505      &            LOUT = 6 ,
6506      &            LDAT = 9 )
6507
6508       LOGICAL LCHK
6509
6510       LCHK = .TRUE.
6511
6512 * q-aq chain
6513       IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN
6514          IF (ID1*ID2.GT.0) LCHK = .FALSE.
6515 * q-qq, aq-aqaq chain
6516       ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR.
6517      &        ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN
6518          IF (ID1*ID2.LT.0) LCHK = .FALSE.
6519 * qq-aqaq chain
6520       ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
6521          IF (ID1*ID2.GT.0) LCHK = .FALSE.
6522       ENDIF
6523
6524       RETURN
6525       END
6526
6527 *$ CREATE DT_EVENTA.FOR
6528 *COPY DT_EVENTA
6529 *
6530 *===eventa=============================================================*
6531 *
6532       SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
6533
6534 ************************************************************************
6535 * Treatment of nucleon-nucleon interactions in a two-chain             *
6536 * approximation.                                                       *
6537 *  (input) ID       BAMJET-index of projectile hadron (in case of      *
6538 *                   h-K scattering)                                    *
6539 *          IP/IT    mass number of projectile/target nucleus           *
6540 *          NCSY     number of two chain systems                        *
6541 *          IREJ     rejection flag                                     *
6542 * This version dated 15.01.95 is written by S. Roesler                 *
6543 ************************************************************************
6544
6545       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6546       SAVE
6547       PARAMETER ( LINP = 10 ,
6548      &            LOUT = 6 ,
6549      &            LDAT = 9 )
6550       PARAMETER (TINY10=1.0D-10)
6551
6552 * event history
6553       PARAMETER (NMXHKK=200000)
6554       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6555      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6556      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6557 * extended event history
6558       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6559      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6560      &                IHIST(2,NMXHKK)
6561 * rejection counter
6562       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6563      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6564      &                IREXCI(3),IRDIFF(2),IRINC
6565 * flags for diffractive interactions (DTUNUC 1.x)
6566       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6567 * particle properties (BAMJET index convention)
6568       CHARACTER*8  ANAME
6569       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6570      &                IICH(210),IIBAR(210),K1(210),K2(210)
6571 * flags for input different options
6572       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6573       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6574      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6575 * various options for treatment of partons (DTUNUC 1.x)
6576 * (chain recombination, Cronin,..)
6577       LOGICAL LCO2CR,LINTPT
6578       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6579      &                LCO2CR,LINTPT
6580
6581       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
6582
6583       IREJ      = 0
6584       NPOINT(3) = NHKK+1
6585
6586 * skip following treatment for low-mass diffraction
6587       IF (ABS(IFLAGD).EQ.1) THEN
6588          NPOINT(3) = NPOINT(2)
6589          GOTO 5
6590       ENDIF
6591
6592 * multiple scattering of chain ends
6593       IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
6594       IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
6595
6596       NC = NPOINT(2)
6597 * get a two-chain system from DTEVT1
6598       DO 3 I=1,NCSY
6599          IFP1 = IDHKK(NC)
6600          IFT1 = IDHKK(NC+1)
6601          IFP2 = IDHKK(NC+2)
6602          IFT2 = IDHKK(NC+3)
6603          DO 4 K=1,4
6604             PP1(K) = PHKK(K,NC)
6605             PT1(K) = PHKK(K,NC+1)
6606             PP2(K) = PHKK(K,NC+2)
6607             PT2(K) = PHKK(K,NC+3)
6608     4    CONTINUE
6609          MOP1 = NC
6610          MOT1 = NC+1
6611          MOP2 = NC+2
6612          MOT2 = NC+3
6613          CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
6614      &               IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
6615          IF (IREJ1.GT.0) THEN
6616             IRHHA = IRHHA+1
6617             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
6618             GOTO 9999
6619          ENDIF
6620          NC = NC+4
6621     3 CONTINUE
6622
6623 * meson/antibaryon projectile:
6624 * sample single-chain valence-valence systems (Reggeon contrib.)
6625       IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN
6626          IF (IIBAR(ID).LE.0) CALL DT_VV2SCH
6627       ENDIF
6628
6629       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6630 * check DTEVT1 for remaining resonance mass corrections
6631          CALL DT_EVTRES(IREJ1)
6632          IF (IREJ1.GT.0) THEN
6633             IRRES(1) = IRRES(1)+1
6634             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA'
6635             GOTO 9999
6636          ENDIF
6637       ENDIF
6638
6639 * assign p_t to two-"chain" systems consisting of two resonances only
6640 * since only entries for chains will be affected, this is obsolete
6641 * in case of JETSET-fragmetation
6642       CALL DT_RESPT
6643
6644 * combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
6645       IF (LCO2CR) CALL DT_COM2CR
6646
6647     5 CONTINUE
6648
6649 * fragmentation of the complete event
6650 **uncomment for internal phojet-fragmentation
6651 C     CALL DT_EVTFRA(IREJ1)
6652       CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
6653       IF (IREJ1.GT.0) THEN
6654          IRFRAG = IRFRAG+1
6655          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
6656          GOTO 9999
6657       ENDIF
6658
6659 * decay of possible resonances (should be obsolete)
6660       CALL DT_DECAY1
6661
6662       RETURN
6663
6664  9999 CONTINUE
6665       IREVT = IREVT+1
6666       IREJ  = 1
6667       RETURN
6668       END
6669
6670 *$ CREATE DT_GETCSY.FOR
6671 *COPY DT_GETCSY
6672 *
6673 *===getcsy=============================================================*
6674 *
6675       SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
6676      &                  IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
6677
6678 ************************************************************************
6679 * This version dated 15.01.95 is written by S. Roesler                 *
6680 ************************************************************************
6681
6682       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6683       SAVE
6684       PARAMETER ( LINP = 10 ,
6685      &            LOUT = 6 ,
6686      &            LDAT = 9 )
6687       PARAMETER (TINY10=1.0D-10)
6688
6689 * event history
6690       PARAMETER (NMXHKK=200000)
6691       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6692      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6693      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6694 * extended event history
6695       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6696      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6697      &                IHIST(2,NMXHKK)
6698 * rejection counter
6699       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6700      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6701      &                IREXCI(3),IRDIFF(2),IRINC
6702 * flags for input different options
6703       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6704       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6705      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6706 * flags for diffractive interactions (DTUNUC 1.x)
6707       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6708
6709       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
6710      &          IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
6711
6712       IREJ  = 0
6713
6714 * get quark content of partons
6715       DO 1 I=1,2
6716          IFP1(I) = 0
6717          IFP2(I) = 0
6718          IFT1(I) = 0
6719          IFT2(I) = 0
6720     1 CONTINUE
6721       IFP1(1) = IDT_IPDG2B(IFPR1,1,2)
6722       IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2)
6723       IFP2(1) = IDT_IPDG2B(IFPR2,1,2)
6724       IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2)
6725       IFT1(1) = IDT_IPDG2B(IFTA1,1,2)
6726       IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2)
6727       IFT2(1) = IDT_IPDG2B(IFTA2,1,2)
6728       IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2)
6729
6730 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
6731       IDCH1 = 2
6732       IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1
6733       IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3
6734       IDCH2 = 2
6735       IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1
6736       IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3
6737
6738 * store initial configuration for energy-momentum cons. check
6739       IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
6740
6741 * sample intrinsic p_t at chain-ends
6742       CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2,
6743      &            PT1,IFTA1,IFT1,PT2,IFTA2,IFT2,
6744      &            AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1)
6745       IF (IREJ1.NE.0) THEN
6746          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY'
6747          IRPT = IRPT+1
6748          GOTO 9999
6749       ENDIF
6750
6751 C      IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6752 C         IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
6753 C* check second chain for resonance
6754 C            CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6755 C     &                  AMCH2,AMCH2N,IDCH2,IREJ1)
6756 C            IF (IREJ1.NE.0) GOTO 9999
6757 C            IF (IDR2.NE.0) THEN
6758 C               CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6759 C     &                     AMCH2,AMCH2N,AMCH1,IREJ1)
6760 C               IF (IREJ1.NE.0) GOTO 9999
6761 C            ENDIF
6762 C* check first chain for resonance
6763 C            CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6764 C     &                  AMCH1,AMCH1N,IDCH1,IREJ1)
6765 C            IF (IREJ1.NE.0) GOTO 9999
6766 C            IF (IDR1.NE.0) IDR1 = 100*IDR1
6767 C         ELSE
6768 C* check first chain for resonance
6769 C            CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6770 C     &                  AMCH1,AMCH1N,IDCH1,IREJ1)
6771 C            IF (IREJ1.NE.0) GOTO 9999
6772 C            IF (IDR1.NE.0) THEN
6773 C               CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6774 C     &                     AMCH1,AMCH1N,AMCH2,IREJ1)
6775 C               IF (IREJ1.NE.0) GOTO 9999
6776 C            ENDIF
6777 C* check second chain for resonance
6778 C            CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6779 C     &                  AMCH2,AMCH2N,IDCH2,IREJ1)
6780 C            IF (IREJ1.NE.0) GOTO 9999
6781 C            IF (IDR2.NE.0) IDR2 = 100*IDR2
6782 C         ENDIF
6783 C      ENDIF
6784
6785       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6786 * check chains for resonances
6787          CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6788      &               AMCH1,AMCH1N,IDCH1,IREJ1)
6789          IF (IREJ1.NE.0) GOTO 9999
6790          CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6791      &               AMCH2,AMCH2N,IDCH2,IREJ1)
6792          IF (IREJ1.NE.0) GOTO 9999
6793 * change kinematics corresponding to resonance-masses
6794          IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN
6795             CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6796      &                                 AMCH1,AMCH1N,AMCH2,IREJ1)
6797             IF (IREJ1.GT.0) GOTO 9999
6798             IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6799             CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6800      &                  AMCH2,AMCH2N,IDCH2,IREJ1)
6801             IF (IREJ1.NE.0) GOTO 9999
6802             IF (IDR2.NE.0) IDR2 = 100*IDR2
6803          ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN
6804             CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6805      &                                 AMCH2,AMCH2N,AMCH1,IREJ1)
6806             IF (IREJ1.GT.0) GOTO 9999
6807             IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6808             CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6809      &                  AMCH1,AMCH1N,IDCH1,IREJ1)
6810             IF (IREJ1.NE.0) GOTO 9999
6811             IF (IDR1.NE.0) IDR1 = 100*IDR1
6812          ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN
6813             AMDIF1 = ABS(AMCH1-AMCH1N)
6814             AMDIF2 = ABS(AMCH2-AMCH2N)
6815             IF (AMDIF2.LT.AMDIF1) THEN
6816                CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6817      &                                    AMCH2,AMCH2N,AMCH1,IREJ1)
6818                IF (IREJ1.GT.0) GOTO 9999
6819                IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6820                CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),
6821      &                     IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1)
6822                IF (IREJ1.NE.0) GOTO 9999
6823                IF (IDR1.NE.0) IDR1 = 100*IDR1
6824             ELSE
6825                CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6826      &                                    AMCH1,AMCH1N,AMCH2,IREJ1)
6827                IF (IREJ1.GT.0) GOTO 9999
6828                IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6829                CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),
6830      &                     IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1)
6831                IF (IREJ1.NE.0) GOTO 9999
6832                IF (IDR2.NE.0) IDR2 = 100*IDR2
6833             ENDIF
6834          ENDIF
6835       ENDIF
6836
6837 * store final configuration for energy-momentum cons. check
6838       IF (LEMCCK) THEN
6839          CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM)
6840          CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
6841          IF (IREJ1.NE.0) GOTO 9999
6842       ENDIF
6843
6844 * put partons and chains into DTEVT1
6845       DO 10 I=1,4
6846          PCH1(I) = PP1(I)+PT1(I)
6847          PCH2(I) = PP2(I)+PT2(I)
6848    10 CONTINUE
6849       CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2),
6850      &                                      PP1(3),PP1(4),0,0,0)
6851       CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2),
6852      &                                      PT1(3),PT1(4),0,0,0)
6853       KCH = 100+IDCH(MOP1)*10+1
6854       CALL DT_EVTPUT(KCH,88888,-2,-1,
6855      &           PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1))
6856       CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2),
6857      &                                      PP2(3),PP2(4),0,0,0)
6858       CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2),
6859      &                                      PT2(3),PT2(4),0,0,0)
6860       KCH = KCH+1
6861       CALL DT_EVTPUT(KCH,88888,-2,-1,
6862      &           PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
6863
6864       RETURN
6865
6866  9999 CONTINUE
6867       IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN
6868 * "cancel" sea-sea chains
6869          CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1)
6870          IF (IREJ1.NE.0) GOTO 9998
6871 **sr 16.5. flag for EVENTB
6872          IREJ = -1
6873          RETURN
6874       ENDIF
6875  9998 CONTINUE
6876       IREJ = 1
6877       RETURN
6878       END
6879
6880 *$ CREATE DT_CHKINE.FOR
6881 *COPY DT_CHKINE
6882 *
6883 *===chkine=============================================================*
6884 *
6885       SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
6886      &                  AMCH1,AMCH1N,AMCH2,IREJ)
6887
6888 ************************************************************************
6889 * This subroutine replaces CORMOM.                                     *
6890 * This version dated 05.01.95 is written by S. Roesler                 *
6891 ************************************************************************
6892
6893       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6894       SAVE
6895       PARAMETER ( LINP = 10 ,
6896      &            LOUT = 6 ,
6897      &            LDAT = 9 )
6898       PARAMETER (TINY10=1.0D-10)
6899
6900 * flags for input different options
6901       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6902       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6903      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6904 * rejection counter
6905       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6906      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6907      &                IREXCI(3),IRDIFF(2),IRINC
6908
6909       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
6910      &          PP1I(4),PP2I(4),PT1I(4),PT2I(4)
6911
6912       IREJ  = 0
6913       JMSHL = IMSHL
6914
6915       SCALE  = AMCH1N/MAX(AMCH1,TINY10)
6916       DO 10 I=1,4
6917          PP1(I) = PP1I(I)
6918          PP2(I) = PP2I(I)
6919          PT1(I) = PT1I(I)
6920          PT2(I) = PT2I(I)
6921          PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I)
6922          PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I)
6923          PP1(I) = SCALE*PP1(I)
6924          PT1(I) = SCALE*PT1(I)
6925    10 CONTINUE
6926       IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR.
6927      &    (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997
6928
6929       ECH = PP2(4)+PT2(4)
6930       PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+
6931      &                               (PP2(3)+PT2(3))**2 )
6932       AMCH22 = (ECH-PCH)*(ECH+PCH)
6933       IF (AMCH22.LT.0.0D0) THEN
6934          IF (IOULEV(1).GT.0)
6935      &      WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
6936          GOTO 9997
6937       ENDIF
6938
6939       AMCH1 = AMCH1N
6940       AMCH2 = SQRT(AMCH22)
6941
6942 * put partons again on mass shell
6943    13 CONTINUE
6944       XM1 = 0.0D0
6945       XM2 = 0.0D0
6946       IF (JMSHL.EQ.1) THEN
6947          XM1 = PYMASS(IFP1)
6948          XM2 = PYMASS(IFT1)
6949       ENDIF
6950       CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
6951       IF (IREJ1.NE.0) THEN
6952          IF (JMSHL.EQ.0) GOTO 9998
6953          JMSHL = 0
6954          GOTO 13
6955       ENDIF
6956       JMSHL = IMSHL
6957       DO 11 I=1,4
6958          PP1(I) = P1(I)
6959          PT1(I) = P2(I)
6960    11 CONTINUE
6961    14 CONTINUE
6962       XM1 = 0.0D0
6963       XM2 = 0.0D0
6964       IF (JMSHL.EQ.1) THEN
6965          XM1 = PYMASS(IFP2)
6966          XM2 = PYMASS(IFT2)
6967       ENDIF
6968       CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
6969       IF (IREJ1.NE.0) THEN
6970          IF (JMSHL.EQ.0) GOTO 9998
6971          JMSHL = 0
6972          GOTO 14
6973       ENDIF
6974       DO 12 I=1,4
6975          PP2(I) = P1(I)
6976          PT2(I) = P2(I)
6977    12 CONTINUE
6978       DO 15 I=1,4
6979          PP1I(I) = PP1(I)
6980          PP2I(I) = PP2(I)
6981          PT1I(I) = PT1(I)
6982          PT2I(I) = PT2(I)
6983    15 CONTINUE
6984       RETURN
6985
6986  9997 IRCHKI(1) = IRCHKI(1)+1
6987 **sr
6988 C     GOTO 9999
6989       IREJ = -1
6990       RETURN
6991 **
6992  9998 IRCHKI(2) = IRCHKI(2)+1
6993
6994  9999 CONTINUE
6995       IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
6996       IREJ = 1
6997       RETURN
6998       END
6999
7000 *$ CREATE DT_CH2RES.FOR
7001 *COPY DT_CH2RES
7002 *
7003 *===ch2res=============================================================*
7004 *
7005       SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
7006      &                  AM,AMN,IMODE,IREJ)
7007
7008 ************************************************************************
7009 * Check chains for resonance production.                               *
7010 * This subroutine replaces COMCMA/COBCMA/COMCM2                        *
7011 *    input:                                                            *
7012 *          IF1,2,3,4    input flavors (q,aq in any order)              *
7013 *          AM           chain mass                                     *
7014 *          MODE = 1     check q-aq chain for meson-resonance           *
7015 *               = 2     check q-qq, aq-aqaq chain for baryon-resonance *
7016 *               = 3     check qq-aqaq chain for lower mass cut         *
7017 *    output:                                                           *
7018 *          IDR = 0      no resonances found                            *
7019 *              = -1     pseudoscalar meson/octet baryon                *
7020 *              = 1      vector-meson/decuplet baryon                   *
7021 *          IDXR         BAMJET-index of corresponding resonance        *
7022 *          AMN          mass of corresponding resonance                *
7023 *                                                                      *
7024 *          IREJ         rejection flag                                 *
7025 * This version dated 06.01.95 is written by S. Roesler                 *
7026 ************************************************************************
7027
7028       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7029       SAVE
7030       PARAMETER ( LINP = 10 ,
7031      &            LOUT = 6 ,
7032      &            LDAT = 9 )
7033
7034 * particle properties (BAMJET index convention)
7035       CHARACTER*8  ANAME
7036       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7037      &                IICH(210),IIBAR(210),K1(210),K2(210)
7038 * quark-content to particle index conversion (DTUNUC 1.x)
7039       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
7040      &                IA08(6,21),IA10(6,21)
7041 * rejection counter
7042       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7043      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7044      &                IREXCI(3),IRDIFF(2),IRINC
7045 * flags for input different options
7046       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7047       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7048      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7049
7050       DIMENSION IF(4),JF(4)
7051
7052 **sr 4.7. test
7053 C     DATA AMLOM,AMLOB /0.08D0,0.2D0/
7054       DATA AMLOM,AMLOB /0.1D0,0.7D0/
7055 **
7056 C     DATA AMLOM,AMLOB /0.001D0,0.001D0/
7057
7058       MODE = ABS(IMODE)
7059
7060       IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN
7061          WRITE(LOUT,1000) MODE
7062  1000    FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/,
7063      &          1X,'        program stopped')
7064          STOP
7065       ENDIF
7066
7067       AMX  = AM
7068       IREJ = 0
7069       IDR  = 0
7070       IDXR = 0
7071       AMN  = AMX
7072       IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
7073       IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
7074
7075       IF(1) = IF1
7076       IF(2) = IF2
7077       IF(3) = IF3
7078       IF(4) = IF4
7079       NF = 0
7080       DO 100 I=1,4
7081          IF (IF(I).NE.0) THEN
7082             NF = NF+1
7083             JF(NF) = IF(I)
7084          ENDIF
7085   100 CONTINUE
7086       IF (NF.LE.MODE) THEN
7087          WRITE(LOUT,1001) MODE,IF
7088  1001    FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ',
7089      &   I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4)
7090          GOTO 9999
7091       ENDIF
7092
7093       GOTO (1,2,3) MODE
7094
7095 * check for meson resonance
7096     1 CONTINUE
7097       IFQ  = JF(1)
7098       IFAQ = ABS(JF(2))
7099       IF (JF(2).GT.0) THEN
7100          IFQ  = JF(2)
7101          IFAQ = ABS(JF(1))
7102       ENDIF
7103       IFPS = IMPS(IFAQ,IFQ)
7104       IFV  = IMVE(IFAQ,IFQ)
7105       AMPS = AAM(IFPS)
7106       AMV  = AAM(IFV)
7107       AMHI = AMV+0.3D0
7108       IF (AMX.LT.AMV) THEN
7109          IF (AMX.LT.AMPS) THEN
7110             IF (IMODE.GT.0) THEN
7111                IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999
7112             ELSE
7113                IF (AMX.LT.0.8D0*AMPS) GOTO 9999
7114             ENDIF
7115             LOMRES = LOMRES+1
7116          ENDIF
7117 *    replace chain by pseudoscalar meson
7118          IDR  = -1
7119          IDXR = IFPS
7120          AMN  = AMPS
7121       ELSEIF (AMX.LT.AMHI) THEN
7122 *    replace chain by vector-meson
7123          IDR  = 1
7124          IDXR = IFV
7125          AMN  = AMV
7126       ENDIF
7127       RETURN
7128
7129 * check for baryon resonance
7130     2 CONTINUE
7131       CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
7132       AM8  = AAM(JB8)
7133       AM10 = AAM(JB10)
7134       AMHI = AM10+0.3D0
7135       IF (AMX.LT.AM10) THEN
7136          IF (AMX.LT.AM8) THEN
7137             IF (IMODE.GT.0) THEN
7138                IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999
7139             ELSE
7140                IF (AMX.LT.0.8D0*AM8) GOTO 9999
7141             ENDIF
7142             LOBRES = LOBRES+1
7143          ENDIF
7144 *    replace chain by oktet baryon
7145          IDR  = -1
7146          IDXR = JB8
7147          AMN  = AM8
7148       ELSEIF (AMX.LT.AMHI) THEN
7149          IDR  = 1
7150          IDXR = JB10
7151          AMN  = AM10
7152       ENDIF
7153       RETURN
7154
7155 * check qq-aqaq for lower mass cut
7156     3 CONTINUE
7157 *   empirical definition of AMHI to allow for (b-antib)-pair prod.
7158       AMHI = 2.5D0
7159       IF (AMX.LT.AMHI) GOTO 9999
7160       RETURN
7161
7162  9999 CONTINUE
7163       IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
7164      &    WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
7165       IREJ = 1
7166       IRRES(2) = IRRES(2)+1
7167       RETURN
7168       END
7169
7170 *$ CREATE DT_RJSEAC.FOR
7171 *COPY DT_RJSEAC
7172 *
7173 *===rjseac=============================================================*
7174 *
7175       SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
7176
7177 ************************************************************************
7178 * ReJection of SEA-sea Chains.                                         *
7179 *         MOP1/2       entries of projectile sea-partons in DTEVT1     *
7180 *         MOT1/2       entries of projectile sea-partons in DTEVT1     *
7181 * This version dated 16.01.95 is written by S. Roesler                 *
7182 ************************************************************************
7183
7184       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7185       SAVE
7186       PARAMETER ( LINP = 10 ,
7187      &            LOUT = 6 ,
7188      &            LDAT = 9 )
7189       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
7190
7191 * event history
7192       PARAMETER (NMXHKK=200000)
7193       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7194      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7195      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7196 * extended event history
7197       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7198      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7199      &                IHIST(2,NMXHKK)
7200 * statistics
7201       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7202      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7203      &                ICEVTG(8,0:30)
7204
7205       DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
7206
7207       IREJ = 0
7208
7209 * projectile sea q-aq-pair
7210 *    indices of sea-pair
7211       IDXSEA(1,1) = MOP1
7212       IDXSEA(1,2) = MOP2
7213 *    index of mother-nucleon
7214       IDXNUC(1)   = JMOHKK(1,MOP1)
7215 *    status of valence quarks to be corrected
7216       ISTVAL(1)   = -21
7217
7218 * target sea q-aq-pair
7219 *    indices of sea-pair
7220       IDXSEA(2,1) = MOT1
7221       IDXSEA(2,2) = MOT2
7222 *    index of mother-nucleon
7223       IDXNUC(2)   = JMOHKK(1,MOT1)
7224 *    status of valence quarks to be corrected
7225       ISTVAL(2)   = -22
7226
7227       DO 1 N=1,2
7228          IDONE = 0
7229          DO 2 I=NPOINT(2),NHKK
7230             IF ((ISTHKK(I).EQ.ISTVAL(N)).AND.
7231      &          (JMOHKK(1,I).EQ.IDXNUC(N)))   THEN
7232 * valence parton found
7233 *    inrease 4-momentum by sea 4-momentum
7234                DO 3 K=1,4
7235                   PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
7236      &                                  PHKK(K,IDXSEA(N,2))
7237     3          CONTINUE
7238                PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
7239      &                              PHKK(2,I)**2-PHKK(3,I)**2))
7240 *    "cancel" sea-pair
7241                DO 4 J=1,2
7242                   ISTHKK(IDXSEA(N,J))   = 100
7243                   IDHKK(IDXSEA(N,J))    = 0
7244                   JMOHKK(1,IDXSEA(N,J)) = 0
7245                   JMOHKK(2,IDXSEA(N,J)) = 0
7246                   JDAHKK(1,IDXSEA(N,J)) = 0
7247                   JDAHKK(2,IDXSEA(N,J)) = 0
7248                   DO 5 K=1,4
7249                      PHKK(K,IDXSEA(N,J)) = ZERO
7250                      VHKK(K,IDXSEA(N,J)) = ZERO
7251                      WHKK(K,IDXSEA(N,J)) = ZERO
7252     5             CONTINUE
7253                   PHKK(5,IDXSEA(N,J)) = ZERO
7254     4          CONTINUE
7255                IDONE = 1
7256             ENDIF
7257     2    CONTINUE
7258          IF (IDONE.NE.1) THEN
7259             WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2
7260  1000       FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event',
7261      &                '-record!',/,1X,'        sea-quark pairs   ',
7262      &                2I5,4X,2I5,'   could not be canceled!')
7263             GOTO 9999
7264          ENDIF
7265     1 CONTINUE
7266       ICRJSS = ICRJSS+1
7267       RETURN
7268
7269  9999 CONTINUE
7270       IREJ = 1
7271       RETURN
7272       END
7273
7274 *$ CREATE DT_VV2SCH.FOR
7275 *COPY DT_VV2SCH
7276 *
7277 *===vv2sch=============================================================*
7278 *
7279       SUBROUTINE DT_VV2SCH
7280
7281 ************************************************************************
7282 * Change Valence-Valence chain systems to Single CHain systems for     *
7283 * hadron-nucleus collisions with meson or antibaryon projectile.       *
7284 * (Reggeon contribution)                                               *
7285 * The single chain system is approximately treated as one chain and a  *
7286 * meson at rest.                                                       *
7287 * This version dated 18.01.95 is written by S. Roesler                 *
7288 ************************************************************************
7289
7290       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7291       SAVE
7292       PARAMETER ( LINP = 10 ,
7293      &            LOUT = 6 ,
7294      &            LDAT = 9 )
7295       PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
7296
7297       LOGICAL LSTART
7298
7299 * event history
7300       PARAMETER (NMXHKK=200000)
7301       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7302      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7303      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7304 * extended event history
7305       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7306      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7307      &                IHIST(2,NMXHKK)
7308 * flags for input different options
7309       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7310       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7311      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7312 * statistics
7313       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7314      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7315      &                ICEVTG(8,0:30)
7316
7317       DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
7318      &          PCH2(4)
7319
7320       DATA LSTART /.TRUE./
7321
7322       IFSC  = 0
7323       IF (LSTART) THEN
7324          WRITE(LOUT,1000)
7325  1000    FORMAT(/,1X,'VV2SCH:  Reggeon contribution to valance-',
7326      &          'valence chains treated')
7327          LSTART = .FALSE.
7328       ENDIF
7329
7330       NSTOP = NHKK
7331
7332 * get index of first chain
7333       DO 1 I=NPOINT(3),NHKK
7334          IF (IDHKK(I).EQ.88888) THEN
7335             NC = I
7336             GOTO 2
7337          ENDIF
7338     1 CONTINUE
7339
7340     2 CONTINUE
7341       IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)
7342      &                        .AND.(NC.LT.NSTOP)) THEN
7343 * get valence-valence chains
7344          IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN
7345 *   get "mother"-hadron indices
7346             MO1   = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC)))
7347             MO2   = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC)))
7348             KPROJ = IDT_ICIHAD(IDHKK(MO1))
7349             KTARG = IDT_ICIHAD(IDHKK(MO2))
7350 *   Lab momentum of projectile hadron
7351             CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3)
7352             PTOT  = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+
7353      &                                  PHKK(3,MO1)**2)
7354
7355             SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
7356             IF (DT_RNDM(PTOT).LE.SICHAP) THEN
7357                ICVV2S = ICVV2S+1
7358 *   single chain requested
7359 *      get flavors of chain-end partons
7360                MO(1) = JMOHKK(1,NC)
7361                MO(2) = JMOHKK(2,NC)
7362                MO(3) = JMOHKK(1,NC+3)
7363                MO(4) = JMOHKK(2,NC+3)
7364                DO 3 I=1,4
7365                   IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
7366                   IF(I,2) = 0
7367                   IF (ABS(IDHKK(MO(I))).GE.1000)
7368      &               IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
7369     3          CONTINUE
7370 *      which one is the q-aq chain?
7371 *        N1,N1+1 - DTEVT1-entries for q-aq system
7372 *        N2,N2+1 - DTEVT1-entries for the other chain
7373                IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN
7374                   K1 = 1
7375                   K2 = 3
7376                   N1 = NC-2
7377                   N2 = NC+1
7378                ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
7379                   K1 = 3
7380                   K2 = 1
7381                   N1 = NC+1
7382                   N2 = NC-2
7383                ELSE
7384                   GOTO 10
7385                ENDIF
7386                DO 4 K=1,4
7387                   PP1(K) = PHKK(K,N1)
7388                   PT1(K) = PHKK(K,N1+1)
7389                   PP2(K) = PHKK(K,N2)
7390                   PT2(K) = PHKK(K,N2+1)
7391     4          CONTINUE
7392                AMCH1 = PHKK(5,N1+2)
7393                AMCH2 = PHKK(5,N2+2)
7394 *      get meson-identity corresponding to flavors of q-aq chain
7395                ITMP   = IRESRJ
7396                IRESRJ = 0
7397                CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1,
7398      &                     ZERO,AMCH1N,1,IDUM)
7399                IRESRJ = ITMP
7400 *      change kinematics of chains
7401                CALL DT_CHKINE(PP1,IDHKK(N1),  PP2,IDHKK(N2),
7402      &                     PT1,IDHKK(N1+1),PT2,IDHKK(N2+1),
7403      &                     AMCH1,AMCH1N,AMCH2,IREJ1)
7404                IF (IREJ1.NE.0) GOTO 10
7405 *      check second chain for resonance
7406                IDCHAI = 2
7407                IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3
7408                CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2),
7409      &                     IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1)
7410                IF (IREJ1.NE.0) GOTO 10
7411                IF (IDR2.NE.0) IDR2 = 100*IDR2
7412 *      add partons and chains to DTEVT1
7413                DO 5 K=1,4
7414                   PCH1(K) = PP1(K)+PT1(K)
7415                   PCH2(K) = PP2(K)+PT2(K)
7416     5          CONTINUE
7417                CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2),
7418      &                                             PP1(3),PP1(4),0,0,0)
7419                CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1),
7420      &                                      PT1(2),PT1(3),PT1(4),0,0,0)
7421                KCH = ISTHKK(N1+2)+100
7422                CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3),
7423      &                     PCH1(4),IDR1,IDXR1,IDCH(N1+2))
7424                IDHKK(N1+2) = 22222
7425                CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2),
7426      &                                             PP2(3),PP2(4),0,0,0)
7427                CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1),
7428      &                                      PT2(2),PT2(3),PT2(4),0,0,0)
7429                KCH = ISTHKK(N2+2)+100
7430                CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3),
7431      &                     PCH2(4),IDR2,IDXR2,IDCH(N2+2))
7432                IDHKK(N2+2) = 22222
7433             ENDIF
7434          ENDIF
7435       ELSE
7436          GOTO 11
7437       ENDIF
7438    10 CONTINUE
7439       NC = NC+6
7440       GOTO 2
7441
7442    11 CONTINUE
7443
7444       RETURN
7445       END
7446
7447 *$ CREATE DT_PHNSCH.FOR
7448 *COPY DT_PHNSCH
7449 *
7450 *=== phnsch ===========================================================*
7451 *
7452       DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB )
7453
7454 *----------------------------------------------------------------------*
7455 *                                                                      *
7456 *     Probability for Hadron Nucleon Single CHain interactions:        *
7457 *                                                                      *
7458 *     Created on 30 december 1993  by    Alfredo Ferrari & Paola Sala  *
7459 *                                                   Infn - Milan       *
7460 *                                                                      *
7461 *     Last change on 04-jan-94     by    Alfredo Ferrari               *
7462 *                                                                      *
7463 *             modified by J.R.for use in DTUNUC  6.1.94                *
7464 *                                                                      *
7465 *     Input variables:                                                 *
7466 *                      Kp = hadron projectile index (Part numbering    *
7467 *                           scheme)                                    *
7468 *                   Ktarg = target nucleon index (1=proton, 8=neutron) *
7469 *                    Plab = projectile laboratory momentum (GeV/c)     *
7470 *     Output variable:                                                 *
7471 *                  Phnsch = probability per single chain (particle     *
7472 *                           exchange) interactions                     *
7473 *                                                                      *
7474 *----------------------------------------------------------------------*
7475
7476       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7477       SAVE
7478
7479       PARAMETER ( LUNOUT = 6  )
7480       PARAMETER ( LUNERR = 6  )
7481       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
7482       PARAMETER ( ZERZER = 0.D+00 )
7483       PARAMETER ( ONEONE = 1.D+00 )
7484       PARAMETER ( TWOTWO = 2.D+00 )
7485       PARAMETER ( FIVFIV = 5.D+00 )
7486       PARAMETER ( HLFHLF = 0.5D+00 )
7487
7488       PARAMETER ( NALLWP = 39   )
7489       PARAMETER ( IDMAXP = 210  )
7490
7491       DIMENSION ICHRGE(39),AM(39)
7492
7493 * particle properties (BAMJET index convention)
7494       CHARACTER*8  ANAME
7495       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7496      &                IICH(210),IIBAR(210),K1(210),K2(210)
7497
7498       DIMENSION KPTOIP(210)
7499 * auxiliary common for reggeon exchange (DTUNUC 1.x)
7500       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
7501      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
7502      &                IQTCHR(-6:6),MQUARK(3,39)
7503
7504       DIMENSION SGTCOE (5,33), IHLP (NALLWP)
7505       DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15)
7506 CPH      SAVE SGTCOE, IHLP
7507 CPH      SAVE IQFSC1, IQFSC2, IQBSC1, IQBSC2
7508       EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1))
7509       EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11))
7510       EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19))
7511
7512 * Conversion from part to paprop numbering
7513       DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
7514      & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
7515      & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
7516
7517 *  1=baryon, 2=pion, 3=kaon, 4=antibaryon:
7518       DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
7519      &    2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
7520 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
7521       DATA  SGTCO1  /
7522 * 1st reaction: gamma p total
7523      &0.147 D+00, ZERZER  , ZERZER   , 0.0022D+00, -0.0170D+00,
7524 * 2nd reaction: gamma d total
7525      &0.300 D+00, ZERZER  , ZERZER   , 0.0095D+00, -0.057 D+00,
7526 * 3rd reaction: pi+ p total
7527      &16.4  D+00, 19.3D+00, -0.42D+00, 0.19  D+00, ZERZER     ,
7528 * 4th reaction: pi- p total
7529      &33.0  D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03  D+00,
7530 * 5th reaction: pi+/- d total
7531      &56.8  D+00, 42.2D+00, -1.45D+00, 0.65  D+00, -5.39  D+00,
7532 * 6th reaction: K+ p total
7533      &18.1  D+00, ZERZER  , ZERZER   , 0.26  D+00, -1.0   D+00,
7534 * 7th reaction: K+ n total
7535      &18.7  D+00, ZERZER  , ZERZER   , 0.21  D+00, -0.89  D+00,
7536 * 8th reaction: K+ d total
7537      &34.2  D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99  D+00,
7538 * 9th reaction: K- p total
7539      &32.1  D+00, ZERZER  , ZERZER   , 0.66  D+00, -5.6   D+00,
7540 * 10th reaction: K- n total
7541      &25.2  D+00, ZERZER  , ZERZER   , 0.38  D+00, -2.9   D+00/
7542 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
7543       DATA  SGTCO2  /
7544 * 11th reaction: K- d total
7545      &57.6  D+00, ZERZER  , ZERZER   , 1.17  D+00, -9.5   D+00,
7546 * 12th reaction: p p total
7547      &48.0  D+00, ZERZER  , ZERZER   , 0.522 D+00, -4.51  D+00,
7548 * 13th reaction: p n total
7549      &47.30 D+00, ZERZER  , ZERZER   , 0.513 D+00, -4.27  D+00,
7550 * 14th reaction: p d total
7551      &91.3  D+00, ZERZER  , ZERZER   , 1.05  D+00, -8.8   D+00,
7552 * 15th reaction: pbar p total
7553      &38.4  D+00, 77.6D+00, -0.64D+00, 0.26  D+00, -1.2   D+00,
7554 * 16th reaction: pbar n total
7555      &ZERZER    ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7   D+00,
7556 * 17th reaction: pbar d total
7557      &112.  D+00, 125.D+00, -1.08D+00, 1.14  D+00, -12.4  D+00,
7558 * 18th reaction: Lamda p total
7559      &30.4  D+00, ZERZER  , ZERZER   , ZERZER    , 1.6    D+00/
7560 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
7561       DATA SGTCO3  /
7562 * 19th reaction: pi+ p elastic
7563      &ZERZER    , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER     ,
7564 * 20th reaction: pi- p elastic
7565      &1.76  D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER     ,
7566 * 21st reaction: K+ p elastic
7567      &5.0   D+00, 8.1 D+00, -1.8 D+00, 0.16  D+00, -1.3   D+00,
7568 * 22nd reaction: K- p elastic
7569      &7.3   D+00, ZERZER  , ZERZER   , 0.29  D+00, -2.40  D+00,
7570 * 23rd reaction: p p elastic
7571      &11.9  D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85  D+00,
7572 * 24th reaction: p d elastic
7573      &16.1  D+00, ZERZER  , ZERZER   , 0.32  D+00, -3.4   D+00,
7574 * 25th reaction: pbar p elastic
7575      &10.2  D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28  D+00,
7576 * 26th reaction: pbar p elastic bis
7577      &10.6  D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41  D+00,
7578 * 27th reaction: pbar n elastic
7579      &36.5  D+00, ZERZER  , ZERZER   , ZERZER    , -11.9  D+00,
7580 * 28th reaction: Lamda p elastic
7581      &12.3  D+00, ZERZER  , ZERZER   , ZERZER    , -2.4   D+00,
7582 * 29th reaction: K- p ela bis
7583      &7.24  D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35  D+00,
7584 * 30th reaction: pi- p cx
7585      &ZERZER    ,0.912D+00, -1.22D+00, ZERZER    , ZERZER     ,
7586 * 31st reaction: K- p cx
7587      &ZERZER    , 3.39D+00, -1.75D+00, ZERZER    , ZERZER     ,
7588 * 32nd reaction: K+ n cx
7589      &ZERZER    , 7.18D+00, -2.01D+00, ZERZER    , ZERZER     ,
7590 * 33rd reaction: pbar p cx
7591      &ZERZER    , 18.8D+00, -2.01D+00, ZERZER    , ZERZER     /
7592 *
7593 *  +-------------------------------------------------------------------*
7594          ICHRGE(KTARG)=IICH(KTARG)
7595          AM    (KTARG)=AAM (KTARG)
7596 *  |  Check for pi0 (d-dbar)
7597       IF ( KP .NE. 26 ) THEN
7598          IP  = KPTOIP (KP)
7599          IF(IP.EQ.0)IP=1
7600          ICHRGE(IP)=IICH(KP)
7601          AM    (IP)=AAM (KP)
7602 *  |
7603 *  +-------------------------------------------------------------------*
7604 *  |
7605       ELSE
7606          IP = 23
7607          ICHRGE(IP)=0
7608       END IF
7609 *  |
7610 *  +-------------------------------------------------------------------*
7611 *  +-------------------------------------------------------------------*
7612 *  |  No such interactions for baryon-baryon
7613       IF ( IIBAR (KP) .GT. 0 ) THEN
7614          DT_PHNSCH = ZERZER
7615          RETURN
7616 *  |
7617 *  +-------------------------------------------------------------------*
7618 *  |  No "annihilation" diagram possible for K+ p/n
7619       ELSE IF ( IP .EQ. 15 ) THEN
7620          DT_PHNSCH = ZERZER
7621          RETURN
7622 *  |
7623 *  +-------------------------------------------------------------------*
7624 *  |  No "annihilation" diagram possible for K0 p/n
7625       ELSE IF ( IP .EQ. 24 ) THEN
7626          DT_PHNSCH = ZERZER
7627          RETURN
7628 *  |
7629 *  +-------------------------------------------------------------------*
7630 *  |  No "annihilation" diagram possible for Omebar p/n
7631       ELSE IF ( IP .GE. 38 ) THEN
7632          DT_PHNSCH = ZERZER
7633          RETURN
7634       END IF
7635 *  |
7636 *  +-------------------------------------------------------------------*
7637 *  +-------------------------------------------------------------------*
7638 *  |  If the momentum is larger than 50 GeV/c, compute the single
7639 *  |  chain probability at 50 GeV/c and extrapolate to the present
7640 *  |  momentum according to 1/sqrt(s)
7641 *  |  sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
7642 *  |  P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
7643 *  |  sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
7644 *  |  sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
7645 *  |                        x sqrt(s/s(50))
7646 *  |  P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
7647       IF ( PLAB .GT. 50.D+00 ) THEN
7648          PLA    = 50.D+00
7649          AMPSQ  = AM (IP)**2
7650          AMTSQ  = AM (KTARG)**2
7651          EPROJ  = SQRT ( PLAB**2 + AMPSQ )
7652          UMOSQ  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7653          EPROJ  = SQRT ( PLA**2 + AMPSQ )
7654          UMO50  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7655          UMORAT = SQRT ( UMOSQ / UMO50 )
7656 *  |
7657 *  +-------------------------------------------------------------------*
7658 *  |  P < 3 GeV/c
7659       ELSE IF ( PLAB .LT. 3.D+00 ) THEN
7660          PLA    = 3.D+00
7661          AMPSQ  = AM (IP)**2
7662          AMTSQ  = AM (KTARG)**2
7663          EPROJ  = SQRT ( PLAB**2 + AMPSQ )
7664          UMOSQ  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7665          EPROJ  = SQRT ( PLA**2 + AMPSQ )
7666          UMO50  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7667          UMORAT = SQRT ( UMOSQ / UMO50 )
7668 *  |
7669 *  +-------------------------------------------------------------------*
7670 *  |  P < 50 GeV/c
7671       ELSE
7672          PLA    = PLAB
7673          UMORAT = ONEONE
7674       END IF
7675 *  |
7676 *  +-------------------------------------------------------------------*
7677       ALGPLA = LOG (PLA)
7678 *  +-------------------------------------------------------------------*
7679 *  |  Pions:
7680       IF ( IHLP (IP) .EQ. 2 ) THEN
7681          ACOF = SGTCOE (1,3)
7682          BCOF = SGTCOE (2,3)
7683          ENNE = SGTCOE (3,3)
7684          CCOF = SGTCOE (4,3)
7685          DCOF = SGTCOE (5,3)
7686 *  |  Compute the pi+ p total cross section:
7687          SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7688      &          + DCOF * ALGPLA
7689          ACOF = SGTCOE (1,19)
7690          BCOF = SGTCOE (2,19)
7691          ENNE = SGTCOE (3,19)
7692          CCOF = SGTCOE (4,19)
7693          DCOF = SGTCOE (5,19)
7694 *  |  Compute the pi+ p elastic cross section:
7695          SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7696      &          + DCOF * ALGPLA
7697 *  |  Compute the pi+ p inelastic cross section:
7698          SPPPIN = SPPPTT - SPPPEL
7699          ACOF = SGTCOE (1,4)
7700          BCOF = SGTCOE (2,4)
7701          ENNE = SGTCOE (3,4)
7702          CCOF = SGTCOE (4,4)
7703          DCOF = SGTCOE (5,4)
7704 *  |  Compute the pi- p total cross section:
7705          SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7706      &          + DCOF * ALGPLA
7707          ACOF = SGTCOE (1,20)
7708          BCOF = SGTCOE (2,20)
7709          ENNE = SGTCOE (3,20)
7710          CCOF = SGTCOE (4,20)
7711          DCOF = SGTCOE (5,20)
7712 *  |  Compute the pi- p elastic cross section:
7713          SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7714      &          + DCOF * ALGPLA
7715 *  |  Compute the pi- p inelastic cross section:
7716          SPMPIN = SPMPTT - SPMPEL
7717          SIGDIA = SPMPIN - SPPPIN
7718 *  |  +----------------------------------------------------------------*
7719 *  |  |  Charged pions: besides isospin consideration it is supposed
7720 *  |  |                 that (pi+ n)el is almost equal to (pi- p)el
7721 *  |  |                 and  (pi+ p)el "    "     "    "  (pi- n)el
7722 *  |  |                 and all are almost equal among each others
7723 *  |  |                 (reasonable above 5 GeV/c)
7724          IF ( ICHRGE (IP) .NE. 0 ) THEN
7725             KHELP = KTARG / 8
7726             JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP
7727             ACOF = SGTCOE (1,JREAC)
7728             BCOF = SGTCOE (2,JREAC)
7729             ENNE = SGTCOE (3,JREAC)
7730             CCOF = SGTCOE (4,JREAC)
7731             DCOF = SGTCOE (5,JREAC)
7732 *  |  |  Compute the total cross section:
7733             SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7734      &             + DCOF * ALGPLA
7735             JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP
7736             ACOF = SGTCOE (1,JREAC)
7737             BCOF = SGTCOE (2,JREAC)
7738             ENNE = SGTCOE (3,JREAC)
7739             CCOF = SGTCOE (4,JREAC)
7740             DCOF = SGTCOE (5,JREAC)
7741 *  |  |  Compute the elastic cross section:
7742             SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7743      &             + DCOF * ALGPLA
7744 *  |  |  Compute the inelastic cross section:
7745             SHNCIN = SHNCTT - SHNCEL
7746 *  |  |  Number of diagrams:
7747             NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP
7748 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7749             IQFSC1 = 1 + IP - 13
7750             IQFSC2 = 0
7751             IQBSC1 = 1 + KHELP
7752             IQBSC2 = 1 + IP - 13
7753 *  |  |
7754 *  |  +----------------------------------------------------------------*
7755 *  |  |  pi0: besides isospin consideration it is supposed that the
7756 *  |  |       elastic cross section is not very different from
7757 *  |  |       pi+ p and/or pi- p (reasonable above 5 GeV/c)
7758          ELSE
7759             KHELP  = KTARG / 8
7760             K2HLP  = ( KP - 23 ) / 3
7761 *  |  |  Number of diagrams:
7762 *  |  |  For u ubar (k2hlp=0):
7763 *           NDIAGR = 2 - KHELP
7764 *  |  |  For d dbar (k2hlp=1):
7765 *           NDIAGR = 2 + KHELP - K2HLP
7766             NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP
7767             SHNCIN = HLFHLF * ( SPPPIN + SPMPIN )
7768 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7769             IQFSC1 = 1 + K2HLP
7770             IQFSC2 = 0
7771             IQBSC1 = 1 + KHELP
7772             IQBSC2 = 2 - K2HLP
7773          END IF
7774 *  |  |
7775 *  |  +----------------------------------------------------------------*
7776 *  |                                                   end pi's
7777 *  +-------------------------------------------------------------------*
7778 *  |  Kaons:
7779       ELSE IF ( IHLP (IP) .EQ. 3 ) THEN
7780          ACOF = SGTCOE (1,6)
7781          BCOF = SGTCOE (2,6)
7782          ENNE = SGTCOE (3,6)
7783          CCOF = SGTCOE (4,6)
7784          DCOF = SGTCOE (5,6)
7785 *  |  Compute the K+ p total cross section:
7786          SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7787      &          + DCOF * ALGPLA
7788          ACOF = SGTCOE (1,21)
7789          BCOF = SGTCOE (2,21)
7790          ENNE = SGTCOE (3,21)
7791          CCOF = SGTCOE (4,21)
7792          DCOF = SGTCOE (5,21)
7793 *  |  Compute the K+ p elastic cross section:
7794          SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7795      &          + DCOF * ALGPLA
7796 *  |  Compute the K+ p inelastic cross section:
7797          SKPPIN = SKPPTT - SKPPEL
7798          ACOF = SGTCOE (1,9)
7799          BCOF = SGTCOE (2,9)
7800          ENNE = SGTCOE (3,9)
7801          CCOF = SGTCOE (4,9)
7802          DCOF = SGTCOE (5,9)
7803 *  |  Compute the K- p total cross section:
7804          SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7805      &          + DCOF * ALGPLA
7806          ACOF = SGTCOE (1,22)
7807          BCOF = SGTCOE (2,22)
7808          ENNE = SGTCOE (3,22)
7809          CCOF = SGTCOE (4,22)
7810          DCOF = SGTCOE (5,22)
7811 *  |  Compute the K- p elastic cross section:
7812          SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7813      &          + DCOF * ALGPLA
7814 *  |  Compute the K- p inelastic cross section:
7815          SKMPIN = SKMPTT - SKMPEL
7816          SIGDIA = HLFHLF * ( SKMPIN - SKPPIN )
7817 *  |  +----------------------------------------------------------------*
7818 *  |  |  Charged Kaons: actually only K-
7819          IF ( ICHRGE (IP) .NE. 0 ) THEN
7820             KHELP = KTARG / 8
7821 *  |  |  +-------------------------------------------------------------*
7822 *  |  |  |  Proton target:
7823             IF ( KHELP .EQ. 0 ) THEN
7824                SHNCIN = SKMPIN
7825 *  |  |  |  Number of diagrams:
7826                NDIAGR = 2
7827 *  |  |  |
7828 *  |  |  +-------------------------------------------------------------*
7829 *  |  |  |  Neutron target: besides isospin consideration it is supposed
7830 *  |  |  |              that (K- n)el is almost equal to (K- p)el
7831 *  |  |  |              (reasonable above 5 GeV/c)
7832             ELSE
7833                ACOF = SGTCOE (1,10)
7834                BCOF = SGTCOE (2,10)
7835                ENNE = SGTCOE (3,10)
7836                CCOF = SGTCOE (4,10)
7837                DCOF = SGTCOE (5,10)
7838 *  |  |  |  Compute the total cross section:
7839                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7840      &                + DCOF * ALGPLA
7841 *  |  |  |  Compute the elastic cross section:
7842                SHNCEL = SKMPEL
7843 *  |  |  |  Compute the inelastic cross section:
7844                SHNCIN = SHNCTT - SHNCEL
7845 *  |  |  |  Number of diagrams:
7846                NDIAGR = 1
7847             END IF
7848 *  |  |  |
7849 *  |  |  +-------------------------------------------------------------*
7850 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7851             IQFSC1 = 3
7852             IQFSC2 = 0
7853             IQBSC1 = 1 + KHELP
7854             IQBSC2 = 2
7855 *  |  |
7856 *  |  +----------------------------------------------------------------*
7857 *  |  |  K0's: (actually only K0bar)
7858          ELSE
7859             KHELP  = KTARG / 8
7860 *  |  |  +-------------------------------------------------------------*
7861 *  |  |  |  Proton target: (K0bar p)in supposed to be given by
7862 *  |  |  |                 (K- p)in - Sig_diagr
7863             IF ( KHELP .EQ. 0 ) THEN
7864                SHNCIN = SKMPIN - SIGDIA
7865 *  |  |  |  Number of diagrams:
7866                NDIAGR = 1
7867 *  |  |  |
7868 *  |  |  +-------------------------------------------------------------*
7869 *  |  |  |  Neutron target: (K0bar n)in supposed to be given by
7870 *  |  |  |                 (K- n)in + Sig_diagr
7871 *  |  |  |              besides isospin consideration it is supposed
7872 *  |  |  |              that (K- n)el is almost equal to (K- p)el
7873 *  |  |  |              (reasonable above 5 GeV/c)
7874             ELSE
7875                ACOF = SGTCOE (1,10)
7876                BCOF = SGTCOE (2,10)
7877                ENNE = SGTCOE (3,10)
7878                CCOF = SGTCOE (4,10)
7879                DCOF = SGTCOE (5,10)
7880 *  |  |  |  Compute the total cross section:
7881                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7882      &                + DCOF * ALGPLA
7883 *  |  |  |  Compute the elastic cross section:
7884                SHNCEL = SKMPEL
7885 *  |  |  |  Compute the inelastic cross section:
7886                SHNCIN = SHNCTT - SHNCEL + SIGDIA
7887 *  |  |  |  Number of diagrams:
7888                NDIAGR = 2
7889             END IF
7890 *  |  |  |
7891 *  |  |  +-------------------------------------------------------------*
7892 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7893             IQFSC1 = 3
7894             IQFSC2 = 0
7895             IQBSC1 = 1
7896             IQBSC2 = 1 + KHELP
7897          END IF
7898 *  |  |
7899 *  |  +----------------------------------------------------------------*
7900 *  |                                                   end Kaon's
7901 *  +-------------------------------------------------------------------*
7902 *  |  Antinucleons:
7903       ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN
7904 *  |  For momenta between 3 and 5 GeV/c the use of tabulated data
7905 *  |  should be implemented!
7906          ACOF = SGTCOE (1,15)
7907          BCOF = SGTCOE (2,15)
7908          ENNE = SGTCOE (3,15)
7909          CCOF = SGTCOE (4,15)
7910          DCOF = SGTCOE (5,15)
7911 *  |  Compute the pbar p total cross section:
7912          SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7913      &          + DCOF * ALGPLA
7914          IF ( PLA .LT. FIVFIV ) THEN
7915             JREAC = 26
7916          ELSE
7917             JREAC = 25
7918          END IF
7919          ACOF = SGTCOE (1,JREAC)
7920          BCOF = SGTCOE (2,JREAC)
7921          ENNE = SGTCOE (3,JREAC)
7922          CCOF = SGTCOE (4,JREAC)
7923          DCOF = SGTCOE (5,JREAC)
7924 *  |  Compute the pbar p elastic cross section:
7925          SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7926      &          + DCOF * ALGPLA
7927 *  |  Compute the pbar p inelastic cross section:
7928          SAPPIN = SAPPTT - SAPPEL
7929          ACOF = SGTCOE (1,12)
7930          BCOF = SGTCOE (2,12)
7931          ENNE = SGTCOE (3,12)
7932          CCOF = SGTCOE (4,12)
7933          DCOF = SGTCOE (5,12)
7934 *  |  Compute the p p total cross section:
7935          SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7936      &          + DCOF * ALGPLA
7937          ACOF = SGTCOE (1,23)
7938          BCOF = SGTCOE (2,23)
7939          ENNE = SGTCOE (3,23)
7940          CCOF = SGTCOE (4,23)
7941          DCOF = SGTCOE (5,23)
7942 *  |  Compute the p p elastic cross section:
7943          SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7944      &          + DCOF * ALGPLA
7945 *  |  Compute the K- p inelastic cross section:
7946          SPPINE = SPPTOT - SPPELA
7947          SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV
7948          KHELP  = KTARG / 8
7949 *  |  +----------------------------------------------------------------*
7950 *  |  |  Pbar:
7951          IF ( ICHRGE (IP) .NE. 0 ) THEN
7952             NDIAGR = 5 - KHELP
7953 *  |  |  +-------------------------------------------------------------*
7954 *  |  |  |  Proton target:
7955             IF ( KHELP .EQ. 0 ) THEN
7956 *  |  |  |  Number of diagrams:
7957                SHNCIN = SAPPIN
7958                PUUBAR = 0.8D+00
7959 *  |  |  |
7960 *  |  |  +-------------------------------------------------------------*
7961 *  |  |  |  Neutron target: it is supposed that (ap n)el is almost equal
7962 *  |  |  |                  to (ap p)el (reasonable above 5 GeV/c)
7963             ELSE
7964                ACOF = SGTCOE (1,16)
7965                BCOF = SGTCOE (2,16)
7966                ENNE = SGTCOE (3,16)
7967                CCOF = SGTCOE (4,16)
7968                DCOF = SGTCOE (5,16)
7969 *  |  |  |  Compute the total cross section:
7970                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7971      &                + DCOF * ALGPLA
7972 *  |  |  |  Compute the elastic cross section:
7973                SHNCEL = SAPPEL
7974 *  |  |  |  Compute the inelastic cross section:
7975                SHNCIN = SHNCTT - SHNCEL
7976                PUUBAR = HLFHLF
7977             END IF
7978 *  |  |  |
7979 *  |  |  +-------------------------------------------------------------*
7980 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7981 *  |  |  there are different possibilities, make a random choiche:
7982             IQFSC1 = -1
7983             RNCHEN = DT_RNDM(PUUBAR)
7984             IF ( RNCHEN .LT. PUUBAR ) THEN
7985                IQFSC2 = -2
7986             ELSE
7987                IQFSC2 = -1
7988             END IF
7989             IQBSC1 = -IQFSC1 + KHELP
7990             IQBSC2 = -IQFSC2
7991 *  |  |
7992 *  |  +----------------------------------------------------------------*
7993 *  |  |  nbar:
7994          ELSE
7995             NDIAGR = 4 + KHELP
7996 *  |  |  +-------------------------------------------------------------*
7997 *  |  |  |  Proton target: (nbar p)in supposed to be given by
7998 *  |  |  |                 (pbar p)in - Sig_diagr
7999             IF ( KHELP .EQ. 0 ) THEN
8000                SHNCIN = SAPPIN - SIGDIA
8001                PDDBAR = HLFHLF
8002 *  |  |  |
8003 *  |  |  +-------------------------------------------------------------*
8004 *  |  |  |  Neutron target: (nbar n)el is supposed to be equal to
8005 *  |  |  |                  (pbar p)el (reasonable above 5 GeV/c)
8006             ELSE
8007 *  |  |  |  Compute the total cross section:
8008                SHNCTT = SAPPTT
8009 *  |  |  |  Compute the elastic cross section:
8010                SHNCEL = SAPPEL
8011 *  |  |  |  Compute the inelastic cross section:
8012                SHNCIN = SHNCTT - SHNCEL
8013                PDDBAR = 0.8D+00
8014             END IF
8015 *  |  |  |
8016 *  |  |  +-------------------------------------------------------------*
8017 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8018 *  |  |  there are different possibilities, make a random choiche:
8019             IQFSC1 = -2
8020             RNCHEN = DT_RNDM(RNCHEN)
8021             IF ( RNCHEN .LT. PDDBAR ) THEN
8022                IQFSC2 = -1
8023             ELSE
8024                IQFSC2 = -2
8025             END IF
8026             IQBSC1 = -IQFSC1 + KHELP - 1
8027             IQBSC2 = -IQFSC2
8028          END IF
8029 *  |  |
8030 *  |  +----------------------------------------------------------------*
8031 *  |
8032 *  +-------------------------------------------------------------------*
8033 *  |  Others: not yet implemented
8034       ELSE
8035          SIGDIA = ZERZER
8036          SHNCIN = ONEONE
8037          NDIAGR = 0
8038          DT_PHNSCH = ZERZER
8039          RETURN
8040       END IF
8041 *  |                                                   end others
8042 *  +-------------------------------------------------------------------*
8043       DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN
8044       IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1)
8045      &       + IQECHR (IQBSC2)
8046       IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1)
8047      &       + IQBCHR (IQBSC2)
8048       IQECHC = IQECHC / 3
8049       IQBCHC = IQBCHC / 3
8050       IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1)
8051      &       + IQSCHR (IQBSC2)
8052       IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP))
8053      &       + IQSCHR (MQUARK(3,IP))
8054 *  +-------------------------------------------------------------------*
8055 *  |  Consistency check:
8056       IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN
8057          WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla',
8058      &                         DT_PHNSCH,KP,KTARG,PLA,' ****'
8059          WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla',
8060      &                         DT_PHNSCH,KP,KTARG,PLA,' ****'
8061          DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER )
8062          DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE )
8063       END IF
8064 *  |
8065 *  +-------------------------------------------------------------------*
8066 *  +-------------------------------------------------------------------*
8067 *  |  Consistency check:
8068       IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG)
8069      &     .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN
8070          WRITE (LUNOUT,*)
8071      &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8072      &      IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8073          WRITE (LUNERR,*)
8074      &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8075      &      IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8076       END IF
8077 *  |
8078 *  +-------------------------------------------------------------------*
8079 *  P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8080       IF ( UMORAT .GT. ONEPLS )
8081      &   DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH
8082      &                                 - ONEONE ) * UMORAT + ONEONE )
8083       RETURN
8084 *
8085       ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 )
8086       DT_SCHQUA = ONEONE
8087       JQFSC1 = IQFSC1
8088       JQFSC2 = IQFSC2
8089       JQBSC1 = IQBSC1
8090       JQBSC2 = IQBSC2
8091 *=== End of function Phnsch ===========================================*
8092       RETURN
8093       END
8094
8095 *$ CREATE DT_RESPT.FOR
8096 *COPY DT_RESPT
8097 *
8098 *===respt==============================================================*
8099 *
8100       SUBROUTINE DT_RESPT
8101
8102 ************************************************************************
8103 * Check DTEVT1 for two-resonance systems and sample intrinsic p_t.     *
8104 * This version dated 18.01.95 is written by S. Roesler                 *
8105 ************************************************************************
8106
8107       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8108       SAVE
8109       PARAMETER ( LINP = 10 ,
8110      &            LOUT = 6 ,
8111      &            LDAT = 9 )
8112       PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8113
8114 * event history
8115       PARAMETER (NMXHKK=200000)
8116       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8117      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8118      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8119 * extended event history
8120       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8121      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8122      &                IHIST(2,NMXHKK)
8123
8124 * get index of first chain
8125       DO 1 I=NPOINT(3),NHKK
8126          IF (IDHKK(I).EQ.88888) THEN
8127             NC = I
8128             GOTO 2
8129          ENDIF
8130     1 CONTINUE
8131
8132     2 CONTINUE
8133       IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN
8134 C        WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3)
8135 * skip VV-,SS- systems
8136          IF ((IDCH(NC  ).NE.1).AND.(IDCH(NC  ).NE.8).AND.
8137      &       (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN
8138 * check if both "chains" are resonances
8139             IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN
8140                CALL DT_SAPTRE(NC,NC+3)
8141             ENDIF
8142          ENDIF
8143       ELSE
8144          GOTO 3
8145       ENDIF
8146       NC = NC+6
8147       GOTO 2
8148
8149     3 CONTINUE
8150
8151       RETURN
8152       END
8153
8154 *$ CREATE DT_EVTRES.FOR
8155 *COPY DT_EVTRES
8156 *
8157 *===evtres=============================================================*
8158 *
8159       SUBROUTINE DT_EVTRES(IREJ)
8160
8161 ************************************************************************
8162 * This version dated 14.12.94 is written by S. Roesler                 *
8163 ************************************************************************
8164
8165       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8166       SAVE
8167       PARAMETER ( LINP = 10 ,
8168      &            LOUT = 6 ,
8169      &            LDAT = 9 )
8170       PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10)
8171
8172 * event history
8173       PARAMETER (NMXHKK=200000)
8174       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8175      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8176      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8177 * extended event history
8178       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8179      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8180      &                IHIST(2,NMXHKK)
8181 * flags for input different options
8182       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8183       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8184      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8185 * particle properties (BAMJET index convention)
8186       CHARACTER*8  ANAME
8187       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
8188      &                IICH(210),IIBAR(210),K1(210),K2(210)
8189
8190       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2)
8191
8192       IREJ = 0
8193
8194       DO 1 I=NPOINT(3),NHKK
8195          IF (ABS(IDRES(I)).GE.100) THEN
8196             AMMX = 0.0D0
8197             DO 2 J=NPOINT(3),NHKK
8198                IF (IDHKK(J).EQ.88888) THEN
8199                   IF (PHKK(5,J).GT.AMMX) THEN
8200                      AMMX = PHKK(5,J)
8201                      IMMX = J
8202                   ENDIF
8203                ENDIF
8204     2       CONTINUE
8205             IF (IDRES(IMMX).NE.0) THEN
8206                IF (IOULEV(3).GT.0) THEN
8207                   WRITE(LOUT,'(1X,A)')
8208      &               'EVTRES: no chain for correc. found'
8209 C                 GOTO 6
8210                   GOTO 9999
8211                ELSE
8212                   GOTO 9999
8213                ENDIF
8214             ENDIF
8215             IMO11  = JMOHKK(1,I)
8216             IMO12  = JMOHKK(2,I)
8217             IF (PHKK(3,IMO11).LT.0.0D0) THEN
8218                IMO11 = JMOHKK(2,I)
8219                IMO12 = JMOHKK(1,I)
8220             ENDIF
8221             IMO21  = JMOHKK(1,IMMX)
8222             IMO22  = JMOHKK(2,IMMX)
8223             IF (PHKK(3,IMO21).LT.0.0D0) THEN
8224                IMO21 = JMOHKK(2,IMMX)
8225                IMO22 = JMOHKK(1,IMMX)
8226             ENDIF
8227             AMCH1  = PHKK(5,I)
8228             AMCH1N = AAM(IDXRES(I))
8229
8230             IFPR1 = IDHKK(IMO11)
8231             IFPR2 = IDHKK(IMO21)
8232             IFTA1 = IDHKK(IMO12)
8233             IFTA2 = IDHKK(IMO22)
8234             DO 4 J=1,4
8235                PP1(J) = PHKK(J,IMO11)
8236                PP2(J) = PHKK(J,IMO21)
8237                PT1(J) = PHKK(J,IMO12)
8238                PT2(J) = PHKK(J,IMO22)
8239     4       CONTINUE
8240 * store initial configuration for energy-momentum cons. check
8241             IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1)
8242 * correct kinematics of second chain
8243             CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
8244      &                  AMCH1,AMCH1N,AMCH2,IREJ1)
8245             IF (IREJ1.NE.0) GOTO 9999
8246 * check now this chain for resonance mass
8247             IFP(1) = IDT_IPDG2B(IFPR2,1,2)
8248             IFP(2) = 0
8249             IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2)
8250             IFT(1) = IDT_IPDG2B(IFTA2,1,2)
8251             IFT(2) = 0
8252             IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2)
8253             IDCH2 = 2
8254             IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1
8255             IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3
8256             CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2,
8257      &                  AMCH2,AMCH2N,IDCH2,IREJ1)
8258             IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN
8259                IF (IOULEV(1).GT.0)
8260      &            WRITE(LOUT,*) ' correction for resonance not poss.'
8261 **sr test
8262 C              GOTO 1
8263 C              GOTO 9999
8264 **
8265             ENDIF
8266 * store final configuration for energy-momentum cons. check
8267             IF (LEMCCK) THEN
8268                CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1)
8269                CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
8270                IF (IREJ1.NE.0) GOTO 9999
8271             ENDIF
8272             DO 5 J=1,4
8273                PHKK(J,IMO11) = PP1(J)
8274                PHKK(J,IMO21) = PP2(J)
8275                PHKK(J,IMO12) = PT1(J)
8276                PHKK(J,IMO22) = PT2(J)
8277     5       CONTINUE
8278 * correct entries of chains
8279             DO 3 K=1,4
8280                PHKK(K,I)    = PHKK(K,IMO11)+PHKK(K,IMO12)
8281                PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22)
8282     3       CONTINUE
8283             AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2
8284             AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2-
8285      &            PHKK(3,IMMX)**2
8286 * ?? the following should now be obsolete
8287 **sr test
8288 C           IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN
8289             IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8290 **
8291                WRITE(LOUT,'(1X,A,4G10.3)')
8292      &          'EVTRES: inonsistent mass-corr.',AM1,AM2
8293 C              GOTO 9999
8294                GOTO 1
8295             ENDIF
8296             PHKK(5,I)    = SQRT(AM1)
8297             PHKK(5,IMMX) = SQRT(AM2)
8298             IDRES(I)     = IDRES(I)/100
8299             IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR.
8300      &          (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN
8301                WRITE(LOUT,'(1X,A,4G10.3)')
8302      &          'EVTRES: inconsistent chain-masses',
8303      &          PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2
8304                GOTO 9999
8305             ENDIF
8306          ENDIF
8307     1 CONTINUE
8308     6 CONTINUE
8309       RETURN
8310
8311  9999 CONTINUE
8312       IREJ = 1
8313       RETURN
8314       END
8315
8316 *$ CREATE DT_GETSPT.FOR
8317 *COPY DT_GETSPT
8318 *
8319 *===getspt=============================================================*
8320 *
8321       SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2,
8322      &                  PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2,
8323      &                  AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ)
8324
8325 ************************************************************************
8326 * This version dated 12.12.94 is written by S. Roesler                 *
8327 ************************************************************************
8328
8329       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8330       SAVE
8331       PARAMETER ( LINP = 10 ,
8332      &            LOUT = 6 ,
8333      &            LDAT = 9 )
8334       PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)
8335
8336 * various options for treatment of partons (DTUNUC 1.x)
8337 * (chain recombination, Cronin,..)
8338       LOGICAL LCO2CR,LINTPT
8339       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8340      &                LCO2CR,LINTPT
8341 * flags for input different options
8342       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8343       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8344      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8345 * flags for diffractive interactions (DTUNUC 1.x)
8346       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
8347
8348       DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4),
8349      &          PT2(4),PT2I(4),P1(4),P2(4),
8350      &          IFP1(2),IFP2(2),IFT1(2),IFT2(2),
8351      &          PTOTI(4),PTOTF(4),DIFF(4)
8352
8353       IC   = 0
8354       IREJ = 0
8355 C     B33P = 4.0D0
8356 C     B33T = 4.0D0
8357 C     IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
8358 C     IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
8359       REDU = 1.0D0
8360 C     B33P = 3.5D0
8361 C     B33T = 3.5D0
8362       B33P = 4.0D0
8363       B33T = 4.0D0
8364       IF (IDIFF.NE.0) THEN
8365          B33P = 16.0D0
8366          B33T = 16.0D0
8367       ENDIF
8368
8369       DO 1 I=1,4
8370          PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I)
8371          PP1(I)   = PP1I(I)
8372          PP2(I)   = PP2I(I)
8373          PT1(I)   = PT1I(I)
8374          PT2(I)   = PT2I(I)
8375     1 CONTINUE
8376 * get initial chain masses
8377       PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8378      &                               +(PP1(3)+PT1(3))**2)
8379       ECH   = PP1(4)+PT1(4)
8380       AM1   = (ECH+PTOCH)*(ECH-PTOCH)
8381       PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8382      &                               +(PP2(3)+PT2(3))**2)
8383       ECH   = PP2(4)+PT2(4)
8384       AM2   = (ECH+PTOCH)*(ECH-PTOCH)
8385       IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8386          IF (IOULEV(1).GT.0)
8387      &   WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1',
8388      &                              AM1,AM2
8389          GOTO 9999
8390       ENDIF
8391       AM1  = SQRT(AM1)
8392       AM2  = SQRT(AM2)
8393       AM1N = ZERO
8394       AM2N = ZERO
8395
8396       MODE = 0
8397 C      IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
8398 C        MODE = 0
8399 C      ELSE
8400 C         MODE = 1
8401 C         IF (AM1.LT.0.6) THEN
8402 C            B33P = 10.0D0
8403 C         ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
8404 CC           B33P = 4.0D0
8405 C         ENDIF
8406 C         IF (AM2.LT.0.6) THEN
8407 C            B33T = 10.0D0
8408 C         ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
8409 CC           B33T = 4.0D0
8410 C         ENDIF
8411 C      ENDIF
8412
8413 * check chain masses for very low mass chains
8414 C     CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8415 C    &            AM1,DUM,-IDCH1,IREJ1)
8416 C     CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8417 C    &            AM2,DUM,-IDCH2,IREJ2)
8418 C     IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
8419 C        B33P = 20.0D0
8420 C        B33T = 20.0D0
8421 C     ENDIF
8422
8423       JMSHL = IMSHL
8424
8425     2 CONTINUE
8426       IC = IC+1
8427       IF (MOD(IC,15).EQ.0) B33P  = 2.0D0*B33P
8428       IF (MOD(IC,15).EQ.0) B33T  = 2.0D0*B33T
8429       IF (MOD(IC,18).EQ.0) REDU  = 0.0D0
8430 C     IF (MOD(IC,19).EQ.0) JMSHL = 0
8431       IF (MOD(IC,20).EQ.0) GOTO 7
8432 C        WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
8433 C        RETURN
8434 C        GOTO 9999
8435 C     ENDIF
8436
8437 * get transverse momentum
8438       IF (LINTPT) THEN
8439          ES   = -2.0D0/(B33P**2)
8440      &          *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8441          HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0)
8442          HPSP = HPSP*REDU
8443          ES   = -2.0D0/(B33T**2)
8444      &          *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8445          HPST = SQRT(ES*ES+2.0D0*ES*0.94D0)
8446          HPST = HPST*REDU
8447       ELSE
8448          HPSP = ZERO
8449          HPST = ZERO
8450       ENDIF
8451       CALL DT_DSFECF(SFE1,CFE1)
8452       CALL DT_DSFECF(SFE2,CFE2)
8453       IF (MODE.EQ.0) THEN
8454          PP1(1) = PP1I(1)+HPSP*CFE1
8455          PP1(2) = PP1I(2)+HPSP*SFE1
8456          PP2(1) = PP2I(1)-HPSP*CFE1
8457          PP2(2) = PP2I(2)-HPSP*SFE1
8458          PT1(1) = PT1I(1)+HPST*CFE2
8459          PT1(2) = PT1I(2)+HPST*SFE2
8460          PT2(1) = PT2I(1)-HPST*CFE2
8461          PT2(2) = PT2I(2)-HPST*SFE2
8462       ELSE
8463          PP1(1) = PP1I(1)+HPSP*CFE1
8464          PP1(2) = PP1I(2)+HPSP*SFE1
8465          PT1(1) = PT1I(1)-HPSP*CFE1
8466          PT1(2) = PT1I(2)-HPSP*SFE1
8467          PP2(1) = PP2I(1)+HPST*CFE2
8468          PP2(2) = PP2I(2)+HPST*SFE2
8469          PT2(1) = PT2I(1)-HPST*CFE2
8470          PT2(2) = PT2I(2)-HPST*SFE2
8471       ENDIF
8472
8473 * put partons on mass shell
8474       XMP1 = 0.0D0
8475       XMT1 = 0.0D0
8476       IF (JMSHL.EQ.1) THEN
8477          XMP1 = PYMASS(IFPR1)
8478          XMT1 = PYMASS(IFTA1)
8479       ENDIF
8480       CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1)
8481       IF (IREJ1.NE.0) GOTO 2
8482       DO 3 I=1,4
8483          PTOTF(I) = P1(I)+P2(I)
8484          PP1(I)   = P1(I)
8485          PT1(I)   = P2(I)
8486     3 CONTINUE
8487       XMP2 = 0.0D0
8488       XMT2 = 0.0D0
8489       IF (JMSHL.EQ.1) THEN
8490          XMP2 = PYMASS(IFPR2)
8491          XMT2 = PYMASS(IFTA2)
8492       ENDIF
8493       CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1)
8494       IF (IREJ1.NE.0) GOTO 2
8495       DO 4 I=1,4
8496          PTOTF(I) = PTOTF(I)+P1(I)+P2(I)
8497          PP2(I)   = P1(I)
8498          PT2(I)   = P2(I)
8499     4 CONTINUE
8500
8501 * check consistency
8502       DO 5 I=1,4
8503          DIFF(I) = PTOTI(I)-PTOTF(I)
8504     5 CONTINUE
8505       IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR.
8506      &    (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN
8507          WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF
8508          GOTO 9999
8509       ENDIF
8510       PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2)
8511       AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) ))
8512       PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2)
8513       AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) ))
8514       PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2)
8515       AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) ))
8516       PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2)
8517       AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) ))
8518       IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR.
8519      &    (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3))
8520      &                                                           THEN
8521          WRITE(LOUT,'(1X,A,2(4G10.3,/))')
8522      &     'GETSPT: inconsistent masses',
8523      &     AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2
8524 * sr 22.11.00: commented. It should only have inconsistent masses for
8525 * ultrahigh energies due to rounding problems
8526 C        GOTO 9999
8527       ENDIF
8528
8529 * get chain masses
8530       PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8531      &                               +(PP1(3)+PT1(3))**2)
8532       ECH   = PP1(4)+PT1(4)
8533       AM1N  = (ECH+PTOCH)*(ECH-PTOCH)
8534       PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8535      &                               +(PP2(3)+PT2(3))**2)
8536       ECH   = PP2(4)+PT2(4)
8537       AM2N  = (ECH+PTOCH)*(ECH-PTOCH)
8538       IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN
8539          IF (IOULEV(1).GT.0)
8540      &   WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2',
8541      &                              AM1N,AM2N
8542          GOTO 2
8543       ENDIF
8544       AM1N = SQRT(AM1N)
8545       AM2N = SQRT(AM2N)
8546
8547 * check chain masses for very low mass chains
8548       CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8549      &            AM1N,DUM,-IDCH1,IREJ1)
8550       IF (IREJ1.NE.0) GOTO 2
8551       CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8552      &            AM2N,DUM,-IDCH2,IREJ2)
8553       IF (IREJ2.NE.0) GOTO 2
8554
8555     7 CONTINUE
8556       IF (AM1N.GT.ZERO) THEN
8557          AM1 = AM1N
8558          AM2 = AM2N
8559       ENDIF
8560       DO 6 I=1,4
8561          PP1I(I)   = PP1(I)
8562          PP2I(I)   = PP2(I)
8563          PT1I(I)   = PT1(I)
8564          PT2I(I)   = PT2(I)
8565     6 CONTINUE
8566
8567       RETURN
8568
8569  9999 CONTINUE
8570       IREJ = 1
8571       RETURN
8572       END
8573
8574 *$ CREATE DT_SAPTRE.FOR
8575 *COPY DT_SAPTRE
8576 *
8577 *===saptre=============================================================*
8578 *
8579       SUBROUTINE DT_SAPTRE(IDX1,IDX2)
8580
8581 ************************************************************************
8582 * p-t sampling for two-resonance systems. ("BAMJET-like" method)       *
8583 *        IDX1,IDX2       indices of resonances ("chains") in DTEVT1    *
8584 * Adopted from the original SAPTRE written by J. Ranft.                *
8585 * This version dated 18.01.95 is written by S. Roesler                 *
8586 ************************************************************************
8587
8588       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8589       SAVE
8590       PARAMETER ( LINP = 10 ,
8591      &            LOUT = 6 ,
8592      &            LDAT = 9 )
8593       PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8594
8595 * event history
8596       PARAMETER (NMXHKK=200000)
8597       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8598      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8599      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8600 * extended event history
8601       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8602      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8603      &                IHIST(2,NMXHKK)
8604 * flags for input different options
8605       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8606       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8607      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8608
8609       DIMENSION PA1(4),PA2(4),P1(4),P2(4)
8610
8611       DATA B3 /4.0D0/
8612
8613       ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1)
8614       ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2)
8615       ESMAX  = MIN(ESMAX1,ESMAX2)
8616       IF (ESMAX.LE.0.05D0) RETURN
8617
8618       HMA    = PHKK(5,IDX1)
8619       DO 1 K=1,4
8620          PA1(K) = PHKK(K,IDX1)
8621          PA2(K) = PHKK(K,IDX2)
8622     1 CONTINUE
8623
8624       IF (LEMCCK) THEN
8625          CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM)
8626          CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM)
8627       ENDIF
8628
8629       EXEB   = 0.0D0
8630       IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX)
8631       BEXP   = HMA*(1.0D0-EXEB)/B3
8632       AXEXP  = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2
8633       WA     = AXEXP/(BEXP+AXEXP)
8634       XAB    = DT_RNDM(WA)
8635    10 CONTINUE
8636 * ES is the transverse kinetic energy
8637       IF (XAB.LT.WA)THEN
8638         X  = DT_RNDM(WA)
8639         Y  = DT_RNDM(WA)
8640         ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7)
8641       ELSE
8642         X  = DT_RNDM(Y)
8643         ES = ABS(-LOG(X+TINY7)/B3)
8644       ENDIF
8645       IF (ES.GT.ESMAX) GOTO 10
8646       ES  = ES+HMA
8647 * transverse momentum
8648       HPS = SQRT((ES-HMA)*(ES+HMA))
8649
8650       CALL DT_DSFECF(SFE,CFE)
8651       HPX = HPS*CFE
8652       HPY = HPS*SFE
8653       PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY
8654       PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY
8655       IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN
8656
8657 C     PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3))
8658 C     PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3))
8659       PA1(1) = PA1(1)+HPX
8660       PA1(2) = PA1(2)+HPY
8661       PA2(1) = PA2(1)-HPX
8662       PA2(2) = PA2(2)-HPY
8663
8664 * put resonances on mass-shell again
8665       XM1 = PHKK(5,IDX1)
8666       XM2 = PHKK(5,IDX2)
8667       CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1)
8668       IF (IREJ1.NE.0) RETURN
8669
8670       IF (LEMCCK) THEN
8671          CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM)
8672          CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM)
8673          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1)
8674          IF (IREJ1.NE.0) RETURN
8675       ENDIF
8676
8677       DO 2 K=1,4
8678          PHKK(K,IDX1) = P1(K)
8679          PHKK(K,IDX2) = P2(K)
8680     2 CONTINUE
8681
8682       RETURN
8683       END
8684
8685 *$ CREATE DT_CRONIN.FOR
8686 *COPY DT_CRONIN
8687 *
8688 *===cronin=============================================================*
8689 *
8690       SUBROUTINE DT_CRONIN(INCL)
8691
8692 ************************************************************************
8693 * Cronin-Effect. Multiple scattering of partons at chain ends.         *
8694 *             INCL = 1     multiple sc. in projectile                  *
8695 *                  = 2     multiple sc. in target                      *
8696 * This version dated 05.01.96 is written by S. Roesler.                *
8697 ************************************************************************
8698
8699       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8700       SAVE
8701       PARAMETER ( LINP = 10 ,
8702      &            LOUT = 6 ,
8703      &            LDAT = 9 )
8704       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8705
8706 * event history
8707       PARAMETER (NMXHKK=200000)
8708       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8709      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8710      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8711 * extended event history
8712       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8713      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8714      &                IHIST(2,NMXHKK)
8715 * rejection counter
8716       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8717      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8718      &                IREXCI(3),IRDIFF(2),IRINC
8719 * Glauber formalism: collision properties
8720       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
8721      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
8722
8723       DIMENSION R(3),PIN(4),POUT(4),DEV(4)
8724
8725       DO 1 K=1,4
8726          DEV(K) = ZERO
8727     1 CONTINUE
8728
8729       DO 2 I=NPOINT(2),NHKK
8730          IF (ISTHKK(I).LT.0) THEN
8731 * get z-position of the chain
8732             R(1) = VHKK(1,I)*1.0D12
8733             IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC
8734             R(2) = VHKK(2,I)*1.0D12
8735             IDXNU = JMOHKK(1,I)
8736             IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) )
8737      &                             IDXNU = JMOHKK(1,I-1)
8738             IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) )
8739      &                             IDXNU = JMOHKK(1,I+1)
8740             R(3) = VHKK(3,IDXNU)*1.0D12
8741 * position of target parton the chain is connected to
8742             DO 3 K=1,4
8743                PIN(K) = PHKK(K,I)
8744     3       CONTINUE
8745 * multiple scattering of parton with DTEVT1-index I
8746             CALL DT_CROMSC(PIN,R,POUT,INCL)
8747 **testprint
8748 C           IF (NEVHKK.EQ.5) THEN
8749 C              AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2
8750 C              AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2
8751 C              AMIN = SIGN(SQRT(ABS(AMIN)),AMIN)
8752 C              AMOU = SIGN(SQRT(ABS(AMOU)),AMOU)
8753 C              WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU
8754 C              WRITE(6,'(A,4E15.5)')'PIN:       ',PIN
8755 C              WRITE(6,'(A,4E15.5)')'POUT:      ',POUT
8756 C           ENDIF
8757 **
8758 * increase accumulator by energy-momentum difference
8759             DO 4 K=1,4
8760                DEV(K)    = DEV(K)+POUT(K)-PIN(K)
8761                PHKK(K,I) = POUT(K)
8762     4       CONTINUE
8763             PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8764      &                           PHKK(2,I)**2-PHKK(3,I)**2))
8765          ENDIF
8766     2 CONTINUE
8767
8768 * dump accumulator to momenta of valence partons
8769       NVAL = 0
8770       ETOT = 0.0D0
8771       DO 5 I=NPOINT(2),NHKK
8772          IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8773             NVAL = NVAL+1
8774             ETOT = ETOT+PHKK(4,I)
8775          ENDIF
8776     5 CONTINUE
8777 C     WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4)
8778  1000 FORMAT(1X,'CRONIN :  number of val. partons ',I4,/,
8779      &       9X,4E12.4)
8780       DO 6 I=NPOINT(2),NHKK
8781          IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8782             E = PHKK(4,I)
8783             DO 7 K=1,4
8784 C              PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL)
8785                PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT
8786     7       CONTINUE
8787             PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8788      &                           PHKK(2,I)**2-PHKK(3,I)**2))
8789          ENDIF
8790     6 CONTINUE
8791
8792       RETURN
8793       END
8794
8795 *$ CREATE DT_CROMSC.FOR
8796 *COPY DT_CROMSC
8797 *
8798 *===cromsc=============================================================*
8799 *
8800       SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL)
8801
8802 ************************************************************************
8803 * Cronin-Effect. Multiple scattering of one parton passing through     *
8804 * nuclear matter.                                                      *
8805 *            PIN(4)       input 4-momentum of parton                   *
8806 *            POUT(4)      4-momentum of parton after mult. scatt.      *
8807 *            R(3)         spatial position of parton in target nucleus *
8808 *            INCL = 1     multiple sc. in projectile                   *
8809 *                 = 2     multiple sc. in target                       *
8810 * This is a revised version of the original version written by J. Ranft*
8811 * This version dated 17.01.95 is written by S. Roesler.                *
8812 ************************************************************************
8813
8814       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8815       SAVE
8816       PARAMETER ( LINP = 10 ,
8817      &            LOUT = 6 ,
8818      &            LDAT = 9 )
8819       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8820
8821       LOGICAL LSTART
8822
8823 * rejection counter
8824       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8825      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8826      &                IREXCI(3),IRDIFF(2),IRINC
8827 * Glauber formalism: collision properties
8828       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
8829      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
8830 * various options for treatment of partons (DTUNUC 1.x)
8831 * (chain recombination, Cronin,..)
8832       LOGICAL LCO2CR,LINTPT
8833       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8834      &                LCO2CR,LINTPT
8835
8836       DIMENSION PIN(4),POUT(4),R(3)
8837
8838       DATA LSTART /.TRUE./
8839
8840       IRCRON(1) = IRCRON(1)+1
8841
8842       IF (LSTART) THEN
8843          WRITE(LOUT,1000) CRONCO
8844  1000    FORMAT(/,1X,'CROMSC:  multiple scattering of chain ends',
8845      &          ' treated',/,10X,'with parameter CRONCO = ',F5.2)
8846          LSTART = .FALSE.
8847       ENDIF
8848
8849       NCBACK = 0
8850       RNCL   = RPROJ
8851       IF (INCL.EQ.2) RNCL = RTARG
8852
8853 * Lorentz-transformation into Lab.
8854       MODE = -(INCL+1)
8855       CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE)
8856
8857       PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2)
8858       IF (PTOT.LE.8.0D0) GOTO 9997
8859
8860 * direction cosines of parton before mult. scattering
8861       COSX = PIN(1)/PTOT
8862       COSY = PIN(2)/PTOT
8863       COSZ = PZ/PTOT
8864
8865       RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2
8866       IF (RTESQ.GE.-TINY3) GOTO 9999
8867
8868 * calculate distance (DIST) from R to surface of nucleus (radius RNCL)
8869 * in the direction of particle motion
8870
8871       A    = COSX*R(1)+COSY*R(2)+COSZ*R(3)
8872       TMP  = A**2-RTESQ
8873       IF (TMP.LT.ZERO) GOTO 9998
8874       DIST = -A+SQRT(TMP)
8875
8876 * multiple scattering angle
8877       THETO = CRONCO*SQRT(DIST)/PTOT
8878       IF (THETO.GT.0.1D0) THETO=0.1D0
8879
8880     1 CONTINUE
8881 * Gaussian sampling of spatial angle
8882       CALL DT_RANNOR(R1,R2)
8883       THETA = ABS(R1*THETO)
8884       IF (THETA.GT.0.3D0) GOTO 9997
8885       CALL DT_DSFECF(SFE,CFE)
8886       COSTH = COS(THETA)
8887       SINTH = SIN(THETA)
8888
8889 * new direction cosines
8890       CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE,
8891      &                               COSXN,COSYN,COSZN)
8892
8893       POUT(1) = COSXN*PTOT
8894       POUT(2) = COSYN*PTOT
8895       PZ      = COSZN*PTOT
8896 * Lorentz-transformation into nucl.-nucl. cms
8897       MODE = INCL+1
8898       CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE)
8899
8900 C     IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
8901 C     IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN
8902       IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN
8903          THETO = THETO/2.0D0
8904          NCBACK = NCBACK+1
8905          IF (MOD(NCBACK,200).EQ.0) THEN
8906             WRITE(LOUT,1001) THETO,PIN,POUT
8907  1001       FORMAT(1X,'CROMSC: inconsistent scattering angle ',
8908      &             E12.4,/,1X,'        PIN :',4E12.4,/,
8909      &             1X,'       POUT:',4E12.4)
8910             GOTO 9997
8911          ENDIF
8912          GOTO 1
8913       ENDIF
8914
8915       RETURN
8916
8917  9997 IRCRON(2) = IRCRON(2)+1
8918       GOTO 9999
8919  9998 IRCRON(3) = IRCRON(3)+1
8920
8921  9999 CONTINUE
8922       DO 100 K=1,4
8923          POUT(K) = PIN(K)
8924   100 CONTINUE
8925       RETURN
8926       END
8927
8928 *$ CREATE DT_COM2CR.FOR
8929 *COPY DT_COM2CR
8930 *
8931 *===com2sr=============================================================*
8932 *
8933       SUBROUTINE DT_COM2CR
8934
8935 ************************************************************************
8936 * COMbine q-aq chains to Color Ropes (qq-aqaq).                        *
8937 *        CUTOF      parameter determining minimum number of not        *
8938 *                   combined q-aq chains                               *
8939 * This subroutine replaces KKEVCC etc.                                 *
8940 * This version dated 11.01.95 is written by S. Roesler.                *
8941 ************************************************************************
8942
8943       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8944       SAVE
8945       PARAMETER ( LINP = 10 ,
8946      &            LOUT = 6 ,
8947      &            LDAT = 9 )
8948
8949 * event history
8950       PARAMETER (NMXHKK=200000)
8951       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8952      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8953      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8954 * extended event history
8955       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8956      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8957      &                IHIST(2,NMXHKK)
8958 * statistics
8959       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
8960      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
8961      &                ICEVTG(8,0:30)
8962 * various options for treatment of partons (DTUNUC 1.x)
8963 * (chain recombination, Cronin,..)
8964       LOGICAL LCO2CR,LINTPT
8965       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8966      &                LCO2CR,LINTPT
8967
8968       DIMENSION IDXQA(248),IDXAQ(248)
8969
8970       ICCHAI(1,9) = ICCHAI(1,9)+1
8971       NQA = 0
8972       NAQ = 0
8973 * scan DTEVT1 for q-aq, aq-q chains
8974       DO 10 I=NPOINT(3),NHKK
8975 * skip "chains" which are resonances
8976          IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN
8977             MO1 = JMOHKK(1,I)
8978             MO2 = JMOHKK(2,I)
8979             IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN
8980 * q-aq, aq-q chain found, keep index
8981                IF (IDHKK(MO1).GT.0) THEN
8982                   NQA = NQA+1
8983                   IDXQA(NQA) = I
8984                ELSE
8985                   NAQ = NAQ+1
8986                   IDXAQ(NAQ) = I
8987                ENDIF
8988             ENDIF
8989          ENDIF
8990    10 CONTINUE
8991
8992 * minimum number of q-aq chains requested for the same projectile/
8993 * target
8994       NCHMIN = IDT_NPOISS(CUTOF)
8995
8996 * combine q-aq chains of the same projectile
8997       CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1)
8998 * combine q-aq chains of the same target
8999       CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2)
9000 * combine aq-q chains of the same projectile
9001       CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1)
9002 * combine aq-q chains of the same target
9003       CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2)
9004
9005       RETURN
9006       END
9007
9008 *$ CREATE DT_SCN4CR.FOR
9009 *COPY DT_SCN4CR
9010 *
9011 *===scn4cr=============================================================*
9012 *
9013       SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE)
9014
9015 ************************************************************************
9016 * SCan q-aq chains for Color Ropes.                                    *
9017 * This version dated 11.01.95 is written by S. Roesler.                *
9018 ************************************************************************
9019
9020       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9021       SAVE
9022       PARAMETER ( LINP = 10 ,
9023      &            LOUT = 6 ,
9024      &            LDAT = 9 )
9025
9026 * event history
9027       PARAMETER (NMXHKK=200000)
9028       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9029      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9030      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9031 * extended event history
9032       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9033      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9034      &                IHIST(2,NMXHKK)
9035
9036       DIMENSION IDXCH(248),IDXJN(248)
9037
9038       DO 1 I=1,NCH
9039          IF (IDXCH(I).GT.0) THEN
9040             NJOIN = 1
9041             IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I))))
9042             IDXJN(NJOIN) = I
9043             IF (I.LT.NCH) THEN
9044                DO 2 J=I+1,NCH
9045                   IF (IDXCH(J).GT.0) THEN
9046                      IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J))))
9047                      IF (IDXMO.EQ.IDXMO1) THEN
9048                         NJOIN = NJOIN+1
9049                         IDXJN(NJOIN) = J
9050                      ENDIF
9051                   ENDIF
9052     2          CONTINUE
9053             ENDIF
9054             IF (NJOIN.GE.NCHMIN+2) THEN
9055                NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0)
9056                DO 3 J=1,2*NJ,2
9057                   CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1)
9058                   IF (IREJ1.NE.0) GOTO 3
9059                   IDXCH(IDXJN(J))   = 0
9060                   IDXCH(IDXJN(J+1)) = 0
9061     3          CONTINUE
9062             ENDIF
9063          ENDIF
9064     1 CONTINUE
9065
9066       RETURN
9067       END
9068
9069 *$ CREATE DT_JOIN.FOR
9070 *COPY DT_JOIN
9071 *
9072 *===join===============================================================*
9073 *
9074       SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ)
9075
9076 ************************************************************************
9077 * This subroutine joins two q-aq chains to one qq-aqaq chain.          *
9078 *     IDX1, IDX2       DTEVT1 indices of chains to be joined           *
9079 * This version dated 11.01.95 is written by S. Roesler.                *
9080 ************************************************************************
9081
9082       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9083       SAVE
9084       PARAMETER ( LINP = 10 ,
9085      &            LOUT = 6 ,
9086      &            LDAT = 9 )
9087
9088 * event history
9089       PARAMETER (NMXHKK=200000)
9090       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9091      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9092      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9093 * extended event history
9094       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9095      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9096      &                IHIST(2,NMXHKK)
9097 * flags for input different options
9098       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9099       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9100      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9101 * statistics
9102       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9103      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9104      &                ICEVTG(8,0:30)
9105
9106       DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4)
9107
9108       IREJ   = 0
9109
9110       IDX(1) = IDX1
9111       IDX(2) = IDX2
9112       DO 1 I=1,2
9113          DO 2 J=1,2
9114             MO(I,J) = JMOHKK(J,IDX(I))
9115             ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2)
9116     2    CONTINUE
9117     1 CONTINUE
9118
9119 * check consistency
9120       IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR.
9121      &    (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR.
9122      &    ((ID(1,1)*ID(2,1)).LT.0).OR.
9123      &    ((ID(1,2)*ID(2,2)).LT.0)) THEN
9124          WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1),
9125      &                    MO(2,2)
9126  1000    FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':',
9127      &             2I5,' chain ',I4,':',2I5)
9128       ENDIF
9129
9130 * join chains
9131       DO 3 K=1,4
9132          PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))
9133          PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))
9134     3 CONTINUE
9135       IF1  = IDT_IB2PDG(ID(1,1),ID(2,1),2)
9136       IF2  = IDT_IB2PDG(ID(1,2),ID(2,2),2)
9137       IST1 = ISTHKK(MO(1,1))
9138       IST2 = ISTHKK(MO(1,2))
9139
9140 * put partons again on mass shell
9141       XM1 = 0.0D0
9142       XM2 = 0.0D0
9143       IF (IMSHL.EQ.1) THEN
9144          XM1 = PYMASS(IF1)
9145          XM2 = PYMASS(IF2)
9146       ENDIF
9147       CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1)
9148       IF (IREJ1.NE.0) GOTO 9999
9149       DO 4 I=1,4
9150          PP(I) = P1(I)
9151          PT(I) = P2(I)
9152     4 CONTINUE
9153
9154 * store new partons in DTEVT1
9155       CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4),
9156      &                                                       0,0,0)
9157       CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4),
9158      &                                                       0,0,0)
9159       DO 5 K=1,4
9160          PCH(K) = PP(K)+PT(K)
9161     5 CONTINUE
9162
9163 * check new chain for lower mass limit
9164       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
9165          AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2))
9166          CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM,
9167      &               AMCH,AMCHN,3,IREJ1)
9168          IF (IREJ1.NE.0) THEN
9169             NHKK = NHKK-2
9170             GOTO 9999
9171          ENDIF
9172       ENDIF
9173
9174       ICCHAI(2,9) = ICCHAI(2,9)+1
9175 * store new chain in DTEVT1
9176       KCH = 191
9177       CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9)
9178       IDHKK(IDX(1)) = 22222
9179       IDHKK(IDX(2)) = 22222
9180 * special treatment for space-time coordinates
9181       DO 6 K=1,4
9182          VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0
9183          WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0
9184     6 CONTINUE
9185       RETURN
9186
9187  9999 CONTINUE
9188       IREJ = 1
9189       RETURN
9190       END
9191
9192 *$ CREATE DT_XSGLAU.FOR
9193 *COPY DT_XSGLAU
9194 *
9195 *===xsglau=============================================================*
9196 *
9197       SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX)
9198
9199 ************************************************************************
9200 * Total, elastic, quasi-elastic, inelastic cross sections according to *
9201 * Glauber's approach.                                                  *
9202 *  NA / NB     mass numbers of proj./target nuclei                     *
9203 *  JJPROJ      bamjet-index of projectile (=1 in case of proj.nucleus) *
9204 *  XI,Q2I,ECMI kinematical variables x, Q^2, E_cm                      *
9205 *  IE,IQ       indices of energy and virtuality (the latter for gamma  *
9206 *              projectiles only)                                       *
9207 *  NIDX        index of projectile/target nucleus                      *
9208 * This version dated 17.3.98  is written by S. Roesler                 *
9209 ************************************************************************
9210
9211       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9212       SAVE
9213       PARAMETER ( LINP = 10 ,
9214      &            LOUT = 6 ,
9215      &            LDAT = 9 )
9216
9217       COMPLEX*16 CZERO,CONE,CTWO
9218       CHARACTER*12 CFILE
9219       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9220      &           ONETHI=ONE/THREE,TINY25=1.0D-25)
9221       PARAMETER (TWOPI  = 6.283185307179586454D+00,
9222      &           PI     = TWOPI/TWO,
9223      &           GEV2MB = 0.38938D0,
9224      &           GEV2FM = 0.1972D0,
9225      &           ALPHEM = ONE/137.0D0,
9226 * proton mass
9227      &           AMP    = 0.938D0,
9228      &           AMP2   = AMP**2,
9229 * approx. nucleon radius
9230      &           RNUCLE = 1.12D0)
9231
9232 * particle properties (BAMJET index convention)
9233       CHARACTER*8  ANAME
9234       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
9235      &                IICH(210),IIBAR(210),K1(210),K2(210)
9236       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9237       PARAMETER ( MAXNCL = 260,
9238      &            MAXVQU = MAXNCL,
9239      &            MAXSQU = 20*MAXVQU,
9240      &            MAXINT = MAXVQU+MAXSQU)
9241 * Glauber formalism: parameters
9242       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9243      &                BMAX(NCOMPX),BSTEP(NCOMPX),
9244      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9245      &                NSITEB,NSTATB
9246 * Glauber formalism: cross sections
9247       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
9248      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
9249      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
9250      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
9251      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
9252      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
9253      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
9254      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
9255      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
9256      &                BSLOPE,NEBINI,NQBINI
9257 * Glauber formalism: flags and parameters for statistics
9258       LOGICAL LPROD
9259       CHARACTER*8 CGLB
9260       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
9261 * nucleon-nucleon event-generator
9262       CHARACTER*8 CMODEL
9263       LOGICAL LPHOIN
9264       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
9265 * VDM parameter for photon-nucleus interactions
9266       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
9267 * parameters for hA-diffraction
9268       COMMON /DTDIHA/ DIBETA,DIALPH
9269
9270       COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL),
9271      &           OMPP11,OMPP12,OMPP21,OMPP22,
9272      &           DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP,
9273      &           PPTMP1,PPTMP2
9274       COMPLEX*16 C,CA,CI
9275       DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL),
9276      &          COOP2(3,MAXNCL),COOT2(3,MAXNCL),
9277      &          BPROD(KSITEB)
9278
9279       PARAMETER (NPOINT=16)
9280       DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
9281
9282       LOGICAL LFIRST,LOPEN
9283       DATA LFIRST,LOPEN /.TRUE.,.FALSE./
9284
9285       NTARG = ABS(NIDX)
9286 * for quasi-elastic neutrino scattering set projectile to proton
9287 * it should not have an effect since the whole Glauber-formalism is
9288 * not needed for these interactions..
9289       IF (MCGENE.EQ.4) THEN
9290          IJPROJ = 1
9291       ELSE
9292          IJPROJ = JJPROJ
9293       ENDIF
9294
9295       IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN
9296          I = INDEX(CGLB,' ')
9297          IF (I.EQ.0) THEN
9298             CFILE = CGLB//'.glb'
9299             OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN')
9300          ELSEIF (I.GT.1) THEN
9301             CFILE = CGLB(1:I-1)//'.glb'
9302             OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN')
9303          ELSE
9304             STOP 'XSGLAU 1'
9305          ENDIF
9306          LOPEN = .TRUE.
9307       ENDIF
9308
9309       CZERO  = DCMPLX(ZERO,ZERO)
9310       CONE   = DCMPLX(ONE,ZERO)
9311       CTWO   = DCMPLX(TWO,ZERO)
9312       NEBINI = IE
9313       NQBINI = IQ
9314
9315 * re-define kinematics
9316       S  = ECMI**2
9317       Q2 = Q2I
9318       X  = XI
9319 *  g(Q2=0)-A, h-A, A-A scattering
9320       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9321          Q2 = 0.0001D0
9322          X  = Q2/(S+Q2-AMP2)
9323 *  g(Q2>0)-A scattering
9324       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN
9325          X  = Q2/(S+Q2-AMP2)
9326       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9327          Q2 = (S-AMP2)*X/(ONE-X)
9328       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
9329          S  = Q2*(ONE-X)/X+AMP2
9330       ELSE
9331          WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X
9332          STOP
9333       ENDIF
9334       ECMNN(IE) = SQRT(S)
9335       Q2G(IQ)   = Q2
9336       XNU = (S+Q2-AMP2)/(TWO*AMP)
9337
9338 * parameters determining statistics in evaluating Glauber-xsection
9339       NSTATB = JSTATB
9340       NSITEB = JBINSB
9341       IF (NSITEB.GT.KSITEB) NSITEB = KSITEB
9342
9343 * set up interaction geometry (common /DTGLAM/)
9344 *  projectile/target radii
9345       RPRNCL = DT_RNCLUS(NA)
9346       RTANCL = DT_RNCLUS(NB)
9347       IF (IJPROJ.EQ.7) THEN
9348          RASH(1) = ZERO
9349          RBSH(NTARG) = RTANCL
9350          BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9351       ELSE
9352          IF (NIDX.LE.-1) THEN
9353             RASH(1)     = RPRNCL
9354             RBSH(NTARG) = RTANCL
9355             BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9356          ELSE
9357             RASH(NTARG) = RPRNCL
9358             RBSH(1)     = RTANCL
9359             BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1))
9360          ENDIF
9361       ENDIF
9362 *  maximum impact-parameter
9363       BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1)
9364
9365 * slope, rho ( Re(f(0))/Im(f(0)) )
9366       IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
9367          IF (MCGENE.EQ.2) THEN
9368             ZERO1 = ZERO
9369             CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3,
9370      &                                                   BSLOPE,0)
9371          ELSE
9372             BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
9373          ENDIF
9374          IF (ECMNN(IE).LE.3.0D0) THEN
9375             ROSH = -0.43D0
9376          ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN
9377             ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE))
9378          ELSEIF (ECMNN(IE).GT.50.0D0) THEN
9379             ROSH = 0.1D0
9380          ENDIF
9381       ELSEIF (IJPROJ.EQ.7) THEN
9382          ROSH = 0.1D0
9383       ELSE
9384          BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
9385          ROSH   = 0.01D0
9386       ENDIF
9387
9388 * projectile-nucleon xsection (in fm)
9389       IF (IJPROJ.EQ.7) THEN
9390          SIGSH = DT_SIGVP(X,Q2)/10.0D0
9391       ELSE
9392          ELAB  = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
9393          PLAB  = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
9394 C        SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
9395          DUMZER = ZERO
9396          CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
9397          SIGSH = SIGSH/10.0D0
9398       ENDIF
9399
9400 * parameters for projectile diffraction (hA scattering only)
9401       IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7)
9402      &                               .AND.(DIBETA.GE.ZERO)) THEN
9403          ZERO1 = ZERO
9404          CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0)
9405 C        DIBETA = SDIF1/STOT
9406          DIBETA = 0.2D0
9407          DIGAMM = SQRT(DIALPH**2+DIBETA**2)
9408          IF (DIBETA.LE.ZERO) THEN
9409             ALPGAM = ONE
9410          ELSE
9411             ALPGAM = DIALPH/DIGAMM
9412          ENDIF
9413          FACDI1 = ONE-ALPGAM
9414          FACDI2 = ONE+ALPGAM
9415          FACDI  = SQRT(FACDI1*FACDI2)
9416          WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM
9417       ELSE
9418          DIBETA = -1.0D0
9419          DIALPH = ZERO
9420          DIGAMM = ZERO
9421          FACDI1 = ZERO
9422          FACDI2 = 2.0D0
9423          FACDI  = ZERO
9424       ENDIF
9425
9426 * initializations
9427       DO 10 I=1,NSITEB
9428          BSITE( 0,IQ,NTARG,I) = ZERO
9429          BSITE(IE,IQ,NTARG,I) = ZERO
9430          BPROD(I) = ZERO
9431    10 CONTINUE
9432       STOT  = ZERO
9433       STOT2 = ZERO
9434       SELA  = ZERO
9435       SELA2 = ZERO
9436       SQEP  = ZERO
9437       SQEP2 = ZERO
9438       SQET  = ZERO
9439       SQET2 = ZERO
9440       SQE2  = ZERO
9441       SQE22 = ZERO
9442       SPRO  = ZERO
9443       SPRO2 = ZERO
9444       SDEL  = ZERO
9445       SDEL2 = ZERO
9446       SDQE  = ZERO
9447       SDQE2 = ZERO
9448       FACN   = ONE/DBLE(NSTATB)
9449
9450       IPNT = 0
9451       RPNT = ZERO
9452
9453 *  initialize Gauss-integration for photon-proj.
9454       JPOINT = 1
9455       IF (IJPROJ.EQ.7) THEN
9456          IF (INTRGE(1).EQ.1) THEN
9457             AMLO2 = (3.0D0*AAM(13))**2
9458          ELSEIF (INTRGE(1).EQ.2) THEN
9459             AMLO2 = AAM(33)**2
9460          ELSE
9461             AMLO2 = AAM(96)**2
9462          ENDIF
9463          IF (INTRGE(2).EQ.1) THEN
9464             AMHI2 = S/TWO
9465          ELSEIF (INTRGE(2).EQ.2) THEN
9466             AMHI2 = S/4.0D0
9467          ELSE
9468             AMHI2 = S
9469          ENDIF
9470          AMHI20 = (ECMNN(IE)-AMP)**2
9471          IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
9472          XAMLO = LOG( AMLO2+Q2 )
9473          XAMHI = LOG( AMHI2+Q2 )
9474 **PHOJET105a
9475 C        CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9476 **PHOJET112
9477          CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9478 **
9479          JPOINT = NPOINT
9480 * ratio direct/total photon-nucleon xsection
9481          CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1)
9482       ENDIF
9483
9484 * read pre-initialized profile-function from file
9485       IF (IOGLB.EQ.1) THEN
9486          READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM
9487          IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN
9488             WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB,
9489      &                             NA,NB,NSTATB,NSITEB
9490  1000       FORMAT(' XSGLAU: inconsistent input data in file ',A12,/,
9491      &             ' (IA,IB,ISTATB,ISITEB) ',4I10,/,
9492      &             ' (NA,NB,NSTATB,NSITEB) ',4I10)
9493             STOP
9494          ENDIF
9495          IF (LFIRST) WRITE(LOUT,1001) CFILE
9496  1001    FORMAT(/,' XSGLAU: impact parameter distribution read from ',
9497      &          'file ',A12,/)
9498          READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),
9499      &                         XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG),
9500      &                         XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9501          READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),
9502      &                         XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG),
9503      &                         XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9504          NLINES = INT(DBLE(NSITEB)/7.0D0)
9505          IF (NLINES.GT.0) THEN
9506             DO 21 I=1,NLINES
9507                ISTART = 7*I-6
9508                READ(LDAT,'(7E11.4)')
9509      &            (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9510    21       CONTINUE
9511          ENDIF
9512          ISTART = 7*NLINES+1
9513          IF (ISTART.LE.NSITEB) THEN
9514             READ(LDAT,'(7E11.4)')
9515      &         (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9516          ENDIF
9517          LFIRST = .FALSE.
9518          GOTO 100
9519 * variable projectile/target/energy runs:
9520 * read pre-initialized profile-functions from file
9521       ELSEIF (IOGLB.EQ.100) THEN
9522          CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0)
9523          GOTO 100
9524       ENDIF
9525
9526 * cross sections averaged over NSTATB nucleon configurations
9527       DO 11 IS=1,NSTATB
9528 C        IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS
9529          STOTN = ZERO
9530          SELAN = ZERO
9531          SQEPN = ZERO
9532          SQETN = ZERO
9533          SQE2N = ZERO
9534          SPRON = ZERO
9535          SDELN = ZERO
9536          SDQEN = ZERO
9537
9538          IF (NIDX.LE.-1) THEN
9539             CALL DT_CONUCL(COOP1,NA,RASH(1),0)
9540             CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1)
9541             IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9542                CALL DT_CONUCL(COOP2,NA,RASH(1),0)
9543                CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1)
9544             ENDIF
9545          ELSE
9546             CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0)
9547             CALL DT_CONUCL(COOT1,NB,RBSH(1),1)
9548             IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9549                CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0)
9550                CALL DT_CONUCL(COOT2,NB,RBSH(1),1)
9551             ENDIF
9552          ENDIF
9553
9554 *  integration over impact parameter B
9555          DO 12 IB=1,NSITEB-1
9556             STOTB = ZERO
9557             SELAB = ZERO
9558             SQEPB = ZERO
9559             SQETB = ZERO
9560             SQE2B = ZERO
9561             SPROB = ZERO
9562             SDIR  = ZERO
9563             SDELB = ZERO
9564             SDQEB = ZERO
9565             B     = DBLE(IB)*BSTEP(NTARG)
9566             FACB  = 10.0D0*TWOPI*B*BSTEP(NTARG)
9567
9568 *   integration over M_V^2 for photon-proj.
9569             DO 14 IM=1,JPOINT
9570                PP11(1) = CONE
9571                PP12(1) = CONE
9572                PP21(1) = CONE
9573                PP22(1) = CONE
9574                IF (IJPROJ.EQ.7) THEN
9575                   DO 13 K=2,NB
9576                      PP11(K) = CONE
9577                      PP12(K) = CONE
9578                      PP21(K) = CONE
9579                      PP22(K) = CONE
9580    13             CONTINUE
9581                ENDIF
9582                SHI  = ZERO
9583                FACM = ONE
9584                DCOH = 1.0D10
9585
9586                IF (IJPROJ.EQ.7) THEN
9587                   AMV2 = EXP(ABSZX(IM))-Q2
9588                   AMV  = SQRT(AMV2)
9589                   IF (AMV2.LT.16.0D0) THEN
9590                      R = TWO
9591                   ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN
9592                      R = 10.0D0/3.0D0
9593                   ELSE
9594                      R = 11.0D0/3.0D0
9595                   ENDIF
9596 *    define M_V dependent properties of nucleon scattering amplitude
9597 *     V_M-nucleon xsection
9598                   SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0
9599                   SIGMV  = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2)
9600 *     slope-parametrisation a la Kaidalov
9601                   BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
9602      &                           +0.25D0*LOG(S/(AMV2+Q2)))
9603 *    coherence length
9604                   IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM
9605 *    integration weight factor
9606                   FACM = ALPHEM/(3.0D0*PI*(ONE-X))*
9607      &                  R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM)
9608                ENDIF
9609                GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
9610                GAM = GSH
9611                IF (IJPROJ.EQ.7) THEN
9612                   RCA = GAM*SIGMV/TWOPI
9613                ELSE
9614                   RCA = GAM*SIGSH/TWOPI
9615                ENDIF
9616                FCA = -ROSH*RCA
9617                CA  = DCMPLX(RCA,FCA)
9618                CI  = CONE
9619
9620                DO 15 INA=1,NA
9621                   KK1  = 1
9622                   INT1 = 1
9623                   KK2  = 1
9624                   INT2 = 1
9625                   DO 16 INB=1,NB
9626 *    photon-projectile: check for supression by coherence length
9627                      IF (IJPROJ.EQ.7) THEN
9628                         IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN
9629                            KK1  = INB
9630                            INT1 = INT1+1
9631                         ENDIF
9632                         IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN
9633                            KK2  = INB
9634                            INT2 = INT2+1
9635                         ENDIF
9636                      ENDIF
9637
9638                      X11 = B+COOT1(1,INB)-COOP1(1,INA)
9639                      Y11 =   COOT1(2,INB)-COOP1(2,INA)
9640                      XY11 = GAM*(X11*X11+Y11*Y11)
9641                      IF (XY11.LE.15.0D0) THEN
9642                         C = CONE-CA*EXP(-XY11)
9643                         AR = DBLE(PP11(INT1))
9644                         AI = DIMAG(PP11(INT1))
9645                         IF (ABS(AR).LT.TINY25) AR = ZERO
9646                         IF (ABS(AI).LT.TINY25) AI = ZERO
9647                         PP11(INT1) = DCMPLX(AR,AI)
9648                         PP11(INT1) = PP11(INT1)*C
9649                         AR  = DBLE(C)
9650                         AI  = DIMAG(C)
9651                         SHI = SHI+LOG(AR*AR+AI*AI)
9652                      ENDIF
9653                      IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9654                         X12 = B+COOT2(1,INB)-COOP1(1,INA)
9655                         Y12 =   COOT2(2,INB)-COOP1(2,INA)
9656                         XY12 = GAM*(X12*X12+Y12*Y12)
9657                         IF (XY12.LE.15.0D0) THEN
9658                            C = CONE-CA*EXP(-XY12)
9659                            AR = DBLE(PP12(INT2))
9660                            AI = DIMAG(PP12(INT2))
9661                            IF (ABS(AR).LT.TINY25) AR = ZERO
9662                            IF (ABS(AI).LT.TINY25) AI = ZERO
9663                            PP12(INT2) = DCMPLX(AR,AI)
9664                            PP12(INT2) = PP12(INT2)*C
9665                         ENDIF
9666                         X21 = B+COOT1(1,INB)-COOP2(1,INA)
9667                         Y21 =   COOT1(2,INB)-COOP2(2,INA)
9668                         XY21 = GAM*(X21*X21+Y21*Y21)
9669                         IF (XY21.LE.15.0D0) THEN
9670                            C = CONE-CA*EXP(-XY21)
9671                            AR = DBLE(PP21(INT1))
9672                            AI = DIMAG(PP21(INT1))
9673                            IF (ABS(AR).LT.TINY25) AR = ZERO
9674                            IF (ABS(AI).LT.TINY25) AI = ZERO
9675                            PP21(INT1) = DCMPLX(AR,AI)
9676                            PP21(INT1) = PP21(INT1)*C
9677                         ENDIF
9678                         X22 = B+COOT2(1,INB)-COOP2(1,INA)
9679                         Y22 =   COOT2(2,INB)-COOP2(2,INA)
9680                         XY22 = GAM*(X22*X22+Y22*Y22)
9681                         IF (XY22.LE.15.0D0) THEN
9682                            C = CONE-CA*EXP(-XY22)
9683                            AR = DBLE(PP22(INT2))
9684                            AI = DIMAG(PP22(INT2))
9685                            IF (ABS(AR).LT.TINY25) AR = ZERO
9686                            IF (ABS(AI).LT.TINY25) AI = ZERO
9687                            PP22(INT2) = DCMPLX(AR,AI)
9688                            PP22(INT2) = PP22(INT2)*C
9689                         ENDIF
9690                      ENDIF
9691    16             CONTINUE
9692    15          CONTINUE
9693
9694                OMPP11 = CZERO
9695                OMPP21 = CZERO
9696                DIPP11 = CZERO
9697                DIPP21 = CZERO
9698                DO 17 K=1,INT1
9699                   IF (PP11(K).EQ.CZERO) THEN
9700                      PPTMP1 = CZERO
9701                      PPTMP2 = CZERO
9702                   ELSE
9703                      PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM)
9704                      PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM)
9705                   ENDIF
9706                   AVDIPP = 0.5D0*
9707      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9708                   OMPP11 = OMPP11+AVDIPP
9709 C                 OMPP11 = OMPP11+(CONE-PP11(K))
9710                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9711                   DIPP11 = DIPP11+AVDIPP
9712                   IF (PP21(K).EQ.CZERO) THEN
9713                      PPTMP1 = CZERO
9714                      PPTMP2 = CZERO
9715                   ELSE
9716                      PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM)
9717                      PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM)
9718                   ENDIF
9719                   AVDIPP = 0.5D0*
9720      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9721                   OMPP21 = OMPP21+AVDIPP
9722 C                 OMPP21 = OMPP21+(CONE-PP21(K))
9723                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9724                   DIPP21 = DIPP21+AVDIPP
9725    17          CONTINUE
9726                OMPP12 = CZERO
9727                OMPP22 = CZERO
9728                DIPP12 = CZERO
9729                DIPP22 = CZERO
9730                DO 18 K=1,INT2
9731                   IF (PP12(K).EQ.CZERO) THEN
9732                      PPTMP1 = CZERO
9733                      PPTMP2 = CZERO
9734                   ELSE
9735                      PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM)
9736                      PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM)
9737                   ENDIF
9738                   AVDIPP = 0.5D0*
9739      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9740                   OMPP12 = OMPP12+AVDIPP
9741 C                 OMPP12 = OMPP12+(CONE-PP12(K))
9742                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9743                   DIPP12 = DIPP12+AVDIPP
9744                   IF (PP22(K).EQ.CZERO) THEN
9745                      PPTMP1 = CZERO
9746                      PPTMP2 = CZERO
9747                   ELSE
9748                      PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM)
9749                      PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM)
9750                   ENDIF
9751                   AVDIPP = 0.5D0*
9752      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9753                   OMPP22 = OMPP22+AVDIPP
9754 C                 OMPP22 = OMPP22+(CONE-PP22(K))
9755                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9756                   DIPP22 = DIPP22+AVDIPP
9757    18          CONTINUE
9758
9759                SPROM = ONE-EXP(SHI)
9760                SPROB = SPROB+FACM*SPROM
9761                IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9762                   STOTM = DBLE(OMPP11+OMPP22)
9763                   SELAM = DBLE(OMPP11*DCONJG(OMPP22))
9764                   SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM
9765                   SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM
9766                   SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM
9767                   SDELM = DBLE(DIPP11*DCONJG(DIPP22))
9768                   SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM
9769                   STOTB = STOTB+FACM*STOTM
9770                   SELAB = SELAB+FACM*SELAM
9771                   SDELB = SDELB+FACM*SDELM
9772                   IF (NB.GT.1) THEN
9773                      SQEPB = SQEPB+FACM*SQEPM
9774                      SDQEB = SDQEB+FACM*SDQEM
9775                   ENDIF
9776                   IF (NA.GT.1) SQETB = SQETB+FACM*SQETM
9777                   IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M
9778                   IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD
9779                ENDIF
9780
9781    14       CONTINUE
9782
9783             STOTN = STOTN+FACB*STOTB
9784             SELAN = SELAN+FACB*SELAB
9785             SQEPN = SQEPN+FACB*SQEPB
9786             SQETN = SQETN+FACB*SQETB
9787             SQE2N = SQE2N+FACB*SQE2B
9788             SPRON = SPRON+FACB*SPROB
9789             SDELN = SDELN+FACB*SDELB
9790             SDQEN = SDQEN+FACB*SDQEB
9791
9792             IF (IJPROJ.EQ.7) THEN
9793                BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB)
9794             ELSE
9795                IF (DIBETA.GT.ZERO) THEN
9796                   BPROD(IB+1)= BPROD(IB+1)
9797      &                        +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B)
9798                ELSE
9799                   BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB
9800                ENDIF
9801             ENDIF
9802
9803    12    CONTINUE
9804
9805          STOT  = STOT +FACN*STOTN
9806          STOT2 = STOT2+FACN*STOTN**2
9807          SELA  = SELA +FACN*SELAN
9808          SELA2 = SELA2+FACN*SELAN**2
9809          SQEP  = SQEP +FACN*SQEPN
9810          SQEP2 = SQEP2+FACN*SQEPN**2
9811          SQET  = SQET +FACN*SQETN
9812          SQET2 = SQET2+FACN*SQETN**2
9813          SQE2  = SQE2 +FACN*SQE2N
9814          SQE22 = SQE22+FACN*SQE2N**2
9815          SPRO  = SPRO +FACN*SPRON
9816          SPRO2 = SPRO2+FACN*SPRON**2
9817          SDEL  = SDEL +FACN*SDELN
9818          SDEL2 = SDEL2+FACN*SDELN**2
9819          SDQE  = SDQE +FACN*SDQEN
9820          SDQE2 = SDQE2+FACN*SDQEN**2
9821
9822    11 CONTINUE
9823
9824 * final cross sections
9825 * 1) total
9826       XSTOT(IE,IQ,NTARG) = STOT
9827       IF (IJPROJ.EQ.7)
9828      &   XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR
9829 * 2) elastic
9830       XSELA(IE,IQ,NTARG) = SELA
9831 * 3) quasi-el.: A+B-->A+X (excluding 2)
9832       XSQEP(IE,IQ,NTARG) = SQEP
9833 * 4) quasi-el.: A+B-->X+B (excluding 2)
9834       XSQET(IE,IQ,NTARG) = SQET
9835 * 5) quasi-el.: A+B-->X (excluding 2-4)
9836       XSQE2(IE,IQ,NTARG) = SQE2
9837 * 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
9838       IF (SDEL.GT.ZERO) THEN
9839          XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2
9840       ELSE
9841          XSPRO(IE,IQ,NTARG) = SPRO
9842       ENDIF
9843 * 7) projectile diffraction (el. scatt. off target)
9844       XSDEL(IE,IQ,NTARG) = SDEL
9845 * 8) projectile diffraction (quasi-el. scatt. off target)
9846       XSDQE(IE,IQ,NTARG) = SDQE
9847 *  stat. errors
9848       XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1))
9849       XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1))
9850       XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1))
9851       XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1))
9852       XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1))
9853       XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1))
9854       XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1))
9855       XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1))
9856
9857       IF (IJPROJ.EQ.7) THEN
9858          BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG)
9859      &          -XSQEP(IE,IQ,NTARG)
9860       ELSE
9861          BNORM = XSPRO(IE,IQ,NTARG)
9862       ENDIF
9863       DO 19 I=2,NSITEB
9864          BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1)
9865          IF ((IE.EQ.1).AND.(IQ.EQ.1))
9866      &      BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1)
9867    19 CONTINUE
9868
9869 * write profile function data into file
9870       IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN
9871          WRITE(LDAT,'(5I10,1P,E15.5)')
9872      &      IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE)
9873          WRITE(LDAT,'(1P,6E12.5)')
9874      &      XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG),
9875      &      XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9876          WRITE(LDAT,'(1P,6E12.5)')
9877      &      XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG),
9878      &      XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9879          NLINES = INT(DBLE(NSITEB)/7.0D0)
9880          IF (NLINES.GT.0) THEN
9881             DO 20 I=1,NLINES
9882                ISTART = 7*I-6
9883                WRITE(LDAT,'(1P,7E11.4)')
9884      &            (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9885    20       CONTINUE
9886          ENDIF
9887          ISTART = 7*NLINES+1
9888          IF (ISTART.LE.NSITEB) THEN
9889             WRITE(LDAT,'(1P,7E11.4)')
9890      &         (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9891          ENDIF
9892       ENDIF
9893
9894   100 CONTINUE
9895
9896 C     IF (ABS(IOGLB).EQ.1) CLOSE(LDAT)
9897
9898       RETURN
9899       END
9900
9901 *$ CREATE DT_GETBXS.FOR
9902 *COPY DT_GETBXS
9903 *
9904 *===getbxs=============================================================*
9905 *
9906       SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX)
9907
9908 ************************************************************************
9909 * Biasing in impact parameter space.                                   *
9910 *     XSFRAC = 0 :  BLO    - minimum impact parameter  (input)         *
9911 *                   BHI    - maximum impact parameter  (input)         *
9912 *                   XSFRAC - fraction of cross section corresponding   *
9913 *                            to impact parameter range (BLO,BHI)       *
9914 *                                                      (output)        *
9915 *     XSFRAC > 0 :  XSFRAC - fraction of cross section (input)         *
9916 *                   BHI    - maximum impact parameter giving requested *
9917 *                            fraction of cross section in impact       *
9918 *                            parameter range (0,BMAX)  (output)        *
9919 * This version dated 17.03.00  is written by S. Roesler                *
9920 ************************************************************************
9921
9922       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9923       SAVE
9924       PARAMETER ( LINP = 10 ,
9925      &            LOUT = 6 ,
9926      &            LDAT = 9 )
9927
9928       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9929 * Glauber formalism: parameters
9930       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9931      &                BMAX(NCOMPX),BSTEP(NCOMPX),
9932      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9933      &                NSITEB,NSTATB
9934
9935       NTARG = ABS(NIDX)
9936       IF (XSFRAC.LE.0.0D0) THEN
9937          ILO    = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG)))
9938          IHI    = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG)))
9939          IF (ILO.GE.IHI) THEN
9940             XSFRAC = 0.0D0
9941             RETURN
9942          ENDIF
9943          IF (ILO.EQ.NSITEB-1) THEN
9944             FRCLO = BSITE(0,1,NTARG,NSITEB)
9945          ELSE
9946             FRCLO = BSITE(0,1,NTARG,ILO+1)
9947      &              +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG)
9948      &              *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1))
9949          ENDIF
9950          IF (IHI.EQ.NSITEB-1) THEN
9951             FRCHI = BSITE(0,1,NTARG,NSITEB)
9952          ELSE
9953             FRCHI = BSITE(0,1,NTARG,IHI+1)
9954      &              +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG)
9955      &              *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1))
9956          ENDIF
9957          XSFRAC = FRCHI-FRCLO
9958       ELSE
9959          BLO = 0.0D0
9960          BHI = BMAX(NTARG)
9961          DO 1 I=1,NSITEB-1
9962             IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN
9963                FAC = (XSFRAC              -BSITE(0,1,NTARG,I))/
9964      &               (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I))
9965                BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC
9966                GOTO 2
9967             ENDIF
9968     1    CONTINUE
9969     2    CONTINUE
9970       ENDIF
9971
9972       RETURN
9973       END
9974
9975 *$ CREATE DT_CONUCL.FOR
9976 *COPY DT_CONUCL
9977 *
9978 *===conucl=============================================================*
9979 *
9980       SUBROUTINE DT_CONUCL(X,N,R,MODE)
9981
9982 ************************************************************************
9983 * Calculation of coordinates of nucleons within nuclei.                *
9984 *        X(3,N)   spatial coordinates of nucleons (in fm)  (output)    *
9985 *        N / R    number of nucleons / radius of nucleus   (input)     *
9986 *        MODE = 0 coordinates not sorted                               *
9987 *             = 1 coordinates sorted with increasing X(3,i)            *
9988 *             = 2 coordinates sorted with decreasing X(3,i)            *
9989 * This version dated 26.10.95 is revised by S. Roesler                 *
9990 ************************************************************************
9991
9992       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9993       SAVE
9994       PARAMETER ( LINP = 10 ,
9995      &            LOUT = 6 ,
9996      &            LDAT = 9 )
9997
9998       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9999      &           ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10000
10001       PARAMETER (TWOPI = 6.283185307179586454D+00 )
10002
10003       PARAMETER (NSRT=10)
10004       DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10005       DIMENSION X(3,N),XTMP(3,260)
10006
10007       CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R)
10008
10009       IF ((MODE.NE.0).AND.(N.GT.4)) THEN
10010          K = 0
10011          DO 1 I=1,NSRT
10012             IF (MODE.EQ.2) THEN
10013                ISRT = NSRT+1-I
10014             ELSE
10015                ISRT = I
10016             ENDIF
10017             K1 = K
10018             DO 2 J=1,ICSRT(ISRT)
10019                K = K+1
10020                X(1,K) = XTMP(1,IDXSRT(ISRT,J))
10021                X(2,K) = XTMP(2,IDXSRT(ISRT,J))
10022                X(3,K) = XTMP(3,IDXSRT(ISRT,J))
10023     2       CONTINUE
10024             IF (ICSRT(ISRT).GT.1) THEN
10025                I0 = K1+1
10026                I1 = K
10027                CALL DT_SORT(X,N,I0,I1,MODE)
10028             ENDIF
10029     1    CONTINUE
10030       ELSEIF ((MODE.NE.0).AND.(N.GE.2).AND.(N.LE.4)) THEN
10031          DO 3 I=1,N
10032             X(1,I) = XTMP(1,I)
10033             X(2,I) = XTMP(2,I)
10034             X(3,I) = XTMP(3,I)
10035     3    CONTINUE
10036          CALL DT_SORT(X,N,1,N,MODE)
10037       ELSE
10038          DO 4 I=1,N
10039             X(1,I) = XTMP(1,I)
10040             X(2,I) = XTMP(2,I)
10041             X(3,I) = XTMP(3,I)
10042     4    CONTINUE
10043       ENDIF
10044
10045       RETURN
10046       END
10047
10048 *$ CREATE DT_COORDI.FOR
10049 *COPY DT_COORDI
10050 *
10051 *===coordi=============================================================*
10052 *
10053       SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R)
10054
10055 ************************************************************************
10056 * Calculation of coordinates of nucleons within nuclei.                *
10057 *        X(3,N)   spatial coordinates of nucleons (in fm)  (output)    *
10058 *        N / R    number of nucleons / radius of nucleus   (input)     *
10059 * Based on the original version by Shmakov et al.                      *
10060 * This version dated 26.10.95 is revised by S. Roesler                 *
10061 ************************************************************************
10062
10063       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10064       SAVE
10065       PARAMETER ( LINP = 10 ,
10066      &            LOUT = 6 ,
10067      &            LDAT = 9 )
10068
10069       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10070      &           ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10071
10072       PARAMETER (TWOPI = 6.283185307179586454D+00 )
10073
10074       LOGICAL LSTART
10075
10076       PARAMETER (NSRT=10)
10077       DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10078       DIMENSION X(3,260),WD(4),RD(3)
10079
10080       DATA PDIF/0.545D0/,R2MIN/0.16D0/
10081       DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/
10082       DATA RD /2.09D0, 0.935D0, 0.697D0/
10083
10084       X1SUM = ZERO
10085       X2SUM = ZERO
10086       X3SUM = ZERO
10087
10088       IF (N.EQ.1) THEN
10089          X(1,1) = ZERO
10090          X(2,1) = ZERO
10091          X(3,1) = ZERO
10092       ELSEIF (N.EQ.2) THEN
10093          EPS = DT_RNDM(RD(1))
10094          DO 30 I=1,3
10095             IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40
10096    30    CONTINUE
10097    40    CONTINUE
10098          DO 50 J=1,3
10099             CALL DT_RANNOR(X1,X2)
10100             X(J,1) = RD(I)*X1
10101             X(J,2) = -X(J,1)
10102    50    CONTINUE
10103       ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN
10104          SIGMA = R/SQRTWO
10105          LSTART = .TRUE.
10106          CALL DT_RANNOR(X3,X4)
10107          DO 100 I=1,N
10108             CALL DT_RANNOR(X1,X2)
10109             X(1,I) = SIGMA*X1
10110             X(2,I) = SIGMA*X2
10111             IF (LSTART) GOTO 80
10112             X(3,I) = SIGMA*X4
10113             CALL DT_RANNOR(X3,X4)
10114             GOTO 90
10115    80       CONTINUE
10116             X(3,I) = SIGMA*X3
10117    90       CONTINUE
10118             LSTART = .NOT.LSTART
10119             X1SUM = X1SUM+X(1,I)
10120             X2SUM = X2SUM+X(2,I)
10121             X3SUM = X3SUM+X(3,I)
10122   100    CONTINUE
10123          X1SUM = X1SUM/DBLE(N)
10124          X2SUM = X2SUM/DBLE(N)
10125          X3SUM = X3SUM/DBLE(N)
10126          DO 101 I=1,N
10127             X(1,I) = X(1,I)-X1SUM
10128             X(2,I) = X(2,I)-X2SUM
10129             X(3,I) = X(3,I)-X3SUM
10130   101    CONTINUE
10131       ELSE
10132
10133 * maximum nuclear radius for coordinate sampling
10134          RMAX = R+4.605D0*PDIF
10135
10136 * initialize pre-sorting
10137          DO 121 I=1,NSRT
10138             ICSRT(I) = 0
10139   121    CONTINUE
10140          DR = TWO*RMAX/DBLE(NSRT)
10141
10142 * sample coordinates for N nucleons
10143          DO 140 I=1,N
10144   120       CONTINUE
10145             RAD = RMAX*(DT_RNDM(DR))**ONETHI
10146             F   = DT_DENSIT(N,RAD,R)
10147             IF (DT_RNDM(RAD).GT.F) GOTO 120
10148 *   theta, phi uniformly distributed
10149             CT  = ONE-TWO*DT_RNDM(F)
10150             ST  = SQRT((ONE-CT)*(ONE+CT))
10151             CALL DT_DSFECF(SFE,CFE)
10152             X(1,I) = RAD*ST*CFE
10153             X(2,I) = RAD*ST*SFE
10154             X(3,I) = RAD*CT
10155 *   ensure that distance between two nucleons is greater than R2MIN
10156             IF (I.LT.2) GOTO 122
10157             I1 = I-1
10158             DO 130 I2=1,I1
10159                DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+
10160      &                 (X(3,I)-X(3,I2))**2
10161                IF (DIST2.LE.R2MIN) GOTO 120
10162   130       CONTINUE
10163   122       CONTINUE
10164 *   save index according to z-bin
10165             IDXZ        = INT( (X(3,I)+RMAX)/DR )+1
10166             ICSRT(IDXZ) = ICSRT(IDXZ)+1
10167             IDXSRT(IDXZ,ICSRT(IDXZ)) = I
10168             X1SUM = X1SUM+X(1,I)
10169             X2SUM = X2SUM+X(2,I)
10170             X3SUM = X3SUM+X(3,I)
10171   140    CONTINUE
10172          X1SUM = X1SUM/DBLE(N)
10173          X2SUM = X2SUM/DBLE(N)
10174          X3SUM = X3SUM/DBLE(N)
10175          DO 141 I=1,N
10176             X(1,I) = X(1,I)-X1SUM
10177             X(2,I) = X(2,I)-X2SUM
10178             X(3,I) = X(3,I)-X3SUM
10179   141    CONTINUE
10180
10181       ENDIF
10182
10183       RETURN
10184       END
10185
10186 *$ CREATE DT_DENSIT.FOR
10187 *COPY DT_DENSIT
10188 *
10189 *===densit=============================================================*
10190 *
10191       DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA)
10192
10193       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10194       SAVE
10195
10196       PARAMETER ( LINP = 10 ,
10197      &            LOUT = 6 ,
10198      &            LDAT = 9 )
10199       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10200       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
10201      &           PI    = TWOPI/TWO)
10202
10203       DIMENSION R0(18),FNORM(18)
10204       DATA R0 /  ZERO,   ZERO,   ZERO,   ZERO, 2.12D0,
10205      &         2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0,
10206      &         2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0,
10207      &         2.72D0, 2.66D0, 2.79D0/
10208       DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10209      &            .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10210      &            .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01,
10211      &            .1214D+01,.1265D+01,.1318D+01/
10212       DATA PDIF /0.545D0/
10213
10214       DT_DENSIT = ZERO
10215 * shell model
10216       IF (NA.LE.4) THEN
10217          STOP 'DT_DENSIT-0'
10218       ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN
10219          R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA))
10220          DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2)
10221      &            *EXP(-(R/R1)**2)/FNORM(NA)
10222 * Woods-Saxon
10223       ELSEIF (NA.GT.18) THEN
10224          DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF))
10225       ENDIF
10226
10227       RETURN
10228       END
10229
10230 *$ CREATE DT_RNCLUS.FOR
10231 *COPY DT_RNCLUS
10232 *
10233 *===rnclus=============================================================*
10234 *
10235       DOUBLE PRECISION FUNCTION DT_RNCLUS(N)
10236
10237 ************************************************************************
10238 * Nuclear radius for nucleus with mass number N.                       *
10239 * This version dated 26.9.00  is written by S. Roesler                 *
10240 ************************************************************************
10241
10242       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10243       SAVE
10244
10245       PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)
10246
10247 * nucleon radius
10248       PARAMETER (RNUCLE = 1.12D0)
10249
10250 * nuclear radii for selected nuclei
10251       DIMENSION RADNUC(18)
10252       DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0,
10253      &               2.58D0,2.71D0,2.66D0,2.71D0/
10254
10255       IF (N.LE.18) THEN
10256          IF (RADNUC(N).GT.0.0D0) THEN
10257             DT_RNCLUS = RADNUC(N)
10258          ELSE
10259             DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10260          ENDIF
10261       ELSE
10262          DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10263       ENDIF
10264
10265       RETURN
10266       END
10267
10268 *$ CREATE DT_DENTST.FOR
10269 *COPY DT_DENTST
10270 *
10271 *===dentst=============================================================*
10272 *
10273 C      PROGRAM DT_DENTST
10274       SUBROUTINE DT_DENTST
10275
10276       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10277       SAVE
10278
10279       OPEN(40,FILE='dentst.out',STATUS='UNKNOWN')
10280       OPEN(41,FILE='denmax.out',STATUS='UNKNOWN')
10281
10282       RMIN  = 0.0D0
10283       RMAX  = 8.0D0
10284       NBINS = 500.0D0
10285       DR    = (RMAX-RMIN)/DBLE(NBINS)
10286       DO 1 IA=5,18
10287          FMAX = 0.0D0
10288          DO 2 IR=1,NBINS+1
10289             R = RMIN+DBLE(IR-1)*DR
10290             F = DT_DENSIT(IA,R,R)
10291             IF (F.GT.FMAX) FMAX = F
10292             WRITE(40,'(1X,I3,2E15.5)') IA,R,F
10293     2    CONTINUE
10294          WRITE(41,'(1X,I3,E15.5)') IA,FMAX
10295     1 CONTINUE
10296
10297       CLOSE(40)
10298       CLOSE(41)
10299
10300       END
10301
10302 *$ CREATE DT_SHMAKI.FOR
10303 *COPY DT_SHMAKI
10304 *
10305 *===shmaki=============================================================*
10306 *
10307       SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE)
10308
10309 ************************************************************************
10310 * Initialisation of Glauber formalism. This subroutine has to be       *
10311 * called once (in case of target emulsions as often as many different  *
10312 * target nuclei are considered) before events are sampled.             *
10313 *         NA / NCA   mass number/charge of projectile nucleus          *
10314 *         NB / NCB   mass number/charge of target     nucleus          *
10315 *         IJP        identity of projectile (hadrons/leptons/photons)  *
10316 *         PPN        projectile momentum (for projectile nuclei:       *
10317 *                    momentum per nucleon) in target rest system       *
10318 *         MODE = 0   Glauber formalism invoked                         *
10319 *              = 1   fitted results are loaded from data-file          *
10320 *              = 99  NTARG is forced to be 1                           *
10321 *                    (used in connection with GLAUBERI-card only)      *
10322 * This version dated 22.03.96 is based on the original SHMAKI-routine  *
10323 * and revised by S. Roesler.                                           *
10324 ************************************************************************
10325
10326       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10327       SAVE
10328       PARAMETER ( LINP = 10 ,
10329      &            LOUT = 6 ,
10330      &            LDAT = 9 )
10331       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
10332      &           THREE=3.0D0)
10333
10334       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10335 * Glauber formalism: parameters
10336       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10337      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10338      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10339      &                NSITEB,NSTATB
10340 * Lorentz-parameters of the current interaction
10341       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10342      &                UMO,PPCM,EPROJ,PPROJ
10343 * properties of photon/lepton projectiles
10344       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10345 * kinematical cuts for lepton-nucleus interactions
10346       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
10347      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
10348 * Glauber formalism: cross sections
10349       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10350      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10351      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10352      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10353      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10354      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10355      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10356      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10357      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10358      &                BSLOPE,NEBINI,NQBINI
10359 * cuts for variable energy runs
10360       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
10361 * nucleon-nucleon event-generator
10362       CHARACTER*8 CMODEL
10363       LOGICAL LPHOIN
10364       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10365 * Glauber formalism: flags and parameters for statistics
10366       LOGICAL LPROD
10367       CHARACTER*8 CGLB
10368       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10369
10370       DATA NTARG,ICOUT,IVEOUT /0,0,0/
10371
10372 C     CALL DT_HISHAD
10373 C     STOP
10374
10375       NTARG = NTARG+1
10376       IF (MODE.EQ.99) NTARG = 1
10377       NIDX = -NTARG
10378       IF (MODE.EQ.-1) NIDX = NTARG
10379
10380       IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1
10381       IF (ICOUT.EQ.1) WRITE(LOUT,1000)
10382  1000    FORMAT(//,1X,'SHMAKI:    Glauber formalism (Shmakov et. al) -',
10383      &          ' initialization',/,12X,'--------------------------',
10384      &          '-------------------------',/)
10385
10386       IF (MODE.EQ.2) THEN
10387          CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10388          CALL DT_SHFAST(MODE,PPN,IBACK)
10389          STOP ' Glauber pre-initialization done'
10390       ENDIF
10391       IF (MODE.EQ.1) THEN
10392          CALL DT_PROFBI(NA,NB,PPN,NTARG)
10393       ELSE
10394          IBACK = 1
10395          IF (MODE.EQ.3)  CALL DT_SHFAST(MODE,PPN,IBACK)
10396          IF (IBACK.EQ.1) THEN
10397 * lepton-nucleus (variable energy runs)
10398             IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR.
10399      &          (IJP.EQ.10).OR.(IJP.EQ.11))   THEN
10400                IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10401      &            WRITE(LOUT,1002) NB,NCB
10402  1002          FORMAT(1X,'variable energy run:     projectile-id:  7',
10403      &                '    target A/Z: ',I3,' /',I3,/,/,8X,
10404      &                'E_cm (GeV)    Q^2 (GeV^2)',
10405      &                '    Sigma_tot (mb)     Sigma_in (mb)',/,7X,
10406      &                '--------------------------------',
10407      &                '------------------------------')
10408                AECMLO = LOG10(MIN(UMO,ECMLI))
10409                AECMHI = LOG10(MIN(UMO,ECMHI))
10410                IESTEP = NEB-1
10411                DAECM  = (AECMHI-AECMLO)/DBLE(IESTEP)
10412                IF (AECMLO.EQ.AECMHI) IESTEP = 0
10413                DO 1 I=1,IESTEP+1
10414                   ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10415                   IF (Q2HI.GT.0.1D0) THEN
10416                      IF (Q2LI.LT.0.01D0) THEN
10417                         CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10418                         IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10419      &                     WRITE(LOUT,1003)
10420      &                  ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10421                         Q2LI = 0.01D0
10422                         IBIN = 2
10423                      ELSE
10424                         IBIN = 1
10425                      ENDIF
10426                      IQSTEP = NQB-IBIN
10427                      AQ2LO  = LOG10(Q2LI)
10428                      AQ2HI  = LOG10(Q2HI)
10429                      DAQ2   = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE)
10430                      DO 2 J=IBIN,IQSTEP+IBIN
10431                         Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2)
10432                         CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX)
10433                         IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10434      &                     WRITE(LOUT,1003) ECMNN(I),
10435      &                     Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG)
10436     2                CONTINUE
10437                   ELSE
10438                      CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10439                      IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10440      &                  WRITE(LOUT,1003)
10441      &                  ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10442                   ENDIF
10443  1003             FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3)
10444     1          CONTINUE
10445                IVEOUT = 1
10446             ELSE
10447 * hadron/photon/nucleus-nucleus
10448                IF ((ABS(VAREHI).GT.ZERO).AND.
10449      &             (ABS(VAREHI).GT.ABS(VARELO))) THEN
10450                   IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN
10451                      WRITE(LOUT,1004) NA,NB,NCB
10452  1004                FORMAT(1X,'variable energy run:    projectile-id:',
10453      &                      I3,'    target A/Z: ',I3,' /',I3,/)
10454                      WRITE(LOUT,1005)
10455  1005                FORMAT('  E_cm (GeV)  E_Lab (GeV)  sig_tot^pp (mb)'
10456      &                      ,'  Sigma_tot (mb)  Sigma_prod (mb)',/,
10457      &                      ' -------------------------------------',
10458      &                      '--------------------------------------')
10459                   ENDIF
10460                   AECMLO = LOG10(VARCLO)
10461                   AECMHI = LOG10(VARCHI)
10462                   IESTEP = NEB-1
10463                   DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10464                   IF (AECMLO.EQ.AECMHI) IESTEP = 0
10465                   DO 3 I=1,IESTEP+1
10466                      ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10467                      AMP = 0.938D0
10468                      AMT = 0.938D0
10469                      AMP2 = AMP**2
10470                      AMT2 = AMT**2
10471                      ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT)
10472                      PLAB = SQRT((ELAB+AMP)*(ELAB-AMP))
10473                      CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX)
10474                      IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10475      &                 WRITE(LOUT,1006)
10476      &                 ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10477  1006             FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3)
10478     3             CONTINUE
10479                   IVEOUT = 1
10480                ELSE
10481                   CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10482                ENDIF
10483             ENDIF
10484          ENDIF
10485       ENDIF
10486
10487       IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND.
10488      &    (IOGLB.NE.100)) THEN
10489          WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH,
10490      &                    BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG)
10491  1001    FORMAT(38X,'projectile',
10492      &          '      target',/,1X,'Mass number / charge',
10493      &          17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X,
10494      &          'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X,
10495      &          'Parameters of elastic scattering amplitude:',/,5X,
10496      &          'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ',
10497      &          F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X,
10498      &          'statistics at each b-step',4X,I5,/,/,1X,
10499      &          'Prod. cross section  ',5X,F10.4,' mb',/)
10500       ENDIF
10501
10502       RETURN
10503       END
10504
10505 *$ CREATE DT_PROFBI.FOR
10506 *COPY DT_PROFBI
10507 *
10508 *===profbi=============================================================*
10509 *
10510       SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG)
10511
10512 ************************************************************************
10513 * Integral over profile function (to be used for impact-parameter      *
10514 * sampling during event generation).                                   *
10515 * Fitted results are used.                                             *
10516 *         NA / NB    mass numbers of proj./target nuclei               *
10517 *         PPN        projectile momentum (for projectile nuclei:       *
10518 *                    momentum per nucleon) in target rest system       *
10519 *         NTARG      index of target material (i.e. kind of nucleus)   *
10520 * This version dated 31.05.95 is revised by S. Roesler                 *
10521 ************************************************************************
10522
10523       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10524       SAVE
10525       PARAMETER ( LINP = 10 ,
10526      &            LOUT = 6 ,
10527      &            LDAT = 9 )
10528 CPH      SAVE
10529
10530       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
10531
10532       LOGICAL LSTART
10533       CHARACTER CNAME*80
10534
10535       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10536 * Glauber formalism: parameters
10537       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10538      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10539      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10540      &                NSITEB,NSTATB
10541 * Glauber formalism: cross sections
10542       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10543      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10544      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10545      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10546      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10547      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10548      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10549      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10550      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10551      &                BSLOPE,NEBINI,NQBINI
10552
10553       PARAMETER (NGLMAX=8000)
10554       DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX),
10555      &          GLASIG(NGLMAX),GLAFIT(5,NGLMAX)
10556
10557       DATA LSTART /.TRUE./
10558
10559       IF (LSTART) THEN
10560 * read fit-parameters from file
10561          OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN')
10562          I = 0
10563     1    CONTINUE
10564          READ(47,'(A80)') CNAME
10565          IF (CNAME.EQ.'STOP') GOTO 2
10566          I = I+1
10567          READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I),
10568      &                 GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I),
10569      &                 GLAFIT(4,I),GLAFIT(5,I)
10570          IF (I+1.GT.NGLMAX) THEN
10571             WRITE(LOUT,1000)
10572  1000       FORMAT(1X,'PROFBI:    warning! array size exceeded - ',
10573      &             'program stopped')
10574             STOP
10575          ENDIF
10576          GOTO 1
10577     2    CONTINUE
10578          NGLPAR = I
10579          LSTART = .FALSE.
10580       ENDIF
10581
10582       NNA = NA
10583       NNB = NB
10584       IF (NA.GT.NB) THEN
10585          NNA = NB
10586          NNB = NA
10587       ENDIF
10588       IDXGLA = 0
10589       DO 3 J=1,NGLPAR
10590          IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN
10591             IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1)
10592             DO 4 K=1,J-1
10593                IPOINT = J-K
10594                IF (J.EQ.NGLPAR) IPOINT = J+1-K
10595                IF ((NNA.GT.NGLIP(IPOINT)).OR.
10596      &             (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN
10597                   IF (IPOINT.EQ.1) IPOINT = 0
10598                   NATMP = NGLIP(IPOINT+1)
10599                   IF (PPN.LT.GLAPPN(IPOINT+1)) THEN
10600                      IDXGLA = IPOINT+1
10601                      GOTO 6
10602                   ELSE
10603                      J1BEG = IPOINT+1
10604                      J1END = J
10605 C                    IF (J.EQ.NGLPAR) THEN
10606 C                       J1BEG = IPOINT
10607 C                       J1END = J
10608 C                    ENDIF
10609                      DO 5 J1=J1BEG,J1END
10610                         IF (NGLIP(J1).EQ.NATMP) THEN
10611                            IF (PPN.LT.GLAPPN(J1)) THEN
10612                               IDXGLA = J1
10613                               GOTO 6
10614                            ENDIF
10615                         ELSE
10616                            IDXGLA = J1-1
10617                            GOTO 6
10618                         ENDIF
10619     5                CONTINUE
10620                      IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR)))
10621      &                  IDXGLA = NGLPAR
10622                   ENDIF
10623                ENDIF
10624     4       CONTINUE
10625          ENDIF
10626     3 CONTINUE
10627
10628     6 CONTINUE
10629       IF (IDXGLA.EQ.0) THEN
10630          WRITE(LOUT,1001) NNA,NNB,PPN
10631  1001    FORMAT(1X,'PROFBI:   configuration (NA,NB,PPN = ',
10632      &          2I4,F6.0,') not found ')
10633          STOP
10634       ENDIF
10635
10636 * no interpolation yet available
10637       XSPRO(1,1,NTARG) = GLASIG(IDXGLA)
10638
10639       BSITE(1,1,NTARG,1) = ZERO
10640       DO 10 I=2,NSITEB
10641          XX = DBLE(I)
10642          POLY  = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+
10643      &           GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+
10644      &           GLAFIT(5,IDXGLA)*XX**4
10645          IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY)
10646          BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY))
10647          IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO
10648    10 CONTINUE
10649
10650       RETURN
10651       END
10652
10653 *$ CREATE DT_GLAUBE.FOR
10654 *COPY DT_GLAUBE
10655 *
10656 *===glaube=============================================================*
10657 *
10658       SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX)
10659
10660 ************************************************************************
10661 * Calculation of configuartion of interacting nucleons for one event.  *
10662 *    NB / NB    mass numbers of proj./target nuclei           (input)  *
10663 *    B          impact parameter                              (output) *
10664 *    INTT       total number of wounded nucleons                 "     *
10665 *    INTA / INTB number of wounded nucleons in proj. / target    "     *
10666 *    JS / JT(i) number of collisions proj. / target nucleon i is       *
10667 *                                                   involved  (output) *
10668 *    NIDX       index of projectile/target material            (input) *
10669 *               = -2 call within FLUKA transport calculation           *
10670 * This is an update of the original routine SHMAKO by J.Ranft/HJM      *
10671 * This version dated 22.03.96 is revised by S. Roesler                 *
10672 *                                                                      *
10673 * Last change 27.12.2006 by S. Roesler.                                *
10674 ************************************************************************
10675
10676       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10677       SAVE
10678       PARAMETER ( LINP = 10 ,
10679      &            LOUT = 6 ,
10680      &            LDAT = 9 )
10681       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
10682      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
10683
10684       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10685       PARAMETER ( MAXNCL = 260,
10686      &            MAXVQU = MAXNCL,
10687      &            MAXSQU = 20*MAXVQU,
10688      &            MAXINT = MAXVQU+MAXSQU)
10689 * Glauber formalism: parameters
10690       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10691      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10692      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10693      &                NSITEB,NSTATB
10694 * Glauber formalism: cross sections
10695       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10696      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10697      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10698      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10699      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10700      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10701      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10702      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10703      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10704      &                BSLOPE,NEBINI,NQBINI
10705 * Lorentz-parameters of the current interaction
10706       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10707      &                UMO,PPCM,EPROJ,PPROJ
10708 * properties of photon/lepton projectiles
10709       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10710 * Glauber formalism: collision properties
10711       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
10712      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
10713 * Glauber formalism: flags and parameters for statistics
10714       LOGICAL LPROD
10715       CHARACTER*8 CGLB
10716       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10717
10718       DIMENSION JS(MAXNCL),JT(MAXNCL)
10719
10720       NTARG = ABS(NIDX)
10721
10722 * get actual energy from /DTLTRA/
10723       ECMNOW = UMO
10724       Q2     = VIRT
10725 *
10726 * new patch for pre-initialized variable projectile/target/energy runs,
10727 * bypassed for use within FLUKA (Nidx=-2)
10728       IF (IOGLB.EQ.100) THEN
10729          IF (NIDX.NE.-2) CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1)
10730 *
10731 * variable energy run, interpolate profile function
10732       ELSE
10733          I1   = 1
10734          I2   = 1
10735          RATE = ONE
10736          IF (NEBINI.GT.1) THEN
10737             IF (ECMNOW.GE.ECMNN(NEBINI)) THEN
10738                I1   = NEBINI
10739                I2   = NEBINI
10740                RATE = ONE
10741             ELSEIF (ECMNOW.GT.ECMNN(1)) THEN
10742                DO 1 I=2,NEBINI
10743                   IF (ECMNOW.LT.ECMNN(I)) THEN
10744                      I1   = I-1
10745                      I2   = I
10746                      RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
10747                      GOTO 2
10748                   ENDIF
10749     1          CONTINUE
10750     2          CONTINUE
10751             ENDIF
10752          ENDIF
10753          J1   = 1
10754          J2   = 1
10755          RATQ = ONE
10756          IF (NQBINI.GT.1) THEN
10757             IF (Q2.GE.Q2G(NQBINI)) THEN
10758                J1   = NQBINI
10759                J2   = NQBINI
10760                RATQ = ONE
10761             ELSEIF (Q2.GT.Q2G(1)) THEN
10762                DO 3 I=2,NQBINI
10763                   IF (Q2.LT.Q2G(I)) THEN
10764                      J1   = I-1
10765                      J2   = I
10766                      RATQ = LOG10(     Q2/MAX(Q2G(J1),TINY14))/
10767      &                      LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
10768 C                    RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1))
10769                      GOTO 4
10770                   ENDIF
10771     3          CONTINUE
10772     4          CONTINUE
10773             ENDIF
10774          ENDIF
10775
10776          DO 5 I=1,KSITEB
10777             BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+
10778      &         RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10779      &         RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10780      &         RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+
10781      &                    BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I))
10782     5    CONTINUE
10783       ENDIF
10784
10785       CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX)
10786       IF (NIDX.LE.-1) THEN
10787          RPROJ = RASH(1)
10788          RTARG = RBSH(NTARG)
10789       ELSE
10790          RPROJ = RASH(NTARG)
10791          RTARG = RBSH(1)
10792       ENDIF
10793
10794       RETURN
10795       END
10796
10797 *$ CREATE DT_DIAGR.FOR
10798 *COPY DT_DIAGR
10799 *
10800 *===diagr==============================================================*
10801 *
10802       SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC,
10803      &                                                         NIDX)
10804
10805 ************************************************************************
10806 * Based on the original version by Shmakov et al.                      *
10807 * This version dated 21.04.95 is revised by S. Roesler                 *
10808 ************************************************************************
10809
10810       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10811       SAVE
10812       PARAMETER ( LINP = 10 ,
10813      &            LOUT = 6 ,
10814      &            LDAT = 9 )
10815       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10816       PARAMETER (TWOPI  = 6.283185307179586454D+00,
10817      &           PI     = TWOPI/TWO,
10818      &           GEV2MB = 0.38938D0,
10819      &           GEV2FM = 0.1972D0,
10820      &           ALPHEM = ONE/137.0D0,
10821 * proton mass
10822      &           AMP    = 0.938D0,
10823      &           AMP2   = AMP**2,
10824 * rho0 mass
10825      &           AMRHO0 = 0.77D0)
10826
10827       COMPLEX*16 C,CA,CI
10828       PARAMETER ( MAXNCL = 260,
10829      &            MAXVQU = MAXNCL,
10830      &            MAXSQU = 20*MAXVQU,
10831      &            MAXINT = MAXVQU+MAXSQU)
10832 * particle properties (BAMJET index convention)
10833       CHARACTER*8  ANAME
10834       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
10835      &                IICH(210),IIBAR(210),K1(210),K2(210)
10836       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10837 * emulsion treatment
10838       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
10839      &                NCOMPO,IEMUL
10840 * Glauber formalism: parameters
10841       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10842      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10843      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10844      &                NSITEB,NSTATB
10845 * Glauber formalism: cross sections
10846       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10847      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10848      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10849      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10850      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10851      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10852      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10853      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10854      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10855      &                BSLOPE,NEBINI,NQBINI
10856 * VDM parameter for photon-nucleus interactions
10857       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
10858 * nucleon-nucleon event-generator
10859       CHARACTER*8 CMODEL
10860       LOGICAL LPHOIN
10861       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10862 **PHOJET105a
10863 C     COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10864 **PHOJET112
10865 C  obsolete cut-off information
10866       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
10867       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10868 **
10869 * coordinates of nucleons
10870       COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
10871 * interface between Glauber formalism and DPM
10872       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
10873      &                INTER1(MAXINT),INTER2(MAXINT)
10874 * statistics: Glauber-formalism
10875       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
10876 * n-n cross section fluctuations
10877       PARAMETER (NBINS = 1000)
10878       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
10879
10880       DIMENSION JS(MAXNCL),JT(MAXNCL),
10881      &          JS0(MAXNCL),JT0(MAXNCL,MAXNCL),
10882      &          JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL)
10883       DIMENSION NWA(0:210),NWB(0:210)
10884
10885       LOGICAL LFIRST
10886       DATA LFIRST /.TRUE./
10887
10888       DATA NTARGO,ICNT /0,0/
10889
10890       NTARG = ABS(NIDX)
10891
10892       IF (LFIRST) THEN
10893          LFIRST = .FALSE.
10894          IF (NCOMPO.EQ.0) THEN
10895             NCALL  = 0
10896             NWAMAX = NA
10897             NWBMAX = NB
10898             DO 17 I=0,210
10899                NWA(I) = 0
10900                NWB(I) = 0
10901    17       CONTINUE
10902          ENDIF
10903       ENDIF
10904       IF (NTARG.EQ.-1) THEN
10905          IF (NCOMPO.EQ.0) THEN
10906             WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons'
10907             WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ',
10908      &                                NCALL,NWAMAX,NWBMAX
10909             DO 18 I=1,MAX(NWAMAX,NWBMAX)
10910                WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)')
10911      &                          I,NWA(I),DBLE(NWA(I))/DBLE(NCALL),
10912      &                            NWB(I),DBLE(NWB(I))/DBLE(NCALL)
10913    18       CONTINUE
10914          ENDIF
10915          RETURN
10916       ENDIF
10917
10918       DCOH   = 1.0D10
10919       IPNT   = 0
10920
10921       SQ2  = Q2
10922       IF (SQ2.LE.ZERO) SQ2 = 0.0001D0
10923       S   = ECMNOW**2
10924       X   = SQ2/(S+SQ2-AMP2)
10925       XNU = (S+SQ2-AMP2)/(TWO*AMP)
10926 * photon projectiles: recalculate photon-nucleon amplitude
10927       IF (IJPROJ.EQ.7) THEN
10928    15    CONTINUE
10929 *  VDM assumption: mass of V-meson
10930          AMV2   = DT_SAM2(SQ2,ECMNOW)
10931          AMV    = SQRT(AMV2)
10932          IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15
10933 *  check for pointlike interaction
10934          CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1)
10935 **sr 27.10.
10936 C        SIGSH  = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
10937          SIGSH  = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
10938 **
10939          ROSH   = 0.1D0
10940          BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2)
10941      &                   +0.25D0*LOG(S/(AMV2+SQ2)))
10942 *  coherence length
10943          IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM
10944       ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
10945          IF (MCGENE.EQ.2) THEN
10946             ZERO1 = ZERO
10947             CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3,
10948      &                                                BSLOPE,0)
10949          ELSE
10950             BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
10951          ENDIF
10952          IF (ECMNOW.LE.3.0D0) THEN
10953             ROSH = -0.43D0
10954          ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN
10955             ROSH = -0.63D0+0.175D0*LOG(ECMNOW)
10956          ELSEIF (ECMNOW.GT.50.0D0) THEN
10957             ROSH = 0.1D0
10958          ENDIF
10959          ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
10960          PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
10961          IF (MCGENE.EQ.2) THEN
10962             ZERO1 = ZERO
10963             CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3,
10964      &                                                  BDUM,0)
10965             SIGSH = SIGSH/10.0D0
10966          ELSE
10967 C           SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
10968             DUMZER = ZERO
10969             CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
10970             SIGSH = SIGSH/10.0D0
10971          ENDIF
10972       ELSE
10973          BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
10974          ROSH   = 0.01D0
10975          ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
10976          PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
10977 C        SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
10978          DUMZER = ZERO
10979          CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
10980          SIGSH = SIGSH/10.0D0
10981       ENDIF
10982       GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
10983       GAM = GSH
10984       RCA = GAM*SIGSH/TWOPI
10985       FCA = -ROSH*RCA
10986       CA  = DCMPLX(RCA,FCA)
10987       CI  = DCMPLX(ONE,ZERO)
10988
10989    16 CONTINUE
10990 * impact parameter
10991       IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX)
10992
10993       NTRY = 0
10994     3 CONTINUE
10995       NTRY = NTRY+1
10996 * initializations
10997       JNT  = 0
10998       DO 1 I=1,NA
10999          JS(I) = 0
11000     1 CONTINUE
11001       DO 2 I=1,NB
11002          JT(I) = 0
11003     2 CONTINUE
11004       IF (IJPROJ.EQ.7) THEN
11005          DO 8 I=1,MAXNCL
11006             JS0(I) = 0
11007             JNT0(I)= 0
11008             DO 9 J=1,NB
11009                JT0(I,J) = 0
11010     9       CONTINUE
11011     8    CONTINUE
11012       ENDIF
11013
11014 * nucleon configuration
11015 C     IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN
11016       IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN
11017 C        CALL DT_CONUCL(PKOO,NA,RASH,2)
11018 C        CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1)
11019          IF (NIDX.LE.-1) THEN
11020             CALL DT_CONUCL(PKOO,NA,RASH(1),0)
11021             CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0)
11022          ELSE
11023             CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0)
11024             CALL DT_CONUCL(TKOO,NB,RBSH(1),0)
11025          ENDIF
11026          NTARGO = NTARG
11027       ENDIF
11028       ICNT = ICNT+1
11029
11030 * LEPTO: pick out one struck nucleon
11031       IF (MCGENE.EQ.3) THEN
11032          JNT     = 1
11033          JS(1)   = 1
11034          IDX     = INT(DT_RNDM(X)*NB)+1
11035          JT(IDX) = 1
11036          B       = ZERO
11037          GOTO 19
11038       ENDIF
11039
11040       DO 4 INA=1,NA
11041 * cross section fluctuations
11042          AFLUC = ONE
11043          IF (IFLUCT.EQ.1) THEN
11044             IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0)
11045             AFLUC = FLUIXX(IFLUK)
11046          ENDIF
11047          KK1  = 1
11048          KINT = 1
11049          DO 5 INB=1,NB
11050 * photon-projectile: check for supression by coherence length
11051             IF (IJPROJ.EQ.7) THEN
11052                IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN
11053                   KK1  = INB
11054                   KINT = KINT+1
11055                ENDIF
11056             ENDIF
11057             QQ1 = B+TKOO(1,INB)-PKOO(1,INA)
11058             QQ2 =   TKOO(2,INB)-PKOO(2,INA)
11059             XY  = GAM*(QQ1*QQ1+QQ2*QQ2)
11060             IF (XY.LE.15.0D0) THEN
11061                C  = CI-CA*AFLUC*EXP(-XY)
11062                AR = DBLE(C)
11063                AI = DIMAG(C)
11064                P  = AR*AR+AI*AI
11065                IF (DT_RNDM(XY).GE.P) THEN
11066                   JNT = JNT+1
11067                   IF (IJPROJ.EQ.7) THEN
11068                      JNT0(KINT) = JNT0(KINT)+1
11069                      IF (JNT0(KINT).GT.MAXNCL) THEN
11070                         WRITE(LOUT,1001) MAXNCL
11071  1001                   FORMAT(1X,
11072      &                        'DIAGR:  no. of requested interactions',
11073      &                        ' exceeds array dimensions ',I4)
11074                         STOP
11075                      ENDIF
11076                      JS0(KINT)      = JS0(KINT)+1
11077                      JT0(KINT,INB)  = JT0(KINT,INB)+1
11078                      JI1(KINT,JNT0(KINT)) = INA
11079                      JI2(KINT,JNT0(KINT)) = INB
11080                   ELSE
11081                      IF (JNT.GT.MAXINT) THEN
11082                         WRITE(LOUT,1000) JNT, MAXINT
11083  1000                   FORMAT(1X,
11084      &                        'DIAGR:  no. of requested interactions ('
11085      &                        ,I4,') exceeds array dimensions (',I4,')')
11086                         STOP
11087                      ENDIF
11088                      JS(INA) = JS(INA)+1
11089                      JT(INB) = JT(INB)+1
11090                      INTER1(JNT) = INA
11091                      INTER2(JNT) = INB
11092                   ENDIF
11093                ENDIF
11094             ENDIF
11095     5    CONTINUE
11096     4 CONTINUE
11097
11098       IF (JNT.EQ.0) THEN
11099          IF (NTRY.LT.500) THEN
11100             GOTO 3
11101          ELSE
11102 C           WRITE(6,*) ' new impact parameter required (old= ',B,')'
11103             GOTO 16
11104          ENDIF
11105       ENDIF
11106
11107       IDIREC = 0
11108       IF (IJPROJ.EQ.7) THEN
11109          K = INT(ONE+DT_RNDM(X)*DBLE(KINT))
11110    10    CONTINUE
11111          IF (JNT0(K).EQ.0) THEN
11112             K = K+1
11113             IF (K.GT.KINT) K = 1
11114             GOTO 10
11115          ENDIF
11116 * supress Glauber-cascade by direct photon processes
11117          CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2)
11118          IF (IPNT.GT.0) THEN
11119             JNT   = 1
11120             JS(1) = 1
11121             DO 11 INB=1,NB
11122                JT(INB) = JT0(K,INB)
11123                IF (JT(INB).GT.0) GOTO 12
11124    11       CONTINUE
11125    12       CONTINUE
11126             INTER1(1) = 1
11127             INTER2(1) = INB
11128             IDIREC    = IPNT
11129          ELSE
11130             JNT   = JNT0(K)
11131             JS(1) = JS0(K)
11132             DO 13 INB=1,NB
11133                JT(INB) = JT0(K,INB)
11134    13       CONTINUE
11135             DO 14 I=1,JNT
11136                INTER1(I) = JI1(K,I)
11137                INTER2(I) = JI2(K,I)
11138    14       CONTINUE
11139          ENDIF
11140       ENDIF
11141
11142    19 CONTINUE
11143       INTA = 0
11144       INTB = 0
11145       DO 6 I=1,NA
11146         IF (JS(I).NE.0) INTA=INTA+1
11147     6 CONTINUE
11148       DO 7 I=1,NB
11149         IF (JT(I).NE.0) INTB=INTB+1
11150     7 CONTINUE
11151       ICWPG = INTA
11152       ICWTG = INTB
11153       ICIG  = JNT
11154       IPGLB = IPGLB+INTA
11155       ITGLB = ITGLB+INTB
11156       NGLB = NGLB+1
11157
11158       IF (NCOMPO.EQ.0) THEN
11159          NCALL = NCALL+1
11160          NWA(INTA) = NWA(INTA)+1
11161          NWB(INTB) = NWB(INTB)+1
11162       ENDIF
11163
11164       RETURN
11165       END
11166
11167 *$ CREATE DT_MODB.FOR
11168 *COPY DT_MODB
11169 *
11170 *===modb===============================================================*
11171 *
11172       SUBROUTINE DT_MODB(B,NIDX)
11173
11174 ************************************************************************
11175 * Sampling of impact parameter of collision.                           *
11176 *    B          impact parameter    (output)                           *
11177 *    NIDX       index of projectile/target material             (input)*
11178 * Based on the original version by Shmakov et al.                      *
11179 * This version dated 21.04.95 is revised by S. Roesler                 *
11180 *                                                                      *
11181 * Last change 27.12.2006 by S. Roesler.                                *
11182 ************************************************************************
11183
11184       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11185       SAVE
11186       PARAMETER ( LINP = 10 ,
11187      &            LOUT = 6 ,
11188      &            LDAT = 9 )
11189       PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0)
11190
11191       LOGICAL LEFT,LFIRST
11192
11193 * central particle production, impact parameter biasing
11194       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
11195       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11196 * Glauber formalism: parameters
11197       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11198      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11199      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11200      &                NSITEB,NSTATB
11201 * Glauber formalism: cross sections
11202       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11203      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11204      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11205      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11206      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11207      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11208      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11209      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11210      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11211      &                BSLOPE,NEBINI,NQBINI
11212
11213       DATA LFIRST /.TRUE./
11214
11215       NTARG = ABS(NIDX)
11216       IF (NIDX.LE.-1) THEN
11217          RA = RASH(1)
11218          RB = RBSH(NTARG)
11219       ELSE
11220          RA = RASH(NTARG)
11221          RB = RBSH(1)
11222       ENDIF
11223
11224       IF (ICENTR.EQ.2) THEN
11225          IF (RA.EQ.RB) THEN
11226             BB = DT_RNDM(B)*(0.3D0*RA)**2
11227             B  = SQRT(BB)
11228          ELSEIF(RA.LT.RB)THEN
11229             BB = DT_RNDM(B)*1.4D0*(RB-RA)**2
11230             B  = SQRT(BB)
11231          ELSEIF(RA.GT.RB)THEN
11232             BB = DT_RNDM(B)*1.4D0*(RA-RB)**2
11233             B  = SQRT(BB)
11234          ENDIF
11235       ELSE
11236     9    CONTINUE
11237          Y  = DT_RNDM(BB)
11238          I0 = 1
11239          I2 = NSITEB
11240    10    CONTINUE
11241          I1 = (I0+I2)/2
11242          LEFT = ((BSITE(0,1,NTARG,I0)-Y)
11243      &          *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO
11244          IF (LEFT) GOTO 20
11245          I0 = I1
11246          GOTO 30
11247    20    CONTINUE
11248          I2 = I1
11249    30    CONTINUE
11250          IF (I2-I0-2) 40,50,60
11251    40    CONTINUE
11252          I1 = I2+1
11253          IF (I1.GT.NSITEB) I1 = I0-1
11254          GOTO 70
11255    50    CONTINUE
11256          I1 = I0+1
11257          GOTO 70
11258    60    CONTINUE
11259          GOTO 10
11260    70    CONTINUE
11261          X0 = DBLE(I0-1)*BSTEP(NTARG)
11262          X1 = DBLE(I1-1)*BSTEP(NTARG)
11263          X2 = DBLE(I2-1)*BSTEP(NTARG)
11264          Y0 = BSITE(0,1,NTARG,I0)
11265          Y1 = BSITE(0,1,NTARG,I1)
11266          Y2 = BSITE(0,1,NTARG,I2)
11267    80    CONTINUE
11268          B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+
11269      &       X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+
11270      &       X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15)
11271 **sr 5.4.98: shift B by half the bin width to be in agreement with BPROD
11272          B = B+0.5D0*BSTEP(NTARG)
11273          IF (B.LT.ZERO) B = X1
11274          IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG)
11275          IF (ICENTR.LT.0) THEN
11276             IF (LFIRST) THEN
11277                LFIRST = .FALSE.
11278                IF (ICENTR.LE.-100) THEN
11279                   BIMIN  = 0.0D0
11280                ELSE
11281                   XSFRAC = 0.0D0
11282                ENDIF
11283                CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG)
11284                WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG),
11285      &                          BIMIN,BIMAX,XSFRAC*100.0D0,
11286      &                          XSFRAC*XSPRO(1,1,NTARG)
11287  10000         FORMAT(/,1X,'DT_MODB:      Biasing in impact parameter',
11288      &                /,15X,'---------------------------'/,/,4X,
11289      &                'average radii of proj / targ :',F10.3,' fm /',
11290      &                F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :',
11291      &                F10.3,' fm',/,/,21X,'b_lo / b_hi :',
11292      &                F10.3,' fm /',F7.3,' fm',/,5X,'percentage of',
11293      &                ' cross section :',F10.3,' %',/,5X,
11294      &                'corresponding cross section :',F10.3,' mb',/)
11295             ENDIF
11296             IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN
11297                B = BIMIN
11298             ELSE
11299                IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9
11300             ENDIF
11301          ENDIF
11302       ENDIF
11303
11304       RETURN
11305       END
11306
11307 *$ CREATE DT_SHFAST.FOR
11308 *COPY DT_SHFAST
11309 *
11310 *===shfast=============================================================*
11311 *
11312       SUBROUTINE DT_SHFAST(MODE,PPN,IBACK)
11313
11314       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11315       SAVE
11316       PARAMETER ( LINP = 10 ,
11317      &            LOUT = 6 ,
11318      &            LDAT = 9 )
11319       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1,
11320      &           ONE=1.0D0,TWO=2.0D0)
11321
11322       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11323 * Glauber formalism: parameters
11324       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11325      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11326      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11327      &                NSITEB,NSTATB
11328 * properties of interacting particles
11329       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11330 * Glauber formalism: cross sections
11331       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11332      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11333      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11334      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11335      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11336      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11337      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11338      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11339      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11340      &                BSLOPE,NEBINI,NQBINI
11341
11342       IBACK = 0
11343
11344       IF (MODE.EQ.2) THEN
11345          OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11346          WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN
11347  1000    FORMAT(1X,8I5,E15.5)
11348          WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11349  1001    FORMAT(1X,4E15.5)
11350          WRITE(47,1002) SIGSH,ROSH,GSH
11351  1002    FORMAT(1X,3E15.5)
11352          DO 10 I=1,100
11353             WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I)
11354    10    CONTINUE
11355          WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11356  1003    FORMAT(1X,2I10,3E15.5)
11357          CLOSE(47)
11358       ELSE
11359          OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11360          READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP
11361          IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND.
11362      &       (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ)
11363      &       .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND.
11364      &       (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN
11365             READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11366             READ(47,1002) SIGSH,ROSH,GSH
11367             DO 11 I=1,100
11368                READ(47,'(1X,E15.5)') BSITE(1,1,1,I)
11369    11       CONTINUE
11370             READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11371          ELSE
11372             IBACK = 1
11373          ENDIF
11374          CLOSE(47)
11375       ENDIF
11376
11377       RETURN
11378       END
11379
11380 *$ CREATE DT_POILIK.FOR
11381 *COPY DT_POILIK
11382 *
11383 *===poilik=============================================================*
11384 *
11385       SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE)
11386
11387       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
11388       SAVE
11389
11390       PARAMETER ( LINP = 10 ,
11391      &            LOUT = 6 ,
11392      &            LDAT = 9 )
11393       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0)
11394       PARAMETER (NE = 8)
11395
11396 **PHOJET105a
11397 C     CHARACTER*8 MDLNA
11398 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
11399 C     PARAMETER (IEETAB=10)
11400 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
11401 **PHOJET110
11402 C  model switches and parameters
11403       CHARACTER*8 MDLNA
11404       INTEGER ISWMDL,IPAMDL
11405       DOUBLE PRECISION PARMDL
11406       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11407 C  energy-interpolation table
11408       INTEGER IEETA2
11409       PARAMETER ( IEETA2 = 20 )
11410       INTEGER ISIMAX
11411       DOUBLE PRECISION SIGTAB,SIGECM
11412       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
11413 **
11414 * VDM parameter for photon-nucleus interactions
11415       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11416 **sr 22.7.97
11417       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11418 * Glauber formalism: cross sections
11419       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11420      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11421      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11422      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11423      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11424      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11425      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11426      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11427      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11428      &                BSLOPE,NEBINI,NQBINI
11429 **
11430
11431       DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/
11432
11433       IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3
11434
11435 * load cross sections from interpolation table
11436       IP = 1
11437       IF(ECM.LE.SIGECM(IP,1)) THEN
11438         I1 = 1
11439         I2 = 1
11440       ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
11441         DO 50 I=2,ISIMAX
11442           IF(ECM.LE.SIGECM(IP,I)) GOTO 200
11443   50    CONTINUE
11444  200    CONTINUE
11445         I1 = I-1
11446         I2 = I
11447       ELSE
11448         WRITE(LOUT,'(/1X,A,2E12.3)')
11449      &    'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
11450         I1 = ISIMAX
11451         I2 = ISIMAX
11452       ENDIF
11453       FAC2 = ZERO
11454       IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
11455      &                     /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
11456       FAC1 = ONE-FAC2
11457
11458       SIGANO = DT_SANO(ECM)
11459
11460 * cross section dependence on photon virtuality
11461       FSUP1 = ZERO
11462       DO  150 I=1,3
11463          FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I)))
11464      &                             /(ONE+VIRT/PARMDL(30+I))**2
11465  150  CONTINUE
11466       FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34))
11467       FAC1  = FAC1*FSUP1
11468       FAC2  = FAC2*FSUP1
11469       FSUP2 = ONE
11470
11471       ECMOLD = ECM
11472       Q2OLD  = VIRT
11473
11474     3 CONTINUE
11475
11476 C     SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
11477       CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2)
11478       IF (ISHAD(1).EQ.1) THEN
11479          SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
11480       ELSE
11481          SIGDIR = ZERO
11482       ENDIF
11483       SIGANO = FSUP1*FSUP2*SIGANO
11484       SIGTOT = SIGTOT-SIGDIR-SIGANO
11485       SIGDIR = SIGDIR/(FSUP1*FSUP2)
11486       SIGANO = SIGANO/(FSUP1*FSUP2)
11487       SIGTOT = SIGTOT+SIGDIR+SIGANO
11488
11489       RR = DT_RNDM(SIGTOT)
11490       IF (RR.LT.SIGDIR/SIGTOT) THEN
11491          IPNT = 1
11492       ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND.
11493      &        (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN
11494          IPNT = 2
11495       ELSE
11496          IPNT = 0
11497       ENDIF
11498       RPNT = (SIGDIR+SIGANO)/SIGTOT
11499 C     WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2
11500 C     WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO
11501 C     WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM
11502 C     WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT
11503       IF (MODE.EQ.1) RETURN
11504
11505 **sr 22.7.97
11506       K1   = 1
11507       K2   = 1
11508       RATE = ZERO
11509       IF (ECM.GE.ECMNN(NEBINI)) THEN
11510          K1   = NEBINI
11511          K2   = NEBINI
11512          RATE = ONE
11513       ELSEIF (ECM.GT.ECMNN(1)) THEN
11514          DO 10 I=2,NEBINI
11515             IF (ECM.LT.ECMNN(I)) THEN
11516                K1   = I-1
11517                K2   = I
11518                RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1))
11519                GOTO 11
11520             ENDIF
11521    10    CONTINUE
11522    11    CONTINUE
11523       ENDIF
11524       J1   = 1
11525       J2   = 1
11526       RATQ = ZERO
11527       IF (NQBINI.GT.1) THEN
11528          IF (VIRT.GE.Q2G(NQBINI)) THEN
11529             J1   = NQBINI
11530             J2   = NQBINI
11531             RATQ = ONE
11532          ELSEIF (VIRT.GT.Q2G(1)) THEN
11533             DO 12 I=2,NQBINI
11534                IF (VIRT.LT.Q2G(I)) THEN
11535                   J1   = I-1
11536                   J2   = I
11537                   RATQ = LOG10(   VIRT/MAX(Q2G(J1),TINY14))/
11538      &                   LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
11539                   GOTO 13
11540                ENDIF
11541    12       CONTINUE
11542    13       CONTINUE
11543          ENDIF
11544       ENDIF
11545       SGA = XSPRO(K1,J1,NTARG)+
11546      &      RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+
11547      &      RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+
11548      &      RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+
11549      &                 XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG))
11550       SDI = DBLE(NB)*SIGDIR
11551       SAN = DBLE(NB)*SIGANO
11552       SPL = SDI+SAN
11553       RR = DT_RNDM(SPL)
11554       IF (RR.LT.SDI/SGA) THEN
11555          IPNT = 1
11556       ELSEIF ((RR.GE.SDI/SGA).AND.
11557      &        (RR.LT.SPL/SGA)) THEN
11558          IPNT = 2
11559       ELSE
11560          IPNT = 0
11561       ENDIF
11562       RPNT = SPL/SGA
11563 C     WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM
11564 **
11565
11566       RETURN
11567       END
11568
11569 *$ CREATE DT_GLBINI.FOR
11570 *COPY DT_GLBINI
11571 *
11572 *===glbini=============================================================*
11573 *
11574       SUBROUTINE DT_GLBINI(WHAT)
11575
11576 ************************************************************************
11577 * Pre-initialization of profile function                               *
11578 * This version dated 28.11.00 is written by S. Roesler.                *
11579 *                                                                      *
11580 * Last change 27.12.2006 by S. Roesler.                                *
11581 ************************************************************************
11582
11583       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11584       SAVE
11585
11586       PARAMETER ( LINP = 10 ,
11587      &            LOUT = 6 ,
11588      &            LDAT = 9 )
11589       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14)
11590
11591       LOGICAL LCMS
11592
11593 * particle properties (BAMJET index convention)
11594       CHARACTER*8  ANAME
11595       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11596      &                IICH(210),IIBAR(210),K1(210),K2(210)
11597 * properties of interacting particles
11598       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11599       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11600 * emulsion treatment
11601       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11602      &                NCOMPO,IEMUL
11603 * Glauber formalism: flags and parameters for statistics
11604       LOGICAL LPROD
11605       CHARACTER*8 CGLB
11606       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11607 * number of data sets other than protons and nuclei
11608 * at the moment = 2 (pions and kaons)
11609       PARAMETER (MAXOFF=2)
11610       DIMENSION IJPINI(5),IOFFST(25)
11611       DATA IJPINI / 13, 15,  0,  0,  0/
11612 * Glauber data-set to be used for hadron projectiles
11613 * (0=proton, 1=pion, 2=kaon)
11614       DATA (IOFFST(K),K=1,25) /
11615      &  0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11616      &  0, 0, 1, 2, 2/
11617 * Acceptance interval for target nucleus mass
11618       PARAMETER (KBACC = 6)
11619 * flags for input different options
11620       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
11621       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
11622      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
11623
11624       PARAMETER (MAXMSS = 100)
11625       DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS)
11626       DIMENSION WHAT(6)
11627
11628       DATA JPEACH,JPSTEP / 18, 5 /
11629
11630 * temporary patch until fix has been implemented in phojet:
11631 *  maximum energy for pion projectile
11632       DATA ECMXPI / 100000.0D0 /
11633 *
11634 *--------------------------------------------------------------------------
11635 * general initializations
11636 *
11637 *  steps in projectile mass number for initialization
11638       IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4))
11639       IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5))
11640 *
11641 *  energy range and binning
11642       ELO  = ABS(WHAT(1))
11643       EHI  = ABS(WHAT(2))
11644       IF (ELO.GT.EHI) ELO = EHI
11645       NEBIN = MAX(INT(WHAT(3)),1)
11646       IF (ELO.EQ.EHI) NEBIN = 0
11647       LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO)
11648       IF (LCMS) THEN
11649          ECMINI = EHI
11650       ELSE
11651          ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2
11652      &                 +2.0D0*AAM(IJTARG)*EHI)
11653       ENDIF
11654 *
11655 *  default arguments for Glauber-routine
11656       XI  = ZERO
11657       Q2I = ZERO
11658 *
11659 *  initialize nuclear parameters, etc.
11660       CALL DT_BERTTP
11661       CALL DT_INCINI
11662 *
11663 *  open Glauber-data output file
11664       IDX = INDEX(CGLB,' ')
11665       K   = 12
11666       IF (IDX.GT.1) K = IDX-1
11667       OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
11668 *
11669 *--------------------------------------------------------------------------
11670 * Glauber-initialization for proton and nuclei projectiles
11671 *
11672 *  initialize phojet for proton-proton interactions
11673       ELAB = ZERO
11674       PLAB = ZERO
11675       CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11676       CALL DT_PHOINI
11677 *
11678 *  record projectile masses
11679       NASAV = 0
11680       NPROJ = MIN(IP,JPEACH)
11681       DO 10 KPROJ=1,NPROJ
11682          NASAV = NASAV+1
11683          IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11684          IASAV(NASAV) = KPROJ
11685    10 CONTINUE
11686       IF (IP.GT.JPEACH) THEN
11687          NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP)
11688          IF (NPROJ.EQ.0) THEN
11689             NASAV = NASAV+1
11690             IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11691             IASAV(NASAV) = IP
11692          ELSE
11693             DO 11 IPROJ=1,NPROJ
11694                KPROJ = JPEACH+IPROJ*JPSTEP
11695                NASAV = NASAV+1
11696                IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11697                IASAV(NASAV) = KPROJ
11698    11       CONTINUE
11699             IF (KPROJ.LT.IP) THEN
11700                NASAV = NASAV+1
11701                IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11702                IASAV(NASAV) = IP
11703             ENDIF
11704          ENDIF
11705       ENDIF
11706 *
11707 *  record target masses
11708       NBSAV = 0
11709       NTARG = 1
11710       IF (NCOMPO.GT.0) NTARG = NCOMPO
11711       DO 12 ITARG=1,NTARG
11712          NBSAV = NBSAV+1
11713          IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! '
11714          IF (NCOMPO.GT.0) THEN
11715             IBSAV(NBSAV) = IEMUMA(ITARG)
11716          ELSE
11717             IBSAV(NBSAV) = IT
11718          ENDIF
11719    12 CONTINUE
11720 *
11721 *  print masses
11722       WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2))
11723  1000 FORMAT(I4,A,1P,2E13.5)
11724       NLINES = DBLE(NASAV)/18.0D0
11725       IF (NLINES.GT.0) THEN
11726          DO 13 I=1,NLINES
11727             IF (I.EQ.1) THEN
11728                WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18)
11729             ELSE
11730                WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I)
11731             ENDIF
11732    13    CONTINUE
11733       ENDIF
11734       I0 = 18*NLINES+1
11735       IF (I0.LE.NASAV) THEN
11736          IF (I0.EQ.1) THEN
11737             WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV)
11738          ELSE
11739             WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV)
11740          ENDIF
11741       ENDIF
11742       NLINES = DBLE(NBSAV)/18.0D0
11743       IF (NLINES.GT.0) THEN
11744          DO 14 I=1,NLINES
11745             IF (I.EQ.1) THEN
11746                WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18)
11747             ELSE
11748                WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I)
11749             ENDIF
11750    14    CONTINUE
11751       ENDIF
11752       I0 = 18*NLINES+1
11753       IF (I0.LE.NBSAV) THEN
11754          IF (I0.EQ.1) THEN
11755             WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV)
11756          ELSE
11757             WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV)
11758          ENDIF
11759       ENDIF
11760 *
11761 *  calculate Glauber-data for each energy and mass combination
11762 *
11763 *   loop over energy bins
11764       ELO = LOG10(ELO)
11765       EHI = LOG10(EHI)
11766       DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE)
11767       DO 1 IE=1,NEBIN+1
11768          E = ELO+DBLE(IE-1)*DEBIN
11769          E = 10**E
11770          IF (LCMS) THEN
11771             E   = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E)
11772             ECM = E
11773          ELSE
11774             PLAB = ZERO
11775             ECM  = ZERO
11776             E    = MAX(AAM(IJPROJ)+0.1D0,E)
11777             CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11778          ENDIF
11779 *
11780 *   loop over projectile and target masses
11781          DO 2 ITARG=1,NBSAV
11782             DO 3 IPROJ=1,NASAV
11783                CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ,
11784      &                                       XI,Q2I,ECM,1,1,-1)
11785     3       CONTINUE
11786     2    CONTINUE
11787 *
11788     1 CONTINUE
11789 *
11790 *--------------------------------------------------------------------------
11791 * Glauber-initialization for pion, kaon, ... projectiles
11792 *
11793       DO 6 IJ=1,MAXOFF
11794 *
11795 *  initialize phojet for this interaction
11796          ELAB = ZERO
11797          PLAB = ZERO
11798          IJPROJ = IJPINI(IJ)
11799          IP     = 1
11800          IPZ    = 1
11801 *
11802 *   temporary patch until fix has been implemented in phojet:
11803          IF (ECMINI.GT.ECMXPI) THEN
11804             CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1)
11805          ELSE
11806             CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11807          ENDIF
11808          CALL DT_PHOINI
11809 *
11810 *  calculate Glauber-data for each energy and mass combination
11811 *
11812 *   loop over energy bins
11813          DO 4 IE=1,NEBIN+1
11814             E = ELO+DBLE(IE-1)*DEBIN
11815             E = 10**E
11816             IF (LCMS) THEN
11817                E   = MAX(2.0D0*AAM(IJPROJ)+TINY14,E)
11818                ECM = E
11819             ELSE
11820                PLAB = ZERO
11821                ECM  = ZERO
11822                E    = MAX(AAM(IJPROJ)+TINY14,E)
11823                CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11824             ENDIF
11825 *
11826 *   loop over projectile and target masses
11827             DO 5 ITARG=1,NBSAV
11828                CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1)
11829     5       CONTINUE
11830 *
11831     4    CONTINUE
11832 *
11833     6 CONTINUE
11834
11835 *--------------------------------------------------------------------------
11836 * close output unit(s), etc.
11837 *
11838       CLOSE(LDAT)
11839
11840       RETURN
11841       END
11842
11843 *$ CREATE DT_GLBSET.FOR
11844 *COPY DT_GLBSET
11845 *
11846 *===glbset=============================================================*
11847 *
11848       SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE)
11849 ************************************************************************
11850 * Interpolation of pre-initialized profile functions                   *
11851 * This version dated 28.11.00 is written by S. Roesler.                *
11852 ************************************************************************
11853
11854       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11855       SAVE
11856
11857       PARAMETER ( LINP = 10 ,
11858      &            LOUT = 6 ,
11859      &            LDAT = 9 )
11860       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
11861
11862       LOGICAL LCMS,LREAD,LFRST1,LFRST2
11863
11864 * particle properties (BAMJET index convention)
11865       CHARACTER*8  ANAME
11866       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11867      &                IICH(210),IIBAR(210),K1(210),K2(210)
11868 * Glauber formalism: flags and parameters for statistics
11869       LOGICAL LPROD
11870       CHARACTER*8 CGLB
11871       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11872       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11873 * Glauber formalism: parameters
11874       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11875      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11876      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11877      &                NSITEB,NSTATB
11878 * Glauber formalism: cross sections
11879       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11880      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11881      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11882      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11883      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11884      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11885      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11886      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11887      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11888      &                BSLOPE,NEBINI,NQBINI
11889 * number of data sets other than protons and nuclei
11890 * at the moment = 2 (pions and kaons)
11891       PARAMETER (MAXOFF=2)
11892       DIMENSION IJPINI(5),IOFFST(25)
11893       DATA IJPINI / 13, 15,  0,  0,  0/
11894 * Glauber data-set to be used for hadron projectiles
11895 * (0=proton, 1=pion, 2=kaon)
11896       DATA (IOFFST(K),K=1,25) /
11897      &  0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11898      &  0, 0, 1, 2, 2/
11899 * Acceptance interval for target nucleus mass
11900       PARAMETER (KBACC = 6)
11901 * emulsion treatment
11902       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11903      &                NCOMPO,IEMUL
11904
11905       PARAMETER (MAXSET=5000,
11906      &           MAXBIN=100)
11907       DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB)
11908       DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6),
11909      &          BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB),
11910      &          IAIDX(10)
11911
11912       DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./
11913 *
11914 * read data from file
11915 *
11916       IF (MODE.EQ.0) THEN
11917
11918          IF (LREAD) RETURN
11919
11920          DO 1 I=1,MAXSET
11921             DO 2 J=1,6
11922                XSIG(I,J) = ZERO
11923                XERR(I,J) = ZERO
11924     2       CONTINUE
11925             DO 3 J=1,KSITEB
11926                BPROFL(I,J) = ZERO
11927     3       CONTINUE
11928     1    CONTINUE
11929          DO 4 I=1,MAXBIN
11930             IABIN(I) = 0
11931             IBBIN(I) = 0
11932     4    CONTINUE
11933          DO 5 I=1,KSITEB
11934             BPRO0(I) = ZERO
11935             BPRO1(I) = ZERO
11936             BPRO(I)  = ZERO
11937     5    CONTINUE
11938
11939          IDX = INDEX(CGLB,' ')
11940          K   = 12
11941          IF (IDX.GT.1) K = IDX-1
11942          OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
11943          WRITE(LOUT,1000) CGLB(1:K)//'.glb'
11944  1000    FORMAT(/,' GLBSET: impact parameter distributions read from ',
11945      &          'file ',A12,/)
11946 *
11947 *  read binning information
11948          READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI
11949 *  return lower energy threshold to Fluka-interface
11950          ELAB = ELO
11951          LCMS = ELO.LT.ZERO
11952          WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:'
11953          IF (LCMS) THEN
11954             WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN
11955          ELSE
11956             WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN
11957          ENDIF
11958  1001    FORMAT(2X,A5,'  E_lo = ',1P,E9.3,'  E_hi = ',1P,E9.3,4X,
11959      &          'No. of bins:',I5,/)
11960          ELO  = LOG10(ABS(ELO))
11961          EHI  = LOG10(ABS(EHI))
11962          DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN))
11963          WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)'
11964          READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18)
11965          IF (NABIN.LT.18) THEN
11966             WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN)
11967          ELSE
11968             WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18)
11969          ENDIF
11970          IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !'
11971          IF (NABIN.GT.18) THEN
11972             NLINES = DBLE(NABIN-18)/18.0D0
11973             IF (NLINES.GT.0) THEN
11974                DO 7 I=1,NLINES
11975                   I0 = 18*(I+1)-17
11976                   READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
11977                   WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
11978     7          CONTINUE
11979             ENDIF
11980             I0 = 18*(NLINES+1)+1
11981             IF (I0.LE.NABIN) THEN
11982                READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
11983                WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
11984             ENDIF
11985          ENDIF
11986          WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)'
11987          READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18)
11988          IF (NBBIN.LT.18) THEN
11989             WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN)
11990          ELSE
11991             WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18)
11992          ENDIF
11993          IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !'
11994          IF (NBBIN.GT.18) THEN
11995             NLINES = DBLE(NBBIN-18)/18.0D0
11996             IF (NLINES.GT.0) THEN
11997                DO 8 I=1,NLINES
11998                   I0 = 18*(I+1)-17
11999                   READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12000                   WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12001     8          CONTINUE
12002             ENDIF
12003             I0 = 18*(NLINES+1)+1
12004             IF (I0.LE.NBBIN) THEN
12005                READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12006                WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12007             ENDIF
12008          ENDIF
12009 *  number of data sets to follow in the Glauber data file
12010 *   this variable is used for checks of consistency of projectile
12011 *   and target mass configurations given in header of Glauber data
12012 *   file and the data-sets which follow in this file
12013          NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN
12014 *
12015 *  read profile function data
12016          NSET  = 0
12017          NAIDX = 0
12018          IPOLD = 0
12019    10    CONTINUE
12020          NSET = NSET+1
12021          IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! '
12022          READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM
12023  1002    FORMAT(5I10,E15.5)
12024          IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN
12025             NAIDX = NAIDX+1
12026             IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !'
12027             IAIDX(NAIDX) = IP
12028             IPOLD = IP
12029          ENDIF
12030          READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6)
12031          READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6)
12032          NLINES = INT(DBLE(ISITEB)/7.0D0)
12033          IF (NLINES.GT.0) THEN
12034             DO 11 I=1,NLINES
12035                READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I)
12036    11       CONTINUE
12037          ENDIF
12038          I0 = 7*NLINES+1
12039          IF (I0.LE.ISITEB)
12040      &      READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB)
12041          GOTO 10
12042   100    CONTINUE
12043          NSET = NSET-1
12044          IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !'
12045          WRITE(LOUT,'(/,1X,A)')
12046      &   ' projectiles other than protons and nuclei: (particle index)'
12047          IF (NAIDX.GT.0) THEN
12048             WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX)
12049          ELSE
12050             WRITE(LOUT,'(6X,A)') 'none'
12051          ENDIF
12052 *
12053          CLOSE(LDAT)
12054          WRITE(LOUT,*)
12055          LREAD = .TRUE.
12056
12057          IF (NCOMPO.EQ.0) THEN
12058             DO 12 J=1,NBBIN
12059                NCOMPO = NCOMPO+1
12060                IEMUMA(NCOMPO) = IBBIN(J)
12061                IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2
12062                EMUFRA(NCOMPO) = 1.0D0
12063    12       CONTINUE
12064             IEMUL = 1
12065          ENDIF
12066 *
12067 * calculate profile function for certain set of parameters
12068 *
12069       ELSE
12070
12071 c        write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE
12072 *
12073 * check for type of projectile and set index-offset to entry in
12074 * Glauber data array correspondingly
12075          IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !'
12076          IF (IOFFST(IDPROJ).EQ.-1) THEN
12077             STOP ' GLBSET: no data for this projectile !'
12078          ELSEIF (IOFFST(IDPROJ).GT.0) THEN
12079             IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN
12080          ELSE
12081             IDXOFF = 0
12082          ENDIF
12083 *
12084 * get energy bin and interpolation factor
12085          IF (LCMS) THEN
12086             E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB)
12087          ELSE
12088             E = ELAB
12089          ENDIF
12090          E = LOG10(E)
12091          IF (E.LT.ELO) THEN
12092             IF (LFRST1) THEN
12093                WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E
12094                LFRST1 = .FALSE.
12095             ENDIF
12096             E = ELO
12097          ENDIF
12098          IF (E.GT.EHI) THEN
12099             IF (LFRST2) THEN
12100                WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E
12101                LFRST2 = .FALSE.
12102             ENDIF
12103             E = EHI
12104          ENDIF
12105          IE0  = (E-ELO)/DEBIN+1
12106          IE1  = IE0+1
12107          FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN
12108 *
12109 * get target nucleus index
12110          KB = 0
12111          NBACC = KBACC
12112          DO 20 I=1,NBBIN
12113             NBDIFF = ABS(NB-IBBIN(I))
12114             IF (NB.EQ.IBBIN(I)) THEN
12115                KB = I
12116                GOTO 21
12117             ELSEIF (NBDIFF.LE.NBACC) THEN
12118                KB = I
12119                NBACC = NBDIFF
12120             ENDIF
12121    20    CONTINUE
12122          IF (KB.NE.0) GOTO 21
12123          WRITE(LOUT,*) ' GLBSET: data not found for target ',NB
12124          STOP
12125    21    CONTINUE
12126 *
12127 * get projectile nucleus bin and interpolation factor
12128          KA0 = 0
12129          KA1 = 0
12130          FACNA = 0
12131          IF (IDXOFF.GT.0) THEN
12132             KA0 = 1
12133             KA1 = 1
12134             KABIN = 1
12135          ELSE
12136             IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !'
12137             DO 22 I=1,NABIN
12138                IF (NA.EQ.IABIN(I)) THEN
12139                   KA0 = I
12140                   KA1 = I
12141                   GOTO 23
12142                ELSEIF (NA.LT.IABIN(I)) THEN
12143                   KA0 = I-1
12144                   KA1 = I
12145                   GOTO 23
12146                ENDIF
12147    22       CONTINUE
12148             WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA
12149             STOP
12150    23       CONTINUE
12151             IF (KA0.NE.KA1)
12152      &         FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0))
12153             KABIN = NABIN
12154          ENDIF
12155 *
12156 * interpolate profile functions for interactions ka0-kb and ka1-kb
12157 * for energy E separately
12158          IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12159          IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12160          IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12161          IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12162          DO 30 I=1,ISITEB
12163             BPRO0(I) = BPROFL(IDX0,I)
12164      &                 +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I))
12165             BPRO1(I) = BPROFL(IDY0,I)
12166      &                 +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I))
12167    30    CONTINUE
12168          RADB  = DT_RNCLUS(NB)
12169          BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1)
12170          BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1)
12171 *
12172 * interpolate cross sections for energy E and projectile mass
12173          DO 31 I=1,6
12174             XS0   = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I))
12175             XS1   = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I))
12176             XS(I) = XS0+FACNA*(XS1-XS0)
12177             XE0   = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I))
12178             XE1   = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I))
12179             XE(I) = XE0+FACNA*(XE1-XE0)
12180    31    CONTINUE
12181 *
12182 * interpolate between ka0 and ka1
12183          RADA = DT_RNCLUS(NA)
12184          BMX  = 2.0D0*(RADA+RADB)
12185          BSTP = BMX/DBLE(ISITEB-1)
12186          BPRO(1) = ZERO
12187          DO 32 I=1,ISITEB-1
12188             B = DBLE(I)*BSTP
12189 *
12190 *   calculate values of profile functions at B
12191             IDX0 = B/BSTP0+1
12192             IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12193             IDX1 = MIN(IDX0+1,ISITEB)
12194             FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0
12195             BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0))
12196             IDX0 = B/BSTP1+1
12197             IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12198             IDX1 = MIN(IDX0+1,ISITEB)
12199             FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1
12200             BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0))
12201 *
12202             BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0)
12203    32    CONTINUE
12204 *
12205 * fill common dtglam
12206          NSITEB   = ISITEB
12207          RASH(1)  = RADA
12208          RBSH(1)  = RADB
12209          BMAX(1)  = BMX
12210          BSTEP(1) = BSTP
12211          DO 33 I=1,KSITEB
12212             BSITE(0,1,1,I) = BPRO(I)
12213    33    CONTINUE
12214 *
12215 * fill common dtglxs
12216          XSTOT(1,1,1) = XS(1)
12217          XSELA(1,1,1) = XS(2)
12218          XSQEP(1,1,1) = XS(3)
12219          XSQET(1,1,1) = XS(4)
12220          XSQE2(1,1,1) = XS(5)
12221          XSPRO(1,1,1) = XS(6)
12222          XETOT(1,1,1) = XE(1)
12223          XEELA(1,1,1) = XE(2)
12224          XEQEP(1,1,1) = XE(3)
12225          XEQET(1,1,1) = XE(4)
12226          XEQE2(1,1,1) = XE(5)
12227          XEPRO(1,1,1) = XE(6)
12228
12229       ENDIF
12230
12231       RETURN
12232       END
12233
12234 *$ CREATE DT_XKSAMP.FOR
12235 *COPY DT_XKSAMP
12236 *
12237 *===xksamp=============================================================*
12238 *
12239       SUBROUTINE DT_XKSAMP(NN,ECM)
12240
12241 ************************************************************************
12242 * Sampling of parton x-values and chain system for one interaction.    *
12243 *                                   processed by S. Roesler, 9.8.95    *
12244 ************************************************************************
12245
12246       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12247       SAVE
12248       PARAMETER ( LINP = 10 ,
12249      &            LOUT = 6 ,
12250      &            LDAT = 9 )
12251       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
12252 CPH      SAVE
12253
12254       PARAMETER (
12255 * lower cuts for (valence-sea/sea-valence) chain masses
12256 *   antiquark-quark (u/d-sea quark)    (s-sea quark)
12257      &               AMIU = 0.5D0,      AMIS = 0.8D0,
12258 *   quark-diquark   (u/d-sea quark)    (s-sea quark)
12259      &               AMAU = 2.6D0,      AMAS = 2.6D0,
12260 * maximum lower valence-x threshold
12261      &           XVMAX  = 0.98D0,
12262 * fraction of sea-diquarks sampled out of sea-partons
12263 **test
12264 C    &           FRCDIQ = 0.9D0,
12265 **
12266 *
12267      &           SQMA   = 0.7D0,
12268 *
12269 * maximum number of trials to generate x's for the required number
12270 * of sea quark pairs for a given hadron
12271      &           NSEATY = 12
12272 C    &           NSEATY = 3
12273      &          )
12274
12275       LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO
12276
12277       PARAMETER ( MAXNCL = 260,
12278      &            MAXVQU = MAXNCL,
12279      &            MAXSQU = 20*MAXVQU,
12280      &            MAXINT = MAXVQU+MAXSQU)
12281 * event history
12282       PARAMETER (NMXHKK=200000)
12283       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
12284      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
12285      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
12286 * particle properties (BAMJET index convention)
12287       CHARACTER*8  ANAME
12288       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12289      &                IICH(210),IIBAR(210),K1(210),K2(210)
12290 * interface between Glauber formalism and DPM
12291       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
12292      &                INTER1(MAXINT),INTER2(MAXINT)
12293 * properties of interacting particles
12294       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12295 * threshold values for x-sampling (DTUNUC 1.x)
12296       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
12297      &                SSMIMQ,VVMTHR
12298 * x-values of partons (DTUNUC 1.x)
12299       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
12300      &                XTVQ(MAXVQU),XTVD(MAXVQU),
12301      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
12302      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
12303 * flavors of partons (DTUNUC 1.x)
12304       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
12305      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
12306      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
12307      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
12308      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
12309      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
12310      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
12311 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12312       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
12313      &                IXPV,IXPS,IXTV,IXTS,
12314      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
12315      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
12316      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
12317      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
12318      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
12319      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
12320      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
12321      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
12322 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12323       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
12324      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
12325 * auxiliary common for chain system storage (DTUNUC 1.x)
12326       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
12327 * flags for input different options
12328       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12329       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12330      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12331 * various options for treatment of partons (DTUNUC 1.x)
12332 * (chain recombination, Cronin,..)
12333       LOGICAL LCO2CR,LINTPT
12334       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
12335      &                LCO2CR,LINTPT
12336
12337       DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU),
12338      &          INTLO(MAXINT)
12339
12340 * (1) initializations
12341 *-----------------------------------------------------------------------
12342
12343 **test
12344       IF (ECM.LT.4.5D0) THEN
12345 C        FRCDIQ = 0.6D0
12346          FRCDIQ = 0.4D0
12347       ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN
12348 C        FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0
12349          FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0
12350       ELSE
12351 C        FRCDIQ = 0.9D0
12352          FRCDIQ = 0.7D0
12353       ENDIF
12354 **
12355       DO 30 I=1,MAXSQU
12356          ZUOSP(I) = .FALSE.
12357          ZUOST(I) = .FALSE.
12358          IF (I.LE.MAXVQU) THEN
12359             ZUOVP(I) = .FALSE.
12360             ZUOVT(I) = .FALSE.
12361          ENDIF
12362    30 CONTINUE
12363
12364 * lower thresholds for x-selection
12365 *  sea-quarks       (default: CSEA=0.2)
12366       IF (ECM.LT.10.0D0) THEN
12367 **!!test
12368          XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM
12369 C        XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0
12370          NSEA  = NSEATY
12371 C        XSTHR = ONE/ECM**2
12372       ELSE
12373 **sr 30.3.98
12374 C        XSTHR = CSEA/ECM
12375          XSTHR = CSEA/ECM**2
12376 C        XSTHR = ONE/ECM**2
12377 **
12378          IF ((IP.GE.150).AND.(IT.GE.150))
12379      &      XSTHR = 2.5D0/(ECM*SQRT(ECM))
12380          NSEA  = NSEATY
12381       ENDIF
12382 *                   (default: SSMIMA=0.14) used for sea-diquarks (?)
12383       XSSTHR = SSMIMA/ECM
12384       BSQMA  = SQMA/ECM
12385 *  valence-quarks   (default: CVQ=1.0)
12386       XVTHR  = CVQ/ECM
12387 *  valence-diquarks (default: CDQ=2.0)
12388       XDTHR  = CDQ/ECM
12389
12390 * maximum-x for sea-quarks
12391       XVCUT  = XVTHR+XDTHR
12392       IF (XVCUT.GT.XVMAX) THEN
12393          XVCUT = XVMAX
12394          XVTHR = XVCUT/3.0D0
12395          XDTHR = XVCUT-XVTHR
12396       ENDIF
12397       XXSEAM = ONE-XVCUT
12398 **sr 18.4. test: DPMJET
12399 C     XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1))
12400 C    &            - XDTHR*(1.D0+0.3D0*DT_RNDM(V2))
12401 C    &             -0.01*(1.D0+1.5D0*DT_RNDM(V3))
12402 **
12403 * maximum number of sea-pairs allowed kinematically
12404 C     NSMAX  = INT(OHALF*XXSEAM/XSTHR)
12405       RNSMAX = OHALF*XXSEAM/XSTHR
12406       IF (RNSMAX.GT.10000.0D0) THEN
12407          NSMAX = 10000
12408       ELSE
12409          NSMAX = INT(OHALF*XXSEAM/XSTHR)
12410       ENDIF
12411 * check kinematical limit for valence-x thresholds
12412 * (should be obsolete now)
12413       IF (XVCUT.GT.XVMAX) THEN
12414          WRITE(LOUT,1000) XVCUT,ECM
12415  1000    FORMAT(' XKSAMP:    kin. limit for valence-x',
12416      &          '  thresholds not allowed (',2E9.3,')')
12417 C        XVTHR = XVMAX-XDTHR
12418 C        IF (XVTHR.LT.ZERO) STOP
12419          STOP
12420       ENDIF
12421
12422 * set eta for valence-x sampling (BETREJ)
12423 *   (UNON per default, UNOM used for projectile mesons only)
12424       IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN
12425          UNOPRV = UNOM
12426       ELSE
12427          UNOPRV = UNON
12428       ENDIF
12429
12430 * (2) select parton x-values of interacting projectile nucleons
12431 *-----------------------------------------------------------------------
12432
12433       IXPV = 0
12434       IXPS = 0
12435
12436       DO 100 IPP=1,IP
12437 *   get interacting projectile nucleon as sampled by Glauber
12438          IF (JSSH(IPP).NE.0) THEN
12439             IXSTMP = IXPS
12440             IXVTMP = IXPV
12441    99       CONTINUE
12442             IXPS   = IXSTMP
12443             IXPV   = IXVTMP
12444 *     JIPP is the actual number of sea-pairs sampled for this nucleon
12445             JIPP   = MIN(JSSH(IPP)-1,NSMAX)
12446    41       CONTINUE
12447             XXSEA  = ZERO
12448             IF (JIPP.GT.0) THEN
12449                XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR
12450 *???
12451                IF (XSTHR.GE.XSMAX) THEN
12452                   JIPP = JIPP-1
12453                   GOTO 41
12454                ENDIF
12455
12456 *>>>get x-values of sea-quark pairs
12457                NSCOUN = 0
12458                PLW = 0.5D0
12459    40          CONTINUE
12460 *     accumulator for sea x-values
12461                XXSEA  = ZERO
12462                NSCOUN = NSCOUN+1
12463                IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12464                IF (NSCOUN.GT.NSEA) THEN
12465 *     decrease the number of interactions after NSEA trials
12466                   JIPP   = JIPP-1
12467                   NSCOUN = 0
12468                ENDIF
12469                DO 70 ISQ=1,JIPP
12470 *     sea-quarks
12471                   IF (IPSQ(IXPS+1).LE.2) THEN
12472 **sr 8.4.98 (1/sqrt(x))
12473 C                    XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12474 C                    XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12475                      XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12476 **
12477                   ELSE
12478                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
12479                         XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12480                      ELSE
12481 **sr 8.4.98 (1/sqrt(x))
12482 C                       XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12483 C                       XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12484                         XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12485 **
12486                      ENDIF
12487                   ENDIF
12488 *     sea-antiquarks
12489                   IF (IPSAQ(IXPS+1).GE.-2) THEN
12490 **sr 8.4.98 (1/sqrt(x))
12491 C                    XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12492 C                    XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12493                      XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12494 **
12495                   ELSE
12496                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
12497                         XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12498                      ELSE
12499 **sr 8.4.98 (1/sqrt(x))
12500 C                       XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12501 C                       XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12502                         XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12503 **
12504                      ENDIF
12505                   ENDIF
12506                   XXSEA = XXSEA+XPSQI+XPSAQI
12507 *     check for maximum allowed sea x-value
12508                   IF (XXSEA.GE.XXSEAM) THEN
12509                      IXPS = IXPS-ISQ+1
12510                      GOTO 40
12511                   ENDIF
12512 *     accept this sea-quark pair
12513                   IXPS         = IXPS+1
12514                   XPSQ(IXPS)   = XPSQI
12515                   XPSAQ(IXPS)  = XPSAQI
12516                   IFROSP(IXPS) = IPP
12517                   ZUOSP(IXPS)  = .TRUE.
12518    70          CONTINUE
12519             ENDIF
12520
12521 *>>>get x-values of valence partons
12522 *     valence quark
12523             IF (XVTHR.GT.0.05D0) THEN
12524                XVHI  = ONE-XXSEA-XDTHR
12525                XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI)
12526             ELSE
12527    90          CONTINUE
12528                XPVQI = DT_DBETAR(OHALF,UNOPRV)
12529                IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR))
12530      &                                                     GOTO 90
12531             ENDIF
12532 *     valence diquark
12533             XPVDI = ONE-XPVQI-XXSEA
12534 *       reject according to x**1.5
12535             XDTMP = XPVDI**1.5D0
12536             IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99
12537 *     accept these valence partons
12538             IXPV         = IXPV+1
12539             XPVQ(IXPV)   = XPVQI
12540             XPVD(IXPV)   = XPVDI
12541             IFROVP(IXPV) = IPP
12542             ITOVP(IPP)   = IXPV
12543             ZUOVP(IXPV)  = .TRUE.
12544
12545          ENDIF
12546   100 CONTINUE
12547
12548 * (3) select parton x-values of interacting target nucleons
12549 *-----------------------------------------------------------------------
12550
12551       IXTV = 0
12552       IXTS = 0
12553
12554       DO 170 ITT=1,IT
12555 *   get interacting target nucleon as sampled by Glauber
12556          IF (JTSH(ITT).NE.0) THEN
12557             IXSTMP = IXTS
12558             IXVTMP = IXTV
12559   169       CONTINUE
12560             IXTS   = IXSTMP
12561             IXTV   = IXVTMP
12562 *     JITT is the actual number of sea-pairs sampled for this nucleon
12563             JITT   = MIN(JTSH(ITT)-1,NSMAX)
12564   111       CONTINUE
12565             XXSEA  = ZERO
12566             IF (JITT.GT.0) THEN
12567                XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR
12568 *???
12569                IF (XSTHR.GE.XSMAX) THEN
12570                   JITT = JITT-1
12571                   GOTO 111
12572                ENDIF
12573
12574 *>>>get x-values of sea-quark pairs
12575                NSCOUN = 0
12576                PLW = 0.5D0
12577   110          CONTINUE
12578 *     accumulator for sea x-values
12579                XXSEA  = ZERO
12580                NSCOUN = NSCOUN+1
12581                IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12582                IF (NSCOUN.GT.NSEA)THEN
12583 *     decrease the number of interactions after NSEA trials
12584                   JITT   = JITT-1
12585                   NSCOUN = 0
12586                ENDIF
12587                DO 140 ISQ=1,JITT
12588 *     sea-quarks
12589                   IF (ITSQ(IXTS+1).LE.2) THEN
12590 **sr 8.4.98 (1/sqrt(x))
12591 C                    XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12592 C                    XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12593                      XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12594 **
12595                   ELSE
12596                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
12597                         XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12598                      ELSE
12599 **sr 8.4.98 (1/sqrt(x))
12600 C                       XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12601 C                       XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12602                         XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12603 **
12604                      ENDIF
12605                   ENDIF
12606 *     sea-antiquarks
12607                   IF (ITSAQ(IXTS+1).GE.-2) THEN
12608 **sr 8.4.98 (1/sqrt(x))
12609 C                    XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12610 C                    XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12611                      XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12612 **
12613                   ELSE
12614                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
12615                         XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12616                      ELSE
12617 **sr 8.4.98 (1/sqrt(x))
12618 C                       XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12619 C                       XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12620                         XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12621 **
12622                      ENDIF
12623                   ENDIF
12624                   XXSEA = XXSEA+XTSQI+XTSAQI
12625 *     check for maximum allowed sea x-value
12626                   IF (XXSEA.GE.XXSEAM) THEN
12627                      IXTS = IXTS-ISQ+1
12628                      GOTO 110
12629                   ENDIF
12630 *     accept this sea-quark pair
12631                   IXTS         = IXTS+1
12632                   XTSQ(IXTS)   = XTSQI
12633                   XTSAQ(IXTS)  = XTSAQI
12634                   IFROST(IXTS) = ITT
12635                   ZUOST(IXTS)  = .TRUE.
12636   140          CONTINUE
12637             ENDIF
12638
12639 *>>>get x-values of valence partons
12640 *     valence quark
12641             IF (XVTHR.GT.0.05D0) THEN
12642                XVHI  = ONE-XXSEA-XDTHR
12643                XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI)
12644             ELSE
12645   160          CONTINUE
12646                XTVQI = DT_DBETAR(OHALF,UNON)
12647                IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR))
12648      &                                                    GOTO 160
12649             ENDIF
12650 *     valence diquark
12651             XTVDI = ONE-XTVQI-XXSEA
12652 *       reject according to x**1.5
12653             XDTMP = XTVDI**1.5D0
12654             IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169
12655 *     accept these valence partons
12656             IXTV         = IXTV+1
12657             XTVQ(IXTV)   = XTVQI
12658             XTVD(IXTV)   = XTVDI
12659             IFROVT(IXTV) = ITT
12660             ITOVT(ITT)   = IXTV
12661             ZUOVT(IXTV)  = .TRUE.
12662
12663          ENDIF
12664   170 CONTINUE
12665
12666 * (4) get valence-valence chains
12667 *-----------------------------------------------------------------------
12668
12669       NVV = 0
12670       DO 240 I=1,NN
12671          INTLO(I) = .TRUE.
12672          IPVAL    = ITOVP(INTER1(I))
12673          ITVAL    = ITOVT(INTER2(I))
12674          IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN
12675             INTLO(I)      = .FALSE.
12676             ZUOVP(IPVAL)  = .FALSE.
12677             ZUOVT(ITVAL)  = .FALSE.
12678             NVV           = NVV+1
12679             ISKPCH(8,NVV) = 0
12680             INTVV1(NVV)   = IPVAL
12681             INTVV2(NVV)   = ITVAL
12682          ENDIF
12683   240 CONTINUE
12684
12685 * (5) get sea-valence chains
12686 *-----------------------------------------------------------------------
12687
12688       NSV = 0
12689       NDV = 0
12690       PLW = 0.5D0
12691       DO 270 I=1,NN
12692          IF (INTLO(I)) THEN
12693             IPVAL = ITOVP(INTER1(I))
12694             ITVAL = ITOVT(INTER2(I))
12695             DO 250 J=1,IXPS
12696                IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND.
12697      &                                ZUOVT(ITVAL)) THEN
12698                   ZUOSP(J)     = .FALSE.
12699                   ZUOVT(ITVAL) = .FALSE.
12700                   INTLO(I)     = .FALSE.
12701                   IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN
12702 *   sample sea-diquark pair
12703                      CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1)
12704                      IF (IREJ1.EQ.0) GOTO 260
12705                   ENDIF
12706                   NSV           = NSV+1
12707                   ISKPCH(4,NSV) = 0
12708                   INTSV1(NSV)   = J
12709                   INTSV2(NSV)   = ITVAL
12710
12711 *>>>correct chain kinematics according to minimum chain masses
12712 *     the actual chain masses
12713                   AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2
12714                   AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2
12715 *     get lower mass cuts
12716                   IF (IPSQ(J).EQ.3) THEN
12717 *       q being s-quark
12718                      AMCHK1 = AMAS
12719                      AMCHK2 = AMIS
12720                   ELSE
12721 *       q being u/d-quark
12722                      AMCHK1 = AMAU
12723                      AMCHK2 = AMIU
12724                   ENDIF
12725 *       q-qq chain
12726 *         chain mass above minimum - resampling of sea-q x-value
12727                   IF (AMSVQ1.GT.AMCHK1) THEN
12728                      XPSQTH      = AMCHK1/(XTVD(ITVAL)*ECM**2)
12729 **sr 8.4.98 (1/sqrt(x))
12730 C                    XPSQXX      = DT_SAMPEX(XPSQTH,XPSQ(J))
12731 C                    XPSQXX      = DT_SAMSQX(XPSQTH,XPSQ(J))
12732                      XPSQXX      = DT_SAMPLW(XPSQTH,XPSQ(J),PLW)
12733 **
12734                      XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX
12735                      XPSQ(J)     = XPSQXX
12736 *         chain mass below minimum - reset sea-q x-value and correct
12737 *                                    diquark-x of the same nucleon
12738                   ELSEIF (AMSVQ1.LT.AMCHK1) THEN
12739                      XPSQW       = AMCHK1/(XTVD(ITVAL)*ECM**2)
12740                      DXPSQ       = XPSQW-XPSQ(J)
12741                      IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12742                         XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12743                         XPSQ(J)     = XPSQW
12744                      ENDIF
12745                   ENDIF
12746 *       aq-q chain
12747 *         chain mass below minimum - reset sea-aq x-value and correct
12748 *                                    diquark-x of the same nucleon
12749                   IF (AMSVQ2.LT.AMCHK2) THEN
12750                      XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2)
12751                      DXPSQ = XPSQW-XPSAQ(J)
12752                      IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12753                         XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12754                         XPSAQ(J)    = XPSQW
12755                      ENDIF
12756                   ENDIF
12757 *>>>end of chain mass correction
12758
12759                   GOTO 260
12760                ENDIF
12761   250       CONTINUE
12762          ENDIF
12763   260    CONTINUE
12764   270 CONTINUE
12765
12766 * (6) get valence-sea chains
12767 *-----------------------------------------------------------------------
12768
12769       NVS = 0
12770       NVD = 0
12771       DO 300 I=1,NN
12772          IF (INTLO(I)) THEN
12773             IPVAL = ITOVP(INTER1(I))
12774             ITVAL = ITOVT(INTER2(I))
12775             DO 280 J=1,IXTS
12776                IF (ZUOVP(IPVAL).AND.ZUOST(J).AND.
12777      &                  (IFROST(J).EQ.INTER2(I))) THEN
12778                   ZUOST(J)     = .FALSE.
12779                   ZUOVP(IPVAL) = .FALSE.
12780                   INTLO(I)     = .FALSE.
12781                   IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
12782 *   sample sea-diquark pair
12783                      CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1)
12784                      IF (IREJ1.EQ.0) GOTO 290
12785                   ENDIF
12786                   NVS           = NVS + 1
12787                   ISKPCH(6,NVS) = 0
12788                   INTVS1(NVS)   = IPVAL
12789                   INTVS2(NVS)   = J
12790
12791 *>>>correct chain kinematics according to minimum chain masses
12792 *     the actual chain masses
12793                   AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2
12794                   AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2
12795 *     get lower mass cuts
12796                   IF (ITSQ(J).EQ.3) THEN
12797 *       q being s-quark
12798                      AMCHK1 = AMIS
12799                      AMCHK2 = AMAS
12800                   ELSE
12801 *       q being u/d-quark
12802                      AMCHK1 = AMIU
12803                      AMCHK2 = AMAU
12804                   ENDIF
12805 *       q-aq chain
12806 *         chain mass below minimum - reset sea-aq x-value and correct
12807 *                                    diquark-x of the same nucleon
12808                   IF (AMVSQ1.LT.AMCHK1) THEN
12809                      XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2)
12810                      DXTSQ = XTSQW-XTSAQ(J)
12811                      IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12812                         XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12813                         XTSAQ(J)    = XTSQW
12814                      ENDIF
12815                   ENDIF
12816 *       qq-q chain
12817 *         chain mass above minimum - resampling of sea-q x-value
12818                   IF (AMVSQ2.GT.AMCHK2) THEN
12819                      XTSQTH      = AMCHK2/(XPVD(IPVAL)*ECM**2)
12820 **sr 8.4.98 (1/sqrt(x))
12821 C                    XTSQXX      = DT_SAMPEX(XTSQTH,XTSQ(J))
12822 C                    XTSQXX      = DT_SAMSQX(XTSQTH,XTSQ(J))
12823                      XTSQXX      = DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
12824 **
12825                      XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX
12826                      XTSQ(J)     = XTSQXX
12827 *         chain mass below minimum - reset sea-q x-value and correct
12828 *                                    diquark-x of the same nucleon
12829                   ELSEIF (AMVSQ2.LT.AMCHK2) THEN
12830                      XTSQW       = AMCHK2/(XPVD(IPVAL)*ECM**2)
12831                      DXTSQ       = XTSQW-XTSQ(J)
12832                      IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12833                         XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12834                         XTSQ(J)     = XTSQW
12835                      ENDIF
12836                   ENDIF
12837 *>>>end of chain mass correction
12838
12839                   GOTO 290
12840                ENDIF
12841   280       CONTINUE
12842          ENDIF
12843   290    CONTINUE
12844   300 CONTINUE
12845
12846 * (7) get sea-sea chains
12847 *-----------------------------------------------------------------------
12848
12849       NSS = 0
12850       NDS = 0
12851       NSD = 0
12852       DO 420 I=1,NN
12853          IF (INTLO(I)) THEN
12854             IPVAL = ITOVP(INTER1(I))
12855             ITVAL = ITOVT(INTER2(I))
12856 *   loop over target partons not yet matched
12857             DO 400 J=1,IXTS
12858                IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN
12859 *   loop over projectile partons not yet matched
12860                   DO 390 JJ=1,IXPS
12861                      IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN
12862                         ZUOSP(JJ)     = .FALSE.
12863                         ZUOST(J)      = .FALSE.
12864                         INTLO(I)      = .FALSE.
12865                         NSS           = NSS+1
12866                         ISKPCH(1,NSS) = 0
12867                         INTSS1(NSS)   = JJ
12868                         INTSS2(NSS)   = J
12869
12870 *---->chain recombination option
12871                         VALFRA        = DBLE(NVV/(NVV+IXPS+IXTS))
12872                         IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA))
12873      &                                                             THEN
12874 *       sea-sea chains may recombine with valence-valence chains
12875 *       only if they have the same projectile or target nucleon
12876                            DO 4201 IVV=1,NVV
12877                               IF (ISKPCH(8,IVV).NE.99) THEN
12878                                  IXVPR = INTVV1(IVV)
12879                                  IXVTA = INTVV2(IVV)
12880                                  IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR.
12881      &                               (INTER2(I).EQ.IFROVT(IXVTA))) THEN
12882 *         recombination possible, drop old v-v and s-s chains
12883                                     ISKPCH(1,NSS) = 99
12884                                     ISKPCH(8,IVV) = 99
12885
12886 *         (a) assign new s-v chains
12887 *         ~~~~~~~~~~~~~~~~~~~~~~~~~
12888                                     IF (LSEADI.AND.
12889      &                                  (DT_RNDM(VALFRA).GT.FRCDIQ))
12890      &                                                             THEN
12891 *           sample sea-diquark pair
12892                                        CALL DT_SAMSDQ(ECM,IXVTA,JJ,2,
12893      &                                                      IREJ1)
12894                                        IF (IREJ1.EQ.0) GOTO 4202
12895                                     ENDIF
12896                                     NSV           = NSV+1
12897                                     ISKPCH(4,NSV) = 0
12898                                     INTSV1(NSV)   = JJ
12899                                     INTSV2(NSV)   = IXVTA
12900 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
12901 *           the actual chain masses
12902                                     AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA)
12903      &                                                     *ECM**2
12904                                     AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA)
12905      &                                                     *ECM**2
12906 *           get lower mass cuts
12907                                     IF (IPSQ(JJ).EQ.3) THEN
12908 *             q being s-quark
12909                                        AMCHK1 = AMAS
12910                                        AMCHK2 = AMIS
12911                                     ELSE
12912 *             q being u/d-quark
12913                                        AMCHK1 = AMAU
12914                                        AMCHK2 = AMIU
12915                                     ENDIF
12916 *           q-qq chain
12917 *             chain mass above minimum - resampling of sea-q x-value
12918                                     IF (AMSVQ1.GT.AMCHK1) THEN
12919                                        XPSQTH      =
12920      &                                    AMCHK1/(XTVD(IXVTA)*ECM**2)
12921 **sr 8.4.98 (1/sqrt(x))
12922                                        XPSQXX      =
12923      &                                    DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW)
12924 C    &                                    DT_SAMSQX(XPSQTH,XPSQ(JJ))
12925 C    &                                    DT_SAMPEX(XPSQTH,XPSQ(JJ))
12926 **
12927                                        XPVD(IPVAL) =
12928      &                                    XPVD(IPVAL)+XPSQ(JJ)-XPSQXX
12929                                        XPSQ(JJ)    = XPSQXX
12930 *             chain mass below minimum - reset sea-q x-value and correct
12931 *                                        diquark-x of the same nucleon
12932                                     ELSEIF (AMSVQ1.LT.AMCHK1) THEN
12933                                        XPSQW =
12934      &                                    AMCHK1/(XTVD(IXVTA)*ECM**2)
12935                                        DXPSQ = XPSQW-XPSQ(JJ)
12936                                        IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
12937      &                                                            THEN
12938                                           XPVD(IPVAL) =
12939      &                                       XPVD(IPVAL)-DXPSQ
12940                                           XPSQ(JJ)    = XPSQW
12941                                        ENDIF
12942                                     ENDIF
12943 *           aq-q chain
12944 *             chain mass below minimum - reset sea-aq x-value and correct
12945 *                                        diquark-x of the same nucleon
12946                                     IF (AMSVQ2.LT.AMCHK2) THEN
12947                                        XPSQW =
12948      &                                    AMCHK2/(XTVQ(IXVTA)*ECM**2)
12949                                        DXPSQ = XPSQW-XPSAQ(JJ)
12950                                        IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
12951      &                                                            THEN
12952                                           XPVD(IPVAL) =
12953      &                                       XPVD(IPVAL)-DXPSQ
12954                                           XPSAQ(JJ)   = XPSQW
12955                                        ENDIF
12956                                     ENDIF
12957 *>>>>>>>>>>>end of chain mass correction
12958  4202                               CONTINUE
12959
12960 *         (b) assign new v-s chains
12961 *         ~~~~~~~~~~~~~~~~~~~~~~~~~
12962                                     IF (LSEADI.AND.(
12963      &                                  DT_RNDM(AMSVQ2).GT.FRCDIQ))
12964      &                                                             THEN
12965 *           sample sea-diquark pair
12966                                        CALL DT_SAMSDQ(ECM,IXVPR,J,1,
12967      &                                                      IREJ1)
12968                                        IF (IREJ1.EQ.0) GOTO 4203
12969                                     ENDIF
12970                                     NVS           = NVS+1
12971                                     ISKPCH(6,NVS) = 0
12972                                     INTVS1(NVS)   = IXVPR
12973                                     INTVS2(NVS)   = J
12974 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
12975 *           the actual chain masses
12976                                     AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2
12977                                     AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2
12978 *           get lower mass cuts
12979                                     IF (ITSQ(J).EQ.3) THEN
12980 *             q being s-quark
12981                                        AMCHK1 = AMIS
12982                                        AMCHK2 = AMAS
12983                                     ELSE
12984 *             q being u/d-quark
12985                                        AMCHK1 = AMIU
12986                                        AMCHK2 = AMAU
12987                                     ENDIF
12988 *           q-aq chain
12989 *             chain mass below minimum - reset sea-aq x-value and correct
12990 *                                        diquark-x of the same nucleon
12991                                     IF (AMVSQ1.LT.AMCHK1) THEN
12992                                        XTSQW =
12993      &                                    AMCHK1/(XPVQ(IXVPR)*ECM**2)
12994                                        DXTSQ = XTSQW-XTSAQ(J)
12995                                        IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
12996      &                                                            THEN
12997                                           XTVD(ITVAL) =
12998      &                                       XTVD(ITVAL)-DXTSQ
12999                                           XTSAQ(J)    = XTSQW
13000                                        ENDIF
13001                                     ENDIF
13002                                     IF (AMVSQ2.GT.AMCHK2) THEN
13003                                        XTSQTH      =
13004      &                                    AMCHK2/(XPVD(IXVPR)*ECM**2)
13005 **sr 8.4.98 (1/sqrt(x))
13006                                        XTSQXX      =
13007      &                                    DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13008 C    &                                    DT_SAMSQX(XTSQTH,XTSQ(J))
13009 C    &                                    DT_SAMPEX(XTSQTH,XTSQ(J))
13010 **
13011                                        XTVD(ITVAL) =
13012      &                                    XTVD(ITVAL)+XTSQ(J)-XTSQXX
13013                                        XTSQ(J)     = XTSQXX
13014                                     ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13015                                        XTSQW =
13016      &                                    AMCHK2/(XPVD(IXVPR)*ECM**2)
13017                                        DXTSQ = XTSQW-XTSQ(J)
13018                                        IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13019      &                                                            THEN
13020                                           XTVD(ITVAL) =
13021      &                                       XTVD(ITVAL)-DXTSQ
13022                                           XTSQ(J)     = XTSQW
13023                                        ENDIF
13024                                     ENDIF
13025 *>>>>>>>>>end of chain mass correction
13026  4203                               CONTINUE
13027 *       jump out of s-s chain loop
13028                                     GOTO 420
13029                                  ENDIF
13030                               ENDIF
13031  4201                      CONTINUE
13032                         ENDIF
13033 *---->end of chain recombination option
13034
13035 *     sample sea-diquark pair (projectile)
13036                         IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN
13037                            CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1)
13038                            IF (IREJ1.EQ.0) THEN
13039                               ISKPCH(1,NSS) = 99
13040                               GOTO 410
13041                            ENDIF
13042                         ENDIF
13043 *     sample sea-diquark pair (target)
13044                         IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13045                            CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1)
13046                            IF (IREJ1.EQ.0) THEN
13047                               ISKPCH(1,NSS) = 99
13048                               GOTO 410
13049                            ENDIF
13050                         ENDIF
13051 *>>>>>correct chain kinematics according to minimum chain masses
13052 *     the actual chain masses
13053                         SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2
13054                         SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2
13055 *     check for lower mass cuts
13056                         IF ((SSMA1Q.LT.SSMIMQ).OR.
13057      &                      (SSMA2Q.LT.SSMIMQ)) THEN
13058                            IPVAL = ITOVP(INTER1(I))
13059                            ITVAL = ITOVT(INTER2(I))
13060                            IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND.
13061      &                         (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN
13062 *       maximum allowed x values for sea quarks
13063                               XSPMAX = ONE-XPVQ(IPVAL)-XDTHR-
13064      &                                           1.2D0*XSSTHR
13065                               XSTMAX = ONE-XTVQ(ITVAL)-XDTHR-
13066      &                                           1.2D0*XSSTHR
13067 *       resampling of x values not possible - skip sea-sea chains
13068                               IF ((XSPMAX.LE.XSSTHR+0.05D0).OR.
13069      &                            (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380
13070 *       resampling of x for projectile sea quark pair
13071                               ICOUS = 0
13072   310                         CONTINUE
13073                               ICOUS = ICOUS+1
13074                               IF (XSSTHR.GT.0.05D0) THEN
13075                                  XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13076      &                                                         XSPMAX)
13077                                  XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13078      &                                                         XSPMAX)
13079                               ELSE
13080   320                            CONTINUE
13081                                  XPSQI = DT_DBETAR(XSEACU,UNOSEA)
13082                                  IF ((XPSQI.LT.XSSTHR).OR.
13083      &                               (XPSQI.GT.XSPMAX))  GOTO 320
13084   330                            CONTINUE
13085                                  XPSAQI = DT_DBETAR(XSEACU,UNOSEA)
13086                                  IF ((XPSAQI.LT.XSSTHR).OR.
13087      &                               (XPSAQI.GT.XSPMAX)) GOTO 330
13088                               ENDIF
13089 *       final test of remaining x for projectile diquark
13090                               XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI
13091      &                                            +XPSQ(JJ)+XPSAQ(JJ)
13092                               IF (XPVDCO.LE.XDTHR) THEN
13093 *!!!
13094 C                                IF (ICOUS.LT.5) GOTO 310
13095                                  IF (ICOUS.LT.0.5D0) GOTO 310
13096                                  GOTO 380
13097                               ENDIF
13098 *       resampling of x for target sea quark pair
13099                               ICOUS = 0
13100   350                         CONTINUE
13101                               ICOUS = ICOUS+1
13102                               IF (XSSTHR.GT.0.05D0) THEN
13103                                  XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13104      &                                                         XSTMAX)
13105                                  XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13106      &                                                         XSTMAX)
13107                               ELSE
13108   360                            CONTINUE
13109                                  XTSQI = DT_DBETAR(XSEACU,UNOSEA)
13110                                  IF ((XTSQI.LT.XSSTHR).OR.
13111      &                               (XTSQI.GT.XSTMAX))  GOTO 360
13112   370                            CONTINUE
13113                                  XTSAQI = DT_DBETAR(XSEACU,UNOSEA)
13114                                  IF ((XTSAQI.LT.XSSTHR).OR.
13115      &                               (XTSAQI.GT.XSTMAX)) GOTO 370
13116                               ENDIF
13117 *       final test of remaining x for target diquark
13118                               XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI
13119      &                                            +XTSQ(J)+XTSAQ(J)
13120                               IF (XTVDCO.LT.XDTHR) THEN
13121                                  IF (ICOUS.LT.5) GOTO 350
13122                                  GOTO 380
13123                               ENDIF
13124                               XPVD(IPVAL) = XPVDCO
13125                               XTVD(ITVAL) = XTVDCO
13126                               XPSQ(JJ)    = XPSQI
13127                               XPSAQ(JJ)   = XPSAQI
13128                               XTSQ(J)     = XTSQI
13129                               XTSAQ(J)    = XTSAQI
13130 *>>>>>end of chain mass correction
13131                               GOTO 410
13132                            ENDIF
13133 *     come here to discard s-s interaction
13134 *     resampling of x values not allowed or unsuccessful
13135   380                      CONTINUE
13136                            INTLO(I)  = .FALSE.
13137                            ZUOST(J)  = .TRUE.
13138                            ZUOSP(JJ) = .TRUE.
13139                            NSS       = NSS-1
13140                         ENDIF
13141 *   consider next s-s interaction
13142                         GOTO 410
13143                      ENDIF
13144   390             CONTINUE
13145                ENDIF
13146   400       CONTINUE
13147          ENDIF
13148   410    CONTINUE
13149   420 CONTINUE
13150
13151 * correct x-values of valence quarks for non-matching sea quarks
13152       DO 430 I=1,IXPS
13153          IF (ZUOSP(I)) THEN
13154             IPVAL       = ITOVP(IFROSP(I))
13155             XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I)
13156             XPSQ(I)     = ZERO
13157             XPSAQ(I)    = ZERO
13158             ZUOSP(I)    = .FALSE.
13159          ENDIF
13160   430 CONTINUE
13161       DO 440 I=1,IXTS
13162          IF (ZUOST(I)) THEN
13163             ITVAL       = ITOVT(IFROST(I))
13164             XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I)
13165             XTSQ(I)     = ZERO
13166             XTSAQ(I)    = ZERO
13167             ZUOST(I)    = .FALSE.
13168          ENDIF
13169   440 CONTINUE
13170       DO 450 I=1,IXPV
13171          IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13
13172   450 CONTINUE
13173       DO 460 I=1,IXTV
13174          IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14
13175   460 CONTINUE
13176
13177       RETURN
13178       END
13179
13180 *$ CREATE DT_SAMSDQ.FOR
13181 *COPY DT_SAMSDQ
13182 *
13183 *===samsdq=============================================================*
13184 *
13185       SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ)
13186
13187 ************************************************************************
13188 * SAMpling of Sea-DiQuarks                                             *
13189 *              ECM        cm-energy of the nucleon-nucleon system      *
13190 *              IDX1,2     indices of x-values of the participating     *
13191 *                         partons (IDX2 is always the sea-q-pair to be *
13192 *                         changed to sea-qq-pair)                      *
13193 *              MODE       = 1  valence-q - sea-diq                     *
13194 *                         = 2  sea-diq   - valence-q                   *
13195 *                         = 3  sea-q     - sea-diq                     *
13196 *                         = 4  sea-diq   - sea-q                       *
13197 * Based on DIQVS, DIQSV, DIQSSD, DIQDSS.                               *
13198 * This version dated 17.10.95 is written by S. Roesler                 *
13199 ************************************************************************
13200
13201       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13202       SAVE
13203
13204       PARAMETER (ZERO=0.0D0)
13205
13206 * threshold values for x-sampling (DTUNUC 1.x)
13207       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
13208      &                SSMIMQ,VVMTHR
13209 * various options for treatment of partons (DTUNUC 1.x)
13210 * (chain recombination, Cronin,..)
13211       LOGICAL LCO2CR,LINTPT
13212       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
13213      &                LCO2CR,LINTPT
13214       PARAMETER ( MAXNCL = 260,
13215      &            MAXVQU = MAXNCL,
13216      &            MAXSQU = 20*MAXVQU,
13217      &            MAXINT = MAXVQU+MAXSQU)
13218 * x-values of partons (DTUNUC 1.x)
13219       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
13220      &                XTVQ(MAXVQU),XTVD(MAXVQU),
13221      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
13222      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
13223 * flavors of partons (DTUNUC 1.x)
13224       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
13225      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
13226      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
13227      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
13228      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
13229      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
13230      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
13231 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13232       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
13233      &                IXPV,IXPS,IXTV,IXTS,
13234      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
13235      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
13236      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
13237      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
13238      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
13239      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
13240      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
13241      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
13242 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13243       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
13244      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
13245 * auxiliary common for chain system storage (DTUNUC 1.x)
13246       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
13247
13248       IREJ = 0
13249 *  threshold-x for valence diquarks
13250       XDTHR = CDQ/ECM
13251
13252       GOTO (1,2,3,4) MODE
13253
13254 *---------------------------------------------------------------------
13255 * proj. valence partons - targ. sea partons
13256 * get x-values and flavors for target sea-diquark pair
13257
13258     1 CONTINUE
13259       IDXVP = IDX1
13260       IDXST = IDX2
13261
13262 *  index of corr. val-diquark-x in target nucleon
13263       IDXVT = ITOVT(IFROST(IDXST))
13264 *  available x above diquark thresholds for valence- and sea-diquarks
13265       XXD   = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13266
13267       IF (XXD.GE.ZERO) THEN
13268 *  x-values for the three diquarks of the target nucleon
13269          RR1    = DT_RNDM(XXD)
13270          RR2    = DT_RNDM(RR1)
13271          RR3    = DT_RNDM(RR2)
13272          SR123  = RR1+RR2+RR3
13273          XXTV   = XDTHR+RR1*XXD/SR123
13274          XXTSQ  = XDTHR+RR2*XXD/SR123
13275          XXTSAQ = XDTHR+RR3*XXD/SR123
13276       ELSE
13277          XXTV   = XTVD(IDXVT)
13278          XXTSQ  = XTSQ(IDXST)
13279          XXTSAQ = XTSAQ(IDXST)
13280       ENDIF
13281 *  flavor of the second quarks in the sea-diquark pair
13282       ITSQ2(IDXST)  = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13283       ITSAQ2(IDXST) = -ITSQ2(IDXST)
13284 *  check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains
13285       AM1    = XXTSQ *XPVQ(IDXVP)*ECM**2
13286       AM2    = XXTSAQ*XPVD(IDXVP)*ECM**2
13287       IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13288 *    ss-asas pair
13289      &     ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0))            ) THEN
13290          IREJ = 1
13291          RETURN
13292       ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13293 *    at least one strange quark
13294      &         ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0))        ) THEN
13295          IREJ = 1
13296          RETURN
13297       ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13298          IREJ = 1
13299          RETURN
13300       ENDIF
13301 *  accept the new sea-diquark
13302       XTVD(IDXVT)   = XXTV
13303       XTSQ(IDXST)   = XXTSQ
13304       XTSAQ(IDXST)  = XXTSAQ
13305       NVD           = NVD+1
13306       INTVD1(NVD)   = IDXVP
13307       INTVD2(NVD)   = IDXST
13308       ISKPCH(7,NVD) = 0
13309       RETURN
13310
13311 *---------------------------------------------------------------------
13312 * proj. sea partons - targ. valence partons
13313 * get x-values and flavors for projectile sea-diquark pair
13314
13315     2 CONTINUE
13316       IDXSP = IDX2
13317       IDXVT = IDX1
13318
13319 *  index of corr. val-diquark-x in projectile nucleon
13320       IDXVP = ITOVP(IFROSP(IDXSP))
13321 *  available x above diquark thresholds for valence- and sea-diquarks
13322       XXD   = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13323
13324       IF (XXD.GE.ZERO) THEN
13325 *  x-values for the three diquarks of the projectile nucleon
13326          RR1    = DT_RNDM(XXD)
13327          RR2    = DT_RNDM(RR1)
13328          RR3    = DT_RNDM(RR2)
13329          SR123  = RR1+RR2+RR3
13330          XXPV   = XDTHR+RR1*XXD/SR123
13331          XXPSQ  = XDTHR+RR2*XXD/SR123
13332          XXPSAQ = XDTHR+RR3*XXD/SR123
13333       ELSE
13334          XXPV   = XPVD(IDXVP)
13335          XXPSQ  = XPSQ(IDXSP)
13336          XXPSAQ = XPSAQ(IDXSP)
13337       ENDIF
13338 *  flavor of the second quarks in the sea-diquark pair
13339       IPSQ2(IDXSP)  = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13340       IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13341 *  check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains
13342       AM1    = XXPSQ *XTVQ(IDXVT)*ECM**2
13343       AM2    = XXPSAQ*XTVD(IDXVT)*ECM**2
13344       IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13345 *    ss-asas pair
13346      &     ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0))            ) THEN
13347          IREJ = 1
13348          RETURN
13349       ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13350 *    at least one strange quark
13351      &         ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0))        ) THEN
13352          IREJ = 1
13353          RETURN
13354       ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13355          IREJ = 1
13356          RETURN
13357       ENDIF
13358 *  accept the new sea-diquark
13359       XPVD(IDXVP)   = XXPV
13360       XPSQ(IDXSP)   = XXPSQ
13361       XPSAQ(IDXSP)  = XXPSAQ
13362       NDV           = NDV+1
13363       INTDV1(NDV)   = IDXSP
13364       INTDV2(NDV)   = IDXVT
13365       ISKPCH(5,NDV) = 0
13366       RETURN
13367
13368 *---------------------------------------------------------------------
13369 * proj. sea partons - targ. sea partons
13370 * get x-values and flavors for target sea-diquark pair
13371
13372     3 CONTINUE
13373       IDXSP = IDX1
13374       IDXST = IDX2
13375
13376 *  index of corr. val-diquark-x in target nucleon
13377       IDXVT = ITOVT(IFROST(IDXST))
13378 *  available x above diquark thresholds for valence- and sea-diquarks
13379       XXD   = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13380
13381       IF (XXD.GE.ZERO) THEN
13382 *  x-values for the three diquarks of the target nucleon
13383          RR1    = DT_RNDM(XXD)
13384          RR2    = DT_RNDM(RR1)
13385          RR3    = DT_RNDM(RR2)
13386          SR123  = RR1+RR2+RR3
13387          XXTV   = XDTHR+RR1*XXD/SR123
13388          XXTSQ  = XDTHR+RR2*XXD/SR123
13389          XXTSAQ = XDTHR+RR3*XXD/SR123
13390       ELSE
13391          XXTV   = XTVD(IDXVT)
13392          XXTSQ  = XTSQ(IDXST)
13393          XXTSAQ = XTSAQ(IDXST)
13394       ENDIF
13395 *  flavor of the second quarks in the sea-diquark pair
13396       ITSQ2(IDXST)  = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13397       ITSAQ2(IDXST) = -ITSQ2(IDXST)
13398 *  check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains
13399       AM1    = XXTSQ *XPSQ(IDXSP)*ECM**2
13400       AM2    = XXTSAQ*XPSAQ(IDXSP)*ECM**2
13401       IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13402 *    ss-asas pair
13403      &     ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0))            ) THEN
13404          IREJ = 1
13405          RETURN
13406       ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13407 *    at least one strange quark
13408      &         ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0))        ) THEN
13409          IREJ = 1
13410          RETURN
13411       ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13412          IREJ = 1
13413          RETURN
13414       ENDIF
13415 *  accept the new sea-diquark
13416       XTVD(IDXVT)   = XXTV
13417       XTSQ(IDXST)   = XXTSQ
13418       XTSAQ(IDXST)  = XXTSAQ
13419       NSD           = NSD+1
13420       INTSD1(NSD)   = IDXSP
13421       INTSD2(NSD)   = IDXST
13422       ISKPCH(3,NSD) = 0
13423       RETURN
13424
13425 *---------------------------------------------------------------------
13426 * proj. sea partons - targ. sea partons
13427 * get x-values and flavors for projectile sea-diquark pair
13428
13429     4 CONTINUE
13430       IDXSP = IDX2
13431       IDXST = IDX1
13432
13433 *  index of corr. val-diquark-x in projectile nucleon
13434       IDXVP = ITOVP(IFROSP(IDXSP))
13435 *  available x above diquark thresholds for valence- and sea-diquarks
13436       XXD   = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13437
13438       IF (XXD.GE.ZERO) THEN
13439 *  x-values for the three diquarks of the projectile nucleon
13440          RR1    = DT_RNDM(XXD)
13441          RR2    = DT_RNDM(RR1)
13442          RR3    = DT_RNDM(RR2)
13443          SR123  = RR1+RR2+RR3
13444          XXPV   = XDTHR+RR1*XXD/SR123
13445          XXPSQ  = XDTHR+RR2*XXD/SR123
13446          XXPSAQ = XDTHR+RR3*XXD/SR123
13447       ELSE
13448          XXPV   = XPVD(IDXVP)
13449          XXPSQ  = XPSQ(IDXSP)
13450          XXPSAQ = XPSAQ(IDXSP)
13451       ENDIF
13452 *  flavor of the second quarks in the sea-diquark pair
13453       IPSQ2(IDXSP)  = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13454       IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13455 *  check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains
13456       AM1    = XXPSQ *XTSQ(IDXST)*ECM**2
13457       AM2    = XXPSAQ*XTSAQ(IDXST)*ECM**2
13458       IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13459 *    ss-asas pair
13460      &     ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0))            ) THEN
13461          IREJ = 1
13462          RETURN
13463       ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13464 *    at least one strange quark
13465      &         ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0))        ) THEN
13466          IREJ = 1
13467          RETURN
13468       ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13469          IREJ = 1
13470          RETURN
13471       ENDIF
13472 *  accept the new sea-diquark
13473       XPVD(IDXVP)   = XXPV
13474       XPSQ(IDXSP)   = XXPSQ
13475       XPSAQ(IDXSP)  = XXPSAQ
13476       NDS           = NDS+1
13477       INTDS1(NDS)   = IDXSP
13478       INTDS2(NDS)   = IDXST
13479       ISKPCH(2,NDS) = 0
13480       RETURN
13481       END
13482
13483 *$ CREATE DT_DIFEVT.FOR
13484 *COPY DT_DIFEVT
13485 *
13486 *===difevt=============================================================*
13487 *
13488       SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP,
13489      &                  IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ)
13490
13491 ************************************************************************
13492 * Interface to treatment of diffractive interactions.                  *
13493 *  (input)          IFP1/2        PDG-indizes of projectile partons    *
13494 *                                 (baryon: IFP2 - adiquark)            *
13495 *                   PP(4)         projectile 4-momentum                *
13496 *                   IFT1/2        PDG-indizes of target partons        *
13497 *                                 (baryon: IFT1 - adiquark)            *
13498 *                   PT(4)         target 4-momentum                    *
13499 *  (output)         JDIFF = 0     no diffraction                       *
13500 *                         = 1/-1  LMSD/LMDD                            *
13501 *                         = 2/-2  HMSD/HMDD                            *
13502 *                   NCSY          counter for two-chain systems        *
13503 *                                 dumped to DTEVT1                     *
13504 * This version dated 14.02.95 is written by S. Roesler                 *
13505 ************************************************************************
13506
13507       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13508       SAVE
13509       PARAMETER ( LINP = 10 ,
13510      &            LOUT = 6 ,
13511      &            LDAT = 9 )
13512       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5,
13513      &           OHALF=0.5D0)
13514
13515 * event history
13516       PARAMETER (NMXHKK=200000)
13517       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
13518      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
13519      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
13520 * extended event history
13521       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
13522      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
13523      &                IHIST(2,NMXHKK)
13524 * flags for diffractive interactions (DTUNUC 1.x)
13525       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
13526
13527       DIMENSION PP(4),PT(4)
13528
13529       LOGICAL LFIRST
13530       DATA LFIRST /.TRUE./
13531
13532       IREJ   = 0
13533       JDIFF  = 0
13534       IFLAGD = JDIFF
13535
13536 * cm. energy
13537       XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
13538      &          (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
13539 * identities of projectile hadron / target nucleon
13540       KPROJ = IDT_ICIHAD(IDHKK(MOP))
13541       KTARG = IDT_ICIHAD(IDHKK(MOT))
13542
13543 * single diffractive xsections
13544       CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM)
13545 * double diffractive xsections
13546 **!! no double diff yet
13547 C     CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM)
13548       DDTOT = 0.0D0
13549       DDHM  = 0.0D0
13550 **!!
13551 * total inelastic xsection
13552 C     SIGIN  = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM)
13553       DUMZER = ZERO
13554       CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL)
13555       SIGIN  = MAX(SIGTO-SIGEL,ZERO)
13556
13557 * fraction of diffractive processes
13558       FRADIF = (SDTOT+DDTOT)/SIGIN
13559
13560       IF (LFIRST) THEN
13561          WRITE(LOUT,1000) XM,SDTOT,SIGIN
13562  1000    FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ',
13563      &          F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ',
13564      &          F5.1,' mb',/)
13565          LFIRST = .FALSE.
13566       ENDIF
13567
13568       IF ((DT_RNDM(DDHM).LE.FRADIF).OR.
13569      &    (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN
13570 * diffractive interaction requested by x-section or by user
13571          FRASD  = SDTOT/(SDTOT+DDTOT)
13572          FRASDH = SDHM/SDTOT
13573 **sr needs to be specified!!
13574 C        FRADDH = DDHM/DDTOT
13575          FRADDH = 1.0D0
13576 **
13577          IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN
13578 *   single diffraction
13579             KDIFF = 1
13580             IF (DT_RNDM(DDTOT).LE.FRASDH) THEN
13581                KP = 2
13582                KT = 0
13583                IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND.
13584      &               ISINGD.NE.3) THEN
13585                   KP = 0
13586                   KT = 2
13587                ENDIF
13588             ELSE
13589                KP = 1
13590                KT = 0
13591                IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND.
13592      &               ISINGD.NE.3) THEN
13593                   KP = 0
13594                   KT = 1
13595                ENDIF
13596             ENDIF
13597          ELSE
13598 *   double diffraction
13599             KDIFF = -1
13600             IF (DT_RNDM(FRADDH).LE.FRADDH) THEN
13601                KP = 2
13602                KT = 2
13603             ELSE
13604                KP = 1
13605                KT = 1
13606             ENDIF
13607          ENDIF
13608          CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13609      &               IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13610          IF (IREJ1.EQ.0) THEN
13611             IFLAGD = 2*KDIFF
13612             IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF
13613          ELSE
13614             GOTO 9999
13615          ENDIF
13616       ENDIF
13617       JDIFF = IFLAGD
13618
13619       RETURN
13620
13621  9999 CONTINUE
13622       IREJ  = 1
13623       RETURN
13624       END
13625
13626 *$ CREATE DT_DIFFKI.FOR
13627 *COPY DT_DIFFKI
13628 *
13629 *===difkin=============================================================*
13630 *
13631       SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13632      &                  IFT1,IFT2,PT,MOT,KT,NCSY,IREJ)
13633
13634 ************************************************************************
13635 * Kinematics of diffractive nucleon-nucleon interaction.               *
13636 *          IFP1/2   PDG-indizes of projectile partons                  *
13637 *                   (baryon: IFP2 - adiquark)                          *
13638 *          PP(4)    projectile 4-momentum                              *
13639 *          IFT1/2   PDG-indizes of target partons                      *
13640 *                   (baryon: IFT1 - adiquark)                          *
13641 *          PT(4)    target 4-momentum                                  *
13642 *          KP   = 0 projectile quasi-elastically scattered             *
13643 *               = 1            excited to low-mass diff. state         *
13644 *               = 2            excited to high-mass diff. state        *
13645 *          KT   = 0 target     quasi-elastically scattered             *
13646 *               = 1            excited to low-mass diff. state         *
13647 *               = 2            excited to high-mass diff. state        *
13648 * This version dated 12.02.95 is written by S. Roesler                 *
13649 ************************************************************************
13650
13651       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13652       SAVE
13653       PARAMETER ( LINP = 10 ,
13654      &            LOUT = 6 ,
13655      &            LDAT = 9 )
13656       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5)
13657
13658       LOGICAL LSTART
13659
13660 * particle properties (BAMJET index convention)
13661       CHARACTER*8  ANAME
13662       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
13663      &                IICH(210),IIBAR(210),K1(210),K2(210)
13664 * flags for input different options
13665       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
13666       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
13667      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
13668 * rejection counter
13669       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
13670      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
13671      &                IREXCI(3),IRDIFF(2),IRINC
13672 * kinematics of diffractive interactions (DTUNUC 1.x)
13673       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13674      &                PPF(4),PTF(4),
13675      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13676      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13677
13678       DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4),
13679      &          PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4)
13680
13681       DATA LSTART /.TRUE./
13682
13683       IF (LSTART) THEN
13684          WRITE(LOUT,2000)
13685  2000    FORMAT(/,1X,'DIFEVT:  diffractive interactions treated ')
13686          LSTART = .FALSE.
13687       ENDIF
13688
13689       IREJ = 0
13690
13691 * initialize common /DTDIKI/
13692       CALL DT_DIFINI
13693 * store momenta of initial incoming particles for emc-check
13694       IF (LEMCCK) THEN
13695          CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM)
13696          CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM)
13697       ENDIF
13698
13699 * masses of initial particles
13700       XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2
13701       XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2
13702       IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999
13703       XMP  = SQRT(XMP2)
13704       XMT  = SQRT(XMT2)
13705 * check quark-input (used to adjust coherence cond. for M-selection)
13706       IBP  = 0
13707       IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1
13708       IBT  = 0
13709       IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1
13710
13711 * parameter for Lorentz-transformation into nucleon-nucleon cms
13712       DO 3 K=1,4
13713          PITOT(K) = PP(K)+PT(K)
13714     3 CONTINUE
13715       XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2
13716       IF (XMTOT2.LE.ZERO) THEN
13717          WRITE(LOUT,1000) XMTOT2
13718  1000    FORMAT(1X,'DIFEVT:   negative cm. energy!  ',
13719      &          'XMTOT2 = ',E12.3)
13720          GOTO 9999
13721       ENDIF
13722       XMTOT = SQRT(XMTOT2)
13723       DO 4 K=1,4
13724          BGTOT(K) = PITOT(K)/XMTOT
13725     4 CONTINUE
13726 * transformation of nucleons into cms
13727       CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2),
13728      &            PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4))
13729       CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2),
13730      &            PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4))
13731 * rotation angles
13732       COD = PP1(3)/PPTOT
13733 C     SID = SQRT((ONE-COD)*(ONE+COD))
13734       PPT = SQRT(PP1(1)**2+PP1(2)**2)
13735       SID = PPT/PPTOT
13736       COF = ONE
13737       SIF = ZERO
13738       IF(PPTOT*SID.GT.TINY10) THEN
13739          COF   = PP1(1)/(SID*PPTOT)
13740          SIF   = PP1(2)/(SID*PPTOT)
13741          ANORF = SQRT(COF*COF+SIF*SIF)
13742          COF   = COF/ANORF
13743          SIF   = SIF/ANORF
13744       ENDIF
13745 * check consistency
13746       DO 5 K=1,4
13747          DEV1(K) = ABS(PP1(K)+PT1(K))
13748     5 CONTINUE
13749       DEV1(4) = ABS(DEV1(4)-XMTOT)
13750       IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR.
13751      &    (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10))     THEN
13752          WRITE(LOUT,1001) DEV1
13753  1001    FORMAT(1X,'DIFEVT:   inconsitent Lorentz-transformation! ',
13754      &          /,8X,4E12.3)
13755          GOTO 9999
13756       ENDIF
13757
13758 * select x-fractions in high-mass diff. interactions
13759       IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT)
13760
13761 * select diffractive masses
13762 * - projectile
13763       IF (KP.EQ.1) THEN
13764          XMPF = DT_XMLMD(XMTOT)
13765          CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1)
13766          IF (IREJ1.GT.0) GOTO 9999
13767       ELSEIF (KP.EQ.2) THEN
13768          XMPF = DT_XMHMD(XMTOT,IBP,1)
13769       ELSE
13770          XMPF = XMP
13771       ENDIF
13772 * - target
13773       IF (KT.EQ.1) THEN
13774          XMTF = DT_XMLMD(XMTOT)
13775          CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1)
13776          IF (IREJ1.GT.0) GOTO 9999
13777       ELSEIF (KT.EQ.2) THEN
13778          XMTF = DT_XMHMD(XMTOT,IBT,2)
13779       ELSE
13780          XMTF = XMT
13781       ENDIF
13782
13783 * kinematical treatment of "two-particle" system (masses - XMPF,XMTF)
13784       XMPF2 = XMPF**2
13785       XMTF2 = XMTF**2
13786       PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT)
13787       PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2)
13788
13789 * select momentum transfer (all t-values used here are <0)
13790 *   minimum absolute value to produce diffractive masses
13791       TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3))
13792       TT   = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1)
13793       IF (IREJ1.GT.0) GOTO 9999
13794
13795 * longitudinal momentum of excited/elastically scattered projectile
13796       PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT)
13797 * total transverse momentum due to t-selection
13798       PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2
13799       IF (PPBLT2.LT.ZERO) THEN
13800          WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT
13801  1002    FORMAT(1X,'DIFEVT:   inconsistent transverse momentum! ',
13802      &          E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3)
13803          GOTO 9999
13804       ENDIF
13805       CALL DT_DSFECF(SINPHI,COSPHI)
13806       PPBLT     = SQRT(PPBLT2)
13807       PPBLOB(1) = COSPHI*PPBLT
13808       PPBLOB(2) = SINPHI*PPBLT
13809
13810 * rotate excited/elastically scattered projectile into n-n cms.
13811       CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF,
13812      &                                                    XX,YY,ZZ)
13813       PPBLOB(1) = XX
13814       PPBLOB(2) = YY
13815       PPBLOB(3) = ZZ
13816
13817 * 4-momentum of excited/elastically scattered target and of exchanged
13818 * Pomeron
13819       DO 6 K=1,4
13820          IF (K.LT.4) PTBLOB(K) = -PPBLOB(K)
13821          PPOM1(K) = PP1(K)-PPBLOB(K)
13822     6 CONTINUE
13823       PTBLOB(4) = XMTOT-PPBLOB(4)
13824
13825 * Lorentz-transformation back into system of initial diff. collision
13826       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13827      &            PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4),
13828      &            PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4))
13829       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13830      &            PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4),
13831      &            PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4))
13832       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13833      &            PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4),
13834      &            PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4))
13835
13836 * store 4-momentum of elastically scattered particle (in single diff.
13837 * events)
13838       IF (KP.EQ.0) THEN
13839          DO 7 K=1,4
13840             PSC(K) = PPF(K)
13841     7    CONTINUE
13842       ELSEIF (KT.EQ.0) THEN
13843          DO 8 K=1,4
13844             PSC(K) = PTF(K)
13845     8    CONTINUE
13846       ENDIF
13847
13848 * check consistency of kinematical treatment so far
13849       IF (LEMCCK) THEN
13850          CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM)
13851          CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM)
13852          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1)
13853          IF (IREJ1.NE.0) GOTO 9999
13854       ENDIF
13855       DO 9 K=1,4
13856          DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K))
13857          DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K))
13858     9 CONTINUE
13859       IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR.
13860      &    (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR.
13861      &    (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR.
13862      &    (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5))     THEN
13863          WRITE(LOUT,1003) DEV1,DEV2
13864  1003    FORMAT(1X,'DIFEVT:   inconsitent kinematical treatment!  ',
13865      &          2(/,8X,4E12.3))
13866          GOTO 9999
13867       ENDIF
13868
13869 * kinematical treatment for low-mass diffraction
13870       CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1)
13871       IF (IREJ1.NE.0) GOTO 9999
13872
13873 * dump diffractive chains into DTEVT1
13874       CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13875       IF (IREJ1.NE.0) GOTO 9999
13876
13877       RETURN
13878
13879  9999 CONTINUE
13880       IRDIFF(1) = IRDIFF(1)+1
13881       IREJ      = 1
13882       RETURN
13883       END
13884
13885 *$ CREATE DT_XMHMD.FOR
13886 *COPY DT_XMHMD
13887 *
13888 *===xmhmd==============================================================*
13889 *
13890       DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE)
13891
13892 ************************************************************************
13893 * Diffractive mass in high mass single/double diffractive events.      *
13894 * This version dated 11.02.95 is written by S. Roesler                 *
13895 ************************************************************************
13896
13897       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13898       SAVE
13899       PARAMETER ( LINP = 10 ,
13900      &            LOUT = 6 ,
13901      &            LDAT = 9 )
13902       PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)
13903
13904 * kinematics of diffractive interactions (DTUNUC 1.x)
13905       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13906      &                PPF(4),PTF(4),
13907      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13908      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13909
13910 C     DATA XCOLOW /0.05D0/
13911       DATA XCOLOW /0.15D0/
13912
13913       DT_XMHMD = ZERO
13914       XH = XPH(2)
13915       IF (MODE.EQ.2) XH = XTH(2)
13916
13917 * minimum Pomeron-x for high-mass diffraction
13918 * (adjusted to get a smooth transition between HM and LM component)
13919       R = DT_RNDM(XH)
13920       XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2)
13921       IF (ECM.LE.300.0D0) THEN
13922          RR     = (1.0D0-EXP(-((ECM/140.0D0)**4)))
13923          XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2)
13924       ENDIF
13925 * maximum Pomeron-x for high-mass diffraction
13926 * (coherence condition, adjusted to fit to experimental data)
13927       IF (IB.NE.0) THEN
13928 *   baryon-diffraction
13929          XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2)))
13930       ELSE
13931 *   meson-diffraction
13932          XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2)))
13933       ENDIF
13934 * check boundaries
13935       IF (XDIMIN.GE.XDIMAX) THEN
13936          XDIMIN = OHALF*XDIMAX
13937       ENDIF
13938
13939       KLOOP = 0
13940     1 CONTINUE
13941       KLOOP = KLOOP+1
13942       IF (KLOOP.GT.20) RETURN
13943 * sample Pomeron-x from 1/x-distribution (critical Pomeron)
13944       XDIFF = DT_SAMPEX(XDIMIN,XDIMAX)
13945 * corr. diffr. mass
13946       DT_XMHMD = ECM*SQRT(XDIFF)
13947       IF (DT_XMHMD.LT.2.5D0) GOTO 1
13948
13949       RETURN
13950       END
13951
13952 *$ CREATE DT_XMLMD.FOR
13953 *COPY DT_XMLMD
13954 *
13955 *===xmlmd==============================================================*
13956 *
13957       DOUBLE PRECISION FUNCTION DT_XMLMD(ECM)
13958
13959 ************************************************************************
13960 * Diffractive mass in high mass single/double diffractive events.      *
13961 * This version dated 11.02.95 is written by S. Roesler                 *
13962 ************************************************************************
13963
13964       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13965       SAVE
13966       PARAMETER ( LINP = 10 ,
13967      &            LOUT = 6 ,
13968      &            LDAT = 9 )
13969
13970 * minimum Pomeron-x for low-mass diffraction
13971 C     AMO = 1.5D0
13972       AMO = 2.0D0
13973 * maximum Pomeron-x for low-mass diffraction
13974 * (adjusted to get a smooth transition between HM and LM component)
13975       R   = DT_RNDM(AMO)
13976       SAM = 1.0D0
13977       IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4))
13978       R   = DT_RNDM(AMO)*SAM
13979       AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0)
13980       AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX
13981
13982 * selection of diffractive mass
13983 * (adjusted to get a smooth transition between HM and LM component)
13984       R   = DT_RNDM(AMU)
13985       IF (ECM.LE.50.0D0) THEN
13986          DT_XMLMD = AMO*(AMU/AMO)**R
13987       ELSE
13988          A = 0.7D0
13989          IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2)))
13990          DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A))
13991       ENDIF
13992
13993       RETURN
13994       END
13995
13996 *$ CREATE DT_TDIFF.FOR
13997 *COPY DT_TDIFF
13998 *
13999 *===tdiff==============================================================*
14000 *
14001       DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ)
14002
14003 ************************************************************************
14004 * t-selection for single/double diffractive interactions.              *
14005 *          ECM      cm. energy                                         *
14006 *          TMIN     minimum momentum transfer to produce diff. masses  *
14007 *          XM1/XM2  diffractively produced masses                      *
14008 *                   (for single diffraction XM2 is obsolete)           *
14009 *          K1/K2= 0 not excited                                        *
14010 *               = 1 low-mass excitation                                *
14011 *               = 2 high-mass excitation                               *
14012 * This version dated 11.02.95 is written by S. Roesler                 *
14013 ************************************************************************
14014
14015       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14016       SAVE
14017       PARAMETER ( LINP = 10 ,
14018      &            LOUT = 6 ,
14019      &            LDAT = 9 )
14020       PARAMETER (ZERO=0.0D0)
14021
14022       PARAMETER ( BTP0   = 3.7D0,
14023      &            ALPHAP = 0.24D0 )
14024
14025       IREJ   = 0
14026       NCLOOP = 0
14027       DT_TDIFF  = ZERO
14028
14029       IF (K1.GT.0) THEN
14030          XM1 = XM1I
14031          XM2 = XM2I
14032       ELSE
14033          XM1 = XM2I
14034       ENDIF
14035       XDI = (XM1/ECM)**2
14036       IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN
14037 * slope for single diffraction
14038          SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI)
14039       ELSE
14040 * slope for double diffraction
14041          SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2)
14042       ENDIF
14043
14044     1 CONTINUE
14045       NCLOOP = NCLOOP+1
14046       IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999
14047       Y = DT_RNDM(XDI)
14048       T = -LOG(1.0D0-Y)/SLOPE
14049       IF (ABS(T).LE.ABS(TMIN)) GOTO 1
14050       DT_TDIFF = -ABS(T)
14051
14052       RETURN
14053
14054  9999 CONTINUE
14055       WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2
14056  1000 FORMAT(1X,'DT_TDIFF:   t-selection rejected!',/,
14057      &       1X,'ECM  = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ',
14058      &       E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2)
14059       IREJ = 1
14060       RETURN
14061       END
14062
14063 *$ CREATE DT_XVALHM.FOR
14064 *COPY DT_XVALHM
14065 *
14066 *===xvalhm=============================================================*
14067 *
14068       SUBROUTINE DT_XVALHM(KP,KT)
14069
14070 ************************************************************************
14071 * Sampling of parton x-values in high-mass diffractive interactions.   *
14072 * This version dated 12.02.95 is written by S. Roesler                 *
14073 ************************************************************************
14074
14075       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14076       SAVE
14077       PARAMETER ( LINP = 10 ,
14078      &            LOUT = 6 ,
14079      &            LDAT = 9 )
14080       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2)
14081
14082 * kinematics of diffractive interactions (DTUNUC 1.x)
14083       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14084      &                PPF(4),PTF(4),
14085      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14086      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14087 * various options for treatment of partons (DTUNUC 1.x)
14088 * (chain recombination, Cronin,..)
14089       LOGICAL LCO2CR,LINTPT
14090       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
14091      &                LCO2CR,LINTPT
14092
14093       DATA UNON,XVQTHR /2.0D0,0.8D0/
14094
14095       IF (KP.EQ.2) THEN
14096 * x-fractions of projectile valence partons
14097     1    CONTINUE
14098          XPH(1) = DT_DBETAR(OHALF,UNON)
14099          IF (XPH(1).GE.XVQTHR) GOTO 1
14100          XPH(2) = ONE-XPH(1)
14101 * x-fractions of Pomeron q-aq-pair
14102          XPOLO = TINY2
14103          XPOHI = ONE-TINY2
14104          XPPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14105          XPPO(2) = ONE-XPPO(1)
14106 * flavors of Pomeron q-aq-pair
14107          IFLAV    = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ))
14108          IFPPO(1) = IFLAV
14109          IFPPO(2) = -IFLAV
14110          IF (DT_RNDM(UNON).GT.OHALF) THEN
14111             IFPPO(1) = -IFLAV
14112             IFPPO(2) = IFLAV
14113          ENDIF
14114       ENDIF
14115
14116       IF (KT.EQ.2) THEN
14117 * x-fractions of projectile target partons
14118     2    CONTINUE
14119          XTH(1) = DT_DBETAR(OHALF,UNON)
14120          IF (XTH(1).GE.XVQTHR) GOTO 2
14121          XTH(2) = ONE-XTH(1)
14122 * x-fractions of Pomeron q-aq-pair
14123          XPOLO = TINY2
14124          XPOHI = ONE-TINY2
14125          XTPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14126          XTPO(2) = ONE-XTPO(1)
14127 * flavors of Pomeron q-aq-pair
14128          IFLAV    = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ))
14129          IFTPO(1) = IFLAV
14130          IFTPO(2) = -IFLAV
14131          IF (DT_RNDM(XPOLO).GT.OHALF) THEN
14132             IFTPO(1) = -IFLAV
14133             IFTPO(2) = IFLAV
14134          ENDIF
14135       ENDIF
14136
14137       RETURN
14138       END
14139
14140 *$ CREATE DT_LM2RES.FOR
14141 *COPY DT_LM2RES
14142 *
14143 *===lm2res=============================================================*
14144 *
14145       SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ)
14146
14147 ************************************************************************
14148 * Check low-mass diffractive excitation for resonance mass.            *
14149 *   (input)   IF1/2    PDG-indizes of valence partons                  *
14150 *   (in/out)  XM       diffractive mass requested/corrected            *
14151 *   (output)  IDR/IDXR id./BAMJET-index of resonance                   *
14152 * This version dated 12.02.95 is written by S. Roesler                 *
14153 ************************************************************************
14154
14155       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14156       SAVE
14157       PARAMETER ( LINP = 10 ,
14158      &            LOUT = 6 ,
14159      &            LDAT = 9 )
14160       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14161
14162 * kinematics of diffractive interactions (DTUNUC 1.x)
14163       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14164      &                PPF(4),PTF(4),
14165      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14166      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14167
14168       IREJ = 0
14169       IF1B = 0
14170       IF2B = 0
14171       XMI  = XM
14172
14173 * BAMJET indices of partons
14174       IF1A = IDT_IPDG2B(IF1,1,2)
14175       IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2)
14176       IF2A = IDT_IPDG2B(IF2,1,2)
14177       IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2)
14178
14179 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq)
14180       IDCH = 2
14181       IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1
14182
14183 * check for resonance mass
14184       CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1)
14185       IF (IREJ1.NE.0) GOTO 9999
14186
14187       XM = XMN
14188       RETURN
14189
14190  9999 CONTINUE
14191       IREJ = 1
14192       RETURN
14193       END
14194
14195 *$ CREATE DT_LMKINE.FOR
14196 *COPY DT_LMKINE
14197 *
14198 *===lmkine=============================================================*
14199 *
14200       SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ)
14201
14202 ************************************************************************
14203 * Kinematical treatment of low-mass excitations.                       *
14204 * This version dated 12.02.95 is written by S. Roesler                 *
14205 ************************************************************************
14206
14207       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14208       SAVE
14209       PARAMETER ( LINP = 10 ,
14210      &            LOUT = 6 ,
14211      &            LDAT = 9 )
14212       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14213
14214 * flags for input different options
14215       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14216       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14217      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14218 * kinematics of diffractive interactions (DTUNUC 1.x)
14219       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14220      &                PPF(4),PTF(4),
14221      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14222      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14223
14224       DIMENSION P1(4),P2(4)
14225
14226       IREJ = 0
14227
14228       IF (KP.EQ.1) THEN
14229          PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2)
14230          POE  = PPF(4)/PABS
14231          FAC1 = OHALF*(POE+ONE)
14232          FAC2 = -OHALF*(POE-ONE)
14233          DO 1 K=1,3
14234             PPLM1(K) = FAC1*PPF(K)
14235             PPLM2(K) = FAC2*PPF(K)
14236     1    CONTINUE
14237          PPLM1(4) = FAC1*PABS
14238          PPLM2(4) = -FAC2*PABS
14239          IF (IMSHL.EQ.1) THEN
14240             XM1 = PYMASS(IFP1)
14241             XM2 = PYMASS(IFP2)
14242             CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1)
14243             IF (IREJ1.NE.0) GOTO 9999
14244             DO 2 K=1,4
14245                PPLM1(K) = P1(K)
14246                PPLM2(K) = P2(K)
14247     2       CONTINUE
14248          ENDIF
14249       ENDIF
14250
14251       IF (KT.EQ.1) THEN
14252          PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2)
14253          POE  = PTF(4)/PABS
14254          FAC1 = OHALF*(POE+ONE)
14255          FAC2 = -OHALF*(POE-ONE)
14256          DO 3 K=1,3
14257             PTLM2(K) = FAC1*PTF(K)
14258             PTLM1(K) = FAC2*PTF(K)
14259     3    CONTINUE
14260          PTLM2(4) = FAC1*PABS
14261          PTLM1(4) = -FAC2*PABS
14262          IF (IMSHL.EQ.1) THEN
14263             XM1 = PYMASS(IFT1)
14264             XM2 = PYMASS(IFT2)
14265             CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1)
14266             IF (IREJ1.NE.0) GOTO 9999
14267             DO 4 K=1,4
14268                PTLM1(K) = P1(K)
14269                PTLM2(K) = P2(K)
14270     4       CONTINUE
14271          ENDIF
14272       ENDIF
14273
14274       RETURN
14275
14276  9999 CONTINUE
14277       WRITE(LOUT,'(A)') 'LMKINE:   kinematical treatment rejected'
14278       IREJ = 1
14279       RETURN
14280       END
14281
14282 *$ CREATE DT_DIFINI.FOR
14283 *COPY DT_DIFINI
14284 *
14285 *===difini=============================================================*
14286 *
14287       SUBROUTINE DT_DIFINI
14288
14289 ************************************************************************
14290 * Initialization of common /DTDIKI/                                    *
14291 * This version dated 12.02.95 is written by S. Roesler                 *
14292 ************************************************************************
14293
14294       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14295       SAVE
14296       PARAMETER ( LINP = 10 ,
14297      &            LOUT = 6 ,
14298      &            LDAT = 9 )
14299       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14300
14301 * kinematics of diffractive interactions (DTUNUC 1.x)
14302       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14303      &                PPF(4),PTF(4),
14304      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14305      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14306
14307       DO 1 K=1,4
14308          PPOM(K)  = ZERO
14309          PSC(K)   = ZERO
14310          PPF(K)   = ZERO
14311          PTF(K)   = ZERO
14312          PPLM1(K) = ZERO
14313          PPLM2(K) = ZERO
14314          PTLM1(K) = ZERO
14315          PTLM2(K) = ZERO
14316     1 CONTINUE
14317       DO 2 K=1,2
14318          XPH(K)   = ZERO
14319          XPPO(K)  = ZERO
14320          XTH(K)   = ZERO
14321          XTPO(K)  = ZERO
14322          IFPPO(K) = 0
14323          IFTPO(K) = 0
14324     2 CONTINUE
14325       IDPR  = 0
14326       IDXPR = 0
14327       IDTR  = 0
14328       IDXTR = 0
14329
14330       RETURN
14331       END
14332
14333 *$ CREATE DT_DIFPUT.FOR
14334 *COPY DT_DIFPUT
14335 *
14336 *===difput=============================================================*
14337 *
14338       SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,
14339      &                                                          IREJ)
14340
14341 ************************************************************************
14342 * Dump diffractive chains into DTEVT1                                  *
14343 * This version dated 12.02.95 is written by S. Roesler                 *
14344 ************************************************************************
14345
14346       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14347       SAVE
14348       PARAMETER ( LINP = 10 ,
14349      &            LOUT = 6 ,
14350      &            LDAT = 9 )
14351       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14352
14353       LOGICAL LCHK
14354
14355 * kinematics of diffractive interactions (DTUNUC 1.x)
14356       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14357      &                PPF(4),PTF(4),
14358      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14359      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14360 * event history
14361       PARAMETER (NMXHKK=200000)
14362       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14363      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14364      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14365 * extended event history
14366       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14367      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14368      &                IHIST(2,NMXHKK)
14369 * rejection counter
14370       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
14371      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
14372      &                IREXCI(3),IRDIFF(2),IRINC
14373
14374       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4),
14375      &          P1(4),P2(4),P3(4),P4(4)
14376
14377       IREJ = 0
14378
14379       IF (KP.EQ.1) THEN
14380          DO 1 K=1,4
14381             PCH(K) = PPLM1(K)+PPLM2(K)
14382     1    CONTINUE
14383          ID1 = IFP1
14384          ID2 = IFP2
14385          IF (DT_RNDM(PT).GT.OHALF) THEN
14386             ID1 = IFP2
14387             ID2 = IFP1
14388          ENDIF
14389          CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3),
14390      &                                        PPLM1(4),0,0,0)
14391          CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3),
14392      &                                        PPLM2(4),0,0,0)
14393          CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14394      &                                              IDPR,IDXPR,8)
14395       ELSEIF (KP.EQ.2) THEN
14396          DO 2 K=1,4
14397             PP1(K) = XPH(1)*PP(K)
14398             PP2(K) = XPH(2)*PP(K)
14399             PT1(K) = -XPPO(1)*PPOM(K)
14400             PT2(K) = -XPPO(2)*PPOM(K)
14401     2    CONTINUE
14402          CALL  DT_CHKCSY(IFP1,IFPPO(1),LCHK)
14403          XM1 = ZERO
14404          XM2 = ZERO
14405          IF (LCHK) THEN
14406             CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14407             IF (IREJ1.NE.0) GOTO 9999
14408             CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14409             IF (IREJ1.NE.0) GOTO 9999
14410             DO 3 K=1,4
14411                PP1(K) = P1(K)
14412                PT1(K) = P2(K)
14413                PP2(K) = P3(K)
14414                PT2(K) = P4(K)
14415     3       CONTINUE
14416             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14417      &                                                       0,0,8)
14418             CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14419      &                                             PT1(4),0,0,8)
14420             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14421      &                                                       0,0,8)
14422             CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14423      &                                             PT2(4),0,0,8)
14424          ELSE
14425             CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14426             IF (IREJ1.NE.0) GOTO 9999
14427             CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14428             IF (IREJ1.NE.0) GOTO 9999
14429             DO 4 K=1,4
14430                PP1(K) = P1(K)
14431                PT2(K) = P2(K)
14432                PP2(K) = P3(K)
14433                PT1(K) = P4(K)
14434     4       CONTINUE
14435             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14436      &                                                       0,0,8)
14437             CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14438      &                                                PT2(4),0,0,8)
14439             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14440      &                                                       0,0,8)
14441             CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14442      &                                                PT1(4),0,0,8)
14443          ENDIF
14444          NCSY = NCSY+1
14445       ELSE
14446          CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4),
14447      &                                                        0,0,0)
14448       ENDIF
14449
14450       IF (KT.EQ.1) THEN
14451          DO 5 K=1,4
14452             PCH(K) = PTLM1(K)+PTLM2(K)
14453     5    CONTINUE
14454          ID1 = IFT1
14455          ID2 = IFT2
14456          IF (DT_RNDM(PT).GT.OHALF) THEN
14457             ID1 = IFT2
14458             ID2 = IFT1
14459          ENDIF
14460          CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3),
14461      &                                              PTLM1(4),0,0,0)
14462          CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3),
14463      &                                              PTLM2(4),0,0,0)
14464          CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14465      &                                              IDTR,IDXTR,8)
14466       ELSEIF (KT.EQ.2) THEN
14467          DO 6 K=1,4
14468             PP1(K) = XTPO(1)*PPOM(K)
14469             PP2(K) = XTPO(2)*PPOM(K)
14470             PT1(K) = XTH(2)*PT(K)
14471             PT2(K) = XTH(1)*PT(K)
14472     6    CONTINUE
14473          CALL  DT_CHKCSY(IFTPO(1),IFT1,LCHK)
14474          XM1 = ZERO
14475          XM2 = ZERO
14476          IF (LCHK) THEN
14477             CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14478             IF (IREJ1.NE.0) GOTO 9999
14479             CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14480             IF (IREJ1.NE.0) GOTO 9999
14481             DO 7 K=1,4
14482                PP1(K) = P1(K)
14483                PT1(K) = P2(K)
14484                PP2(K) = P3(K)
14485                PT2(K) = P4(K)
14486     7       CONTINUE
14487             CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14488      &                                                PP1(4),0,0,8)
14489             CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14490      &                                                       0,0,8)
14491             CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14492      &                                                PP2(4),0,0,8)
14493             CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14494      &                                                       0,0,8)
14495          ELSE
14496             CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14497             IF (IREJ1.NE.0) GOTO 9999
14498             CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14499             IF (IREJ1.NE.0) GOTO 9999
14500             DO 8 K=1,4
14501                PP1(K) = P1(K)
14502                PT2(K) = P2(K)
14503                PP2(K) = P3(K)
14504                PT1(K) = P4(K)
14505     8       CONTINUE
14506             CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14507      &                                                PP1(4),0,0,8)
14508             CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14509      &                                                       0,0,8)
14510             CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14511      &                                                PP2(4),0,0,8)
14512             CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14513      &                                                       0,0,8)
14514          ENDIF
14515          NCSY = NCSY+1
14516       ELSE
14517          CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4),
14518      &                                                        0,0,0)
14519       ENDIF
14520
14521       RETURN
14522
14523  9999 CONTINUE
14524       IRDIFF(2) = IRDIFF(2)+1
14525       IREJ      = 1
14526       RETURN
14527       END
14528
14529 *$ CREATE DT_EVTFRG.FOR
14530 *COPY DT_EVTFRG
14531 *
14532 *===evtfrg=============================================================*
14533 *
14534       SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ)
14535
14536 ************************************************************************
14537 * Hadronization of chains in DTEVT1.                                   *
14538 *                                                                      *
14539 * Input:                                                               *
14540 *   KMODE = 1   hadronization of PHOJET-chains (id=77xxx)              *
14541 *         = 2   hadronization of DTUNUC-chains (id=88xxx)              *
14542 *   NFRG  if KMODE = 1 : upper index of PHOJET-scatterings to be       *
14543 *                        hadronized with one PYEXEC call               *
14544 *         if KMODE = 2 : max. number of DTUNUC-chains to be hadronized *
14545 *                        with one PYEXEC call                          *
14546 * Output:                                                              *
14547 *   NPYMEM      number of entries in JETSET-common after hadronization *
14548 *   IREJ        rejection flag                                         *
14549 *                                                                      *
14550 * This version dated 17.09.00 is written by S. Roesler                 *
14551 ************************************************************************
14552
14553       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14554       SAVE
14555       PARAMETER ( LINP = 10 ,
14556      &            LOUT = 6 ,
14557      &            LDAT = 9 )
14558       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1)
14559       PARAMETER (ONE=1.0D0,ZERO=0.0D0)
14560
14561       LOGICAL LACCEP
14562
14563       PARAMETER (MXJOIN=200)
14564
14565 * event history
14566       PARAMETER (NMXHKK=200000)
14567       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14568      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14569      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14570 * extended event history
14571       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14572      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14573      &                IHIST(2,NMXHKK)
14574 * flags for input different options
14575       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14576       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14577      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14578 * statistics
14579       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
14580      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
14581      &                ICEVTG(8,0:30)
14582 * flags for diffractive interactions (DTUNUC 1.x)
14583       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
14584 * nucleon-nucleon event-generator
14585       CHARACTER*8 CMODEL
14586       LOGICAL LPHOIN
14587       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
14588 * phojet
14589 C  model switches and parameters
14590       CHARACTER*8 MDLNA
14591       INTEGER ISWMDL,IPAMDL
14592       DOUBLE PRECISION PARMDL
14593       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14594 * jetset
14595       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14596       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
14597       PARAMETER (MAXLND=4000)
14598       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
14599       INTEGER PYK
14600       DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
14601       INTEGER PYCOMP
14602       MODE = KMODE
14603       ISTSTG = 7
14604       IF (MODE.NE.1) ISTSTG = 8
14605       IREJ = 0
14606
14607       IP     = 0
14608       ISH    = 0
14609       INIEMC = 1
14610       NEND   = NHKK
14611       NACCEP = 0
14612       IFRG   = 0
14613       IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
14614       DO 10 I=NPOINT(3),NEND
14615 * sr 14.02.00: seems to be not necessary anymore, commented
14616 C        LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
14617 C    &            ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
14618          LACCEP = .TRUE.
14619 * pick up chains from dtevt1
14620          IDCHK = IDHKK(I)/10000
14621          IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN
14622             IF (IDCHK.EQ.7) THEN
14623                IPJE = IDHKK(I)-IDCHK*10000
14624                IF (IPJE.NE.IFRG) THEN
14625                   IFRG = IPJE
14626                   IF (IFRG.GT.NFRG) GOTO 16
14627                ENDIF
14628             ELSE
14629                IPJE = 1
14630                IFRG = IFRG+1
14631                IF (IFRG.GT.NFRG) THEN
14632                   NFRG = -1
14633                   GOTO 16
14634                ENDIF
14635             ENDIF
14636 *   statistics counter
14637 c           IF (IDCH(I).LE.8)
14638 c    &         ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
14639 c           IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
14640 * special treatment for small chains already corrected to hadrons
14641             IF (IDRES(I).NE.0) THEN
14642                IF (IDRES(I).EQ.11) THEN
14643                   ID = IDXRES(I)
14644                ELSE
14645                   ID = IDT_IPDGHA(IDXRES(I))
14646                ENDIF
14647                IF (LEMCCK) THEN
14648                   CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
14649      &                              PHKK(4,I),INIEMC,IDUM,IDUM)
14650                   INIEMC = 2
14651                ENDIF
14652                IP = IP+1
14653                IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
14654                P(IP,1) = PHKK(1,I)
14655                P(IP,2) = PHKK(2,I)
14656                P(IP,3) = PHKK(3,I)
14657                P(IP,4) = PHKK(4,I)
14658                P(IP,5) = PHKK(5,I)
14659                K(IP,1) = 1
14660                K(IP,2) = ID
14661                K(IP,3) = 0
14662                K(IP,4) = 0
14663                K(IP,5) = 0
14664                IHIST(2,I) = 10000*IPJE+IP
14665                IF (IHIST(1,I).LE.-100) THEN
14666                   ISH = ISH+1
14667                   IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14668                   ISJOIN(ISH) = I
14669                ENDIF
14670                N = IP
14671                IHISMO(IP) = I
14672             ELSE
14673                IJ  = 0
14674                DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
14675                   IF (LEMCCK) THEN
14676                      CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK),
14677      &                                   PHKK(4,KK),INIEMC,IDUM,IDUM)
14678                      CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM)
14679                      INIEMC = 2
14680                   ENDIF
14681                   ID = IDHKK(KK)
14682                   IF (ID.EQ.0) ID = 21
14683 c                  PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
14684 c                  AM0  = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
14685 c                  AMRQ   = PYMASS(ID)
14686 c                  AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
14687 c                  IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
14688 c     &                (ABS(IDIFF).EQ.0)) THEN
14689 cC                    WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
14690 c                     DELTA      = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
14691 c                     PHKK(4,KK) = PHKK(4,KK)+DELTA
14692 c                     PTOT1      = PTOT-DELTA
14693 c                     PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
14694 c                     PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
14695 c                     PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
14696 c                     PHKK(5,KK) = AMRQ
14697 c                  ENDIF
14698                   IP = IP+1
14699                   IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
14700                   P(IP,1) = PHKK(1,KK)
14701                   P(IP,2) = PHKK(2,KK)
14702                   P(IP,3) = PHKK(3,KK)
14703                   P(IP,4) = PHKK(4,KK)
14704                   P(IP,5) = PHKK(5,KK)
14705                   K(IP,1) = 1
14706                   K(IP,2) = ID
14707                   K(IP,3) = 0
14708                   K(IP,4) = 0
14709                   K(IP,5) = 0
14710                   IHIST(2,KK) = 10000*IPJE+IP
14711                   IF (IHIST(1,KK).LE.-100) THEN
14712                      ISH = ISH+1
14713                      IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14714                      ISJOIN(ISH) = KK
14715                   ENDIF
14716                   IJ = IJ+1
14717                   IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
14718                   IJOIN(IJ)  = IP
14719                   IHISMO(IP) = I
14720    11          CONTINUE
14721                N = IP
14722 * join the two-parton system
14723                CALL PYJOIN(IJ,IJOIN)
14724             ENDIF
14725             IDHKK(I) = 99999
14726          ENDIF
14727    10 CONTINUE
14728    16 CONTINUE
14729       N = IP
14730
14731       IF (IP.GT.0) THEN
14732
14733 * final state parton shower
14734          DO 136 NPJE=1,IPJE
14735             IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
14736                IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
14737                   DO 130 K1=1,ISH
14738                      IF (ISJOIN(K1).EQ.0) GOTO 130
14739                      I = ISJOIN(K1)
14740                      IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
14741      &                                                       GOTO 130
14742                      IH1 = IHIST(2,I)/10000
14743                      IF (IH1.NE.NPJE) GOTO 130
14744                      IH1 = IHIST(2,I)-IH1*10000
14745                      DO 135 K2=K1+1,ISH
14746                         IF (ISJOIN(K2).EQ.0) GOTO 135
14747                         II = ISJOIN(K2)
14748                         IH2 = IHIST(2,II)/10000
14749                         IF (IH2.NE.NPJE) GOTO 135
14750                         IH2 = IHIST(2,II)-IH2*10000
14751                         IF (IHIST(1,I).EQ.IHIST(1,II)) THEN
14752                            PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2)
14753                            PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2)
14754                            RQLUN = MIN(PT1,PT2)
14755                            CALL PYSHOW(IH1,IH2,RQLUN)
14756
14757                            ISJOIN(K1) = 0
14758                            ISJOIN(K2) = 0
14759                            GOTO 130
14760                         ENDIF
14761  135                 CONTINUE
14762  130              CONTINUE
14763                ENDIF
14764             ENDIF
14765  136     CONTINUE
14766
14767          CALL DT_INITJS(MODE)
14768 * hadronization
14769
14770          CALL PYEXEC
14771
14772          IF (MSTU(24).NE.0) THEN
14773             WRITE(LOUT,*) ' JETSET-reject at event',
14774      &                    NEVHKK,MSTU(24),KMODE
14775 C           CALL DT_EVTOUT(4)
14776
14777 C           CALL PYLIST(2)
14778
14779             GOTO 9999
14780          ENDIF
14781
14782 *   number of entries in LUJETS
14783
14784          NLINES = PYK(0,1)
14785
14786          NPYMEM = NLINES
14787
14788          DO 12 I=1,NLINES
14789             IFLG(I) = 0
14790    12    CONTINUE
14791
14792          DO 13 II=1,NLINES
14793
14794             IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
14795
14796 *  pick up mother resonance if possible and put it together with
14797 *  their decay-products into the common
14798                IDXMOR = K(II,3)
14799                IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
14800                   KFMOR = K(IDXMOR,2)
14801                   ISMOR = K(IDXMOR,1)
14802                ELSE
14803                   KFMOR = 91
14804                   ISMOR = 1
14805                ENDIF
14806                IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
14807      &             (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
14808                   ID = K(IDXMOR,2)
14809                   MO = IHISMO(PYK(IDXMOR,15))
14810                   PX = PYP(IDXMOR,1)
14811                   PY = PYP(IDXMOR,2)
14812                   PZ = PYP(IDXMOR,3)
14813                   PE = PYP(IDXMOR,4)
14814                   CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14815                   IFLG(IDXMOR) = 1
14816                   MO = NHKK
14817                   DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
14818                      IF (PYK(JDAUG,7).EQ.1) THEN
14819                         ID = PYK(JDAUG,8)
14820                         PX = PYP(JDAUG,1)
14821                         PY = PYP(JDAUG,2)
14822                         PZ = PYP(JDAUG,3)
14823                         PE = PYP(JDAUG,4)
14824                         CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14825                         IF (LEMCCK) THEN
14826                            PX = -PYP(JDAUG,1)
14827                            PY = -PYP(JDAUG,2)
14828                            PZ = -PYP(JDAUG,3)
14829                            PE = -PYP(JDAUG,4)
14830                            CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14831                         ENDIF
14832                         IFLG(JDAUG) = 1
14833                      ENDIF
14834    15             CONTINUE
14835                ELSE
14836 *  there was no mother resonance
14837                   MO = IHISMO(PYK(II,15))
14838                   ID = PYK(II,8)
14839                   PX = PYP(II,1)
14840                   PY = PYP(II,2)
14841                   PZ = PYP(II,3)
14842                   PE = PYP(II,4)
14843                   CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14844                   IF (LEMCCK) THEN
14845                      PX = -PYP(II,1)
14846                      PY = -PYP(II,2)
14847                      PZ = -PYP(II,3)
14848                      PE = -PYP(II,4)
14849                      CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14850                   ENDIF
14851                ENDIF
14852             ENDIF
14853    13    CONTINUE
14854          IF (LEMCCK) THEN
14855             CHKLEV = TINY1
14856             CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
14857 C           IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
14858          ENDIF
14859
14860 * global energy-momentum & flavor conservation check
14861 **sr 16.5. this check is skipped in case of phojet-treatment
14862          IF (MCGENE.EQ.1)
14863      &      CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
14864
14865 * update statistics-counter for diffraction
14866 c        IF (IFLAGD.NE.0) THEN
14867 c           ICDIFF(1) = ICDIFF(1)+1
14868 c           IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
14869 c           IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
14870 c           IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
14871 c           IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
14872 c        ENDIF
14873
14874       ENDIF
14875
14876       RETURN
14877
14878  9999 CONTINUE
14879       IREJ = 1
14880       RETURN
14881       END
14882
14883 *$ CREATE DT_DECAYS.FOR
14884 *COPY DT_DECAYS
14885 *
14886 *===decay==============================================================*
14887 *
14888       SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
14889
14890 ************************************************************************
14891 * Resonance-decay.                                                     *
14892 * This subroutine replaces DDECAY/DECHKK.                              *
14893 *             PIN(4)      4-momentum of resonance          (input)     *
14894 *             IDXIN       BAMJET-index of resonance        (input)     *
14895 *             POUT(20,4)  4-momenta of decay-products      (output)    *
14896 *             IDXOUT(20)  BAMJET-indices of decay-products (output)    *
14897 *             NSEC        number of secondaries            (output)    *
14898 * Adopted from the original version DECHKK.                            *
14899 * This version dated 09.01.95 is written by S. Roesler                 *
14900 ************************************************************************
14901
14902       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14903       SAVE
14904       PARAMETER ( LINP = 10 ,
14905      &            LOUT = 6 ,
14906      &            LDAT = 9 )
14907       PARAMETER (TINY17=1.0D-17)
14908
14909 * HADRIN: decay channel information
14910       PARAMETER (IDMAX9=602)
14911       CHARACTER*8 ZKNAME
14912       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
14913 * particle properties (BAMJET index convention)
14914       CHARACTER*8  ANAME
14915       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
14916      &                IICH(210),IIBAR(210),K1(210),K2(210)
14917 * flags for input different options
14918       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14919       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14920      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14921
14922       DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20),
14923      &          EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3),
14924      &          CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3)
14925
14926 * ISTAB = 1 strong and weak decays
14927 *       = 2 strong decays only
14928 *       = 3 strong decays, weak decays for charmed particles and tau
14929 *           leptons only
14930       DATA ISTAB /2/
14931
14932       IREJ = 0
14933       NSEC = 0
14934 * put initial resonance to stack
14935       NSTK = 1
14936       IDXSTK(NSTK) = IDXIN
14937       DO 5 I=1,4
14938          PI(NSTK,I) = PIN(I)
14939     5 CONTINUE
14940
14941 * store initial configuration for energy-momentum cons. check
14942       IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3),
14943      &                                   PI(NSTK,4),1,IDUM,IDUM)
14944
14945   100 CONTINUE
14946 * get particle from stack
14947       IDXI = IDXSTK(NSTK)
14948 * skip stable particles
14949       IF (ISTAB.EQ.1) THEN
14950          IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10
14951          IF ((IDXI.GE.  1).AND.(IDXI.LE.  7)) GOTO 10
14952       ELSEIF (ISTAB.EQ.2) THEN
14953          IF ((IDXI.GE.  1).AND.(IDXI.LE. 30)) GOTO 10
14954          IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
14955          IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10
14956          IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10
14957          IF ( IDXI.EQ.109)                    GOTO 10
14958          IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10
14959       ELSEIF (ISTAB.EQ.3) THEN
14960          IF ((IDXI.GE.  1).AND.(IDXI.LE. 23)) GOTO 10
14961          IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
14962          IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10
14963          IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10
14964       ENDIF
14965
14966 * calculate direction cosines and Lorentz-parameter of decaying part.
14967       PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2)
14968       PTOT = MAX(PTOT,TINY17)
14969       DO 1 I=1,3
14970          DCOS(I) = PI(NSTK,I)/PTOT
14971     1 CONTINUE
14972       GAM  = PI(NSTK,4)/AAM(IDXI)
14973       BGAM = PTOT/AAM(IDXI)
14974
14975 * get decay-channel
14976       KCHAN = K1(IDXI)-1
14977     2 CONTINUE
14978       KCHAN = KCHAN+1
14979       IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
14980
14981 * identities of secondaries
14982       IDX(1) = NZK(KCHAN,1)
14983       IDX(2) = NZK(KCHAN,2)
14984       IF (IDX(2).LT.1) GOTO 9999
14985       IDX(3) = NZK(KCHAN,3)
14986
14987 * handle decay in rest system of decaying particle
14988       IF (IDX(3).EQ.0) THEN
14989 *   two-particle decay
14990          NDEC = 2
14991          CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2),
14992      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
14993      &               AAM(IDX(1)),AAM(IDX(2)))
14994       ELSE
14995 *   three-particle decay
14996          NDEC = 3
14997          CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3),
14998      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
14999      &               CODF(3),COFF(3),SIFF(3),
15000      &               AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3)))
15001       ENDIF
15002       NSTK = NSTK-1
15003
15004 * transform decay products back
15005       DO 3 I=1,NDEC
15006          NSTK = NSTK+1
15007          CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3),
15008      &               CODF(I),COFF(I),SIFF(I),PF(I),EF(I),
15009      &               PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4))
15010 * add particle to stack
15011          IDXSTK(NSTK) = IDX(I)
15012          DO 4 J=1,3
15013             PI(NSTK,J) = DCOSF(J)*PFF(I)
15014     4    CONTINUE
15015     3 CONTINUE
15016       GOTO 100
15017
15018    10 CONTINUE
15019 * stable particle, put to output-arrays
15020       NSEC = NSEC+1
15021       DO 6 I=1,4
15022          POUT(NSEC,I) = PI(NSTK,I)
15023     6 CONTINUE
15024       IDXOUT(NSEC) = IDXSTK(NSTK)
15025 * store secondaries for energy-momentum conservation check
15026       IF (LEMCCK)
15027      &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
15028      &            -POUT(NSEC,4),2,IDUM,IDUM)
15029       NSTK = NSTK-1
15030       IF (NSTK.GT.0) GOTO 100
15031
15032 * check energy-momentum conservation
15033       IF (LEMCCK) THEN
15034          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
15035          IF (IREJ1.NE.0) GOTO 9999
15036       ENDIF
15037
15038       RETURN
15039
15040  9999 CONTINUE
15041       IREJ = 1
15042       RETURN
15043       END
15044
15045 *$ CREATE DT_DECAY1.FOR
15046 *COPY DT_DECAY1
15047 *
15048 *===decay1=============================================================*
15049 *
15050       SUBROUTINE DT_DECAY1
15051
15052 ************************************************************************
15053 * Decay of resonances stored in DTEVT1.                                *
15054 * This version dated 20.01.95 is written by S. Roesler                 *
15055 ************************************************************************
15056
15057       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15058       SAVE
15059       PARAMETER ( LINP = 10 ,
15060      &            LOUT = 6 ,
15061      &            LDAT = 9 )
15062
15063 * event history
15064       PARAMETER (NMXHKK=200000)
15065       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15066      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15067      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15068 * extended event history
15069       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15070      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15071      &                IHIST(2,NMXHKK)
15072
15073       DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
15074
15075       NEND = NHKK
15076 C     DO 1 I=NPOINT(5),NEND
15077       DO 1 I=NPOINT(4),NEND
15078          IF (ABS(ISTHKK(I)).EQ.1) THEN
15079             DO 2 K=1,4
15080                PIN(K) = PHKK(K,I)
15081     2       CONTINUE
15082             IDXIN = IDBAM(I)
15083             CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15084             IF (NSEC.GT.1) THEN
15085                DO 3 N=1,NSEC
15086                   IDHAD = IDT_IPDGHA(IDXOUT(N))
15087                   CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2),
15088      &                               POUT(N,3),POUT(N,4),0,0,0)
15089     3          CONTINUE
15090             ENDIF
15091          ENDIF
15092     1 CONTINUE
15093
15094       RETURN
15095       END
15096
15097 *$ CREATE DT_DECPI0.FOR
15098 *COPY DT_DECPI0
15099 *
15100 *===decpi0=============================================================*
15101 *
15102       SUBROUTINE DT_DECPI0
15103
15104 ************************************************************************
15105 * Decay of pi0 handled with JETSET.                                    *
15106 * This version dated 18.02.96 is written by S. Roesler                 *
15107 ************************************************************************
15108
15109       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15110       SAVE
15111       PARAMETER ( LINP = 10 ,
15112      &            LOUT = 6 ,
15113      &            LDAT = 9 )
15114       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0)
15115
15116 * event history
15117       PARAMETER (NMXHKK=200000)
15118       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15119      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15120      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15121 * extended event history
15122       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15123      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15124      &                IHIST(2,NMXHKK)
15125       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15126       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15127       PARAMETER (MAXLND=4000)
15128       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15129 * flags for input different options
15130       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15131       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15132      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15133
15134       INTEGER PYCOMP,PYK
15135
15136       DIMENSION IHISMO(NMXHKK),P1(4)
15137
15138       TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
15139
15140       CALL DT_INITJS(2)
15141 * allow pi0 decay
15142       KC = PYCOMP(111)
15143       MDCY(KC,1) = 1
15144
15145       NN  = 0
15146       INI = 0
15147       DO 1 I=1,NHKK
15148          IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
15149             IF (INI.EQ.0) THEN
15150                INI = 1
15151             ELSE
15152                INI = 2
15153             ENDIF
15154             IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15155      &                                    PHKK(4,I),INI,IDUM,IDUM)
15156             PT    = SQRT(PHKK(1,I)**2+PHKK(2,I)**2)
15157             PTOT  = SQRT(PT**2+PHKK(3,I)**2)
15158             COSTH = PHKK(3,I)/(PTOT+TINY10)
15159             IF (COSTH.GT.ONE) THEN
15160                THETA = ZERO
15161             ELSEIF (COSTH.LT.-ONE) THEN
15162                THETA = TWOPI/2.0D0
15163             ELSE
15164                THETA = ACOS(COSTH)
15165             ENDIF
15166             PHI     = ASIN(PHKK(2,I)/(PT  +TINY10))
15167             IF (PHKK(1,I).LT.0.0D0)
15168      &         PHI  = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
15169             ENER    = PHKK(4,I)
15170             NN      = NN+1
15171             KTEMP   = MSTU(10)
15172             MSTU(10)= 1
15173             P(NN,5) = PHKK(5,I)
15174             CALL PY1ENT(NN,111,ENER,THETA,PHI)
15175             MSTU(10)  = KTEMP
15176             IHISMO(NN)= I
15177          ENDIF
15178     1 CONTINUE
15179       IF (NN.GT.0) THEN
15180          CALL PYEXEC
15181          NLINES = PYK(0,1)
15182          DO 2 II=1,NLINES
15183             IF (PYK(II,7).EQ.1) THEN
15184                DO 3 KK=1,4
15185                   P1(KK) = PYP(II,KK)
15186     3          CONTINUE
15187                ID = PYK(II,8)
15188                MO = IHISMO(PYK(II,15))
15189                CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
15190                IF (LEMCCK)
15191      &            CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
15192      &                                            IDUM,IDUM)
15193 *sr: flag with neg. sign (for HELIOS p/A-W jobs)
15194                ISTHKK(MO) = -2
15195             ENDIF
15196     2    CONTINUE
15197          IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
15198       ENDIF
15199       MDCY(KC,1) = 0
15200
15201       RETURN
15202       END
15203
15204 *$ CREATE DT_DTWOPD.FOR
15205 *COPY DT_DTWOPD
15206 *
15207 *===dtwopd=============================================================*
15208 *
15209       SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
15210      &                                            COF2,SIF2,AM1,AM2)
15211
15212 ************************************************************************
15213 * Two-particle decay.                                                  *
15214 *  UMO                 cm-energy of the decaying system       (input)  *
15215 *  AM1/AM2             masses of the decay products           (input)  *
15216 *  ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) *
15217 *  COD,COF,SIF         direction cosines of the decay prod.   (output) *
15218 * Revised by S. Roesler, 20.11.95                                      *
15219 ************************************************************************
15220
15221       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15222       SAVE
15223       PARAMETER ( LINP = 10 ,
15224      &            LOUT = 6 ,
15225      &            LDAT = 9 )
15226       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
15227
15228       IF (UMO.LT.(AM1+AM2)) THEN
15229          WRITE(LOUT,1000) UMO,AM1,AM2
15230  1000    FORMAT(1X,'DTWOPD:    inconsistent kinematics - UMO,AM1,AM2 ',
15231      &          3E12.3)
15232          STOP
15233       ENDIF
15234
15235       ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
15236       ECM2 = UMO-ECM1
15237       PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
15238       PCM2 = PCM1
15239       CALL DT_DSFECF(SIF1,COF1)
15240       COD1 = TWO*DT_RNDM(PCM2)-ONE
15241       COD2 = -COD1
15242       COF2 = -COF1
15243       SIF2 = -SIF1
15244
15245       RETURN
15246       END
15247
15248 *$ CREATE DT_DTHREP.FOR
15249 *COPY DT_DTHREP
15250 *
15251 *===dthrep=============================================================*
15252 *
15253       SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
15254      &                  SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
15255
15256 ************************************************************************
15257 * Three-particle decay.                                                *
15258 *  UMO                 cm-energy of the decaying system       (input)  *
15259 *  AM1/2/3             masses of the decay products           (input)  *
15260 *  ECM1/2/2,PCM1/2/3   cm-energies/momenta of the decay prod. (output) *
15261 *  COD,COF,SIF         direction cosines of the decay prod.   (output) *
15262 *                                                                      *
15263 * Threpd89: slight revision by A. Ferrari                              *
15264 * Last change on   11-oct-93   by    Alfredo Ferrari, INFN - Milan     *
15265 * Revised by S. Roesler, 20.11.95                                      *
15266 ************************************************************************
15267
15268       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15269       SAVE
15270       PARAMETER ( LINP = 10 ,
15271      &            LOUT = 6 ,
15272      &            LDAT = 9 )
15273
15274       PARAMETER ( ANGLSQ = 2.5D-31 )
15275       PARAMETER ( AZRZRZ = 1.0D-30 )
15276       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
15277       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
15278       PARAMETER ( ONEONE = 1.D+00 )
15279       PARAMETER ( TWOTWO = 2.D+00 )
15280       PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
15281
15282       COMMON /HNGAMR/ REDU,AMO,AMM(15)
15283 * flags for input different options
15284       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15285       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15286      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15287
15288       DIMENSION F(5),XX(5)
15289       DATA EPS /AZRZRZ/
15290
15291       UMOO=UMO+UMO
15292 C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
15293 C***J. VON NEUMANN - RANDOM - SELECTION OF S2
15294 C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
15295       UUMO=UMO
15296       AAM1=AM1
15297       AAM2=AM2
15298       AAM3=AM3
15299       GU=(AM2+AM3)**2
15300       GO=(UMO-AM1)**2
15301 *     UFAK=1.0000000000001D0
15302 *     IF (GU.GT.GO) UFAK=0.9999999999999D0
15303       IF (GU.GT.GO) THEN
15304          UFAK=ONEMNS
15305       ELSE
15306          UFAK=ONEPLS
15307       END IF
15308       OFAK=2.D0-UFAK
15309       GU=GU*UFAK
15310       GO=GO*OFAK
15311       DS2=(GO-GU)/99.D0
15312       AM11=AM1*AM1
15313       AM22=AM2*AM2
15314       AM33=AM3*AM3
15315       UMO2=UMO*UMO
15316       RHO2=0.D0
15317       S22=GU
15318       DO 124 I=1,100
15319          S21=S22
15320          S22=GU+(I-1.D0)*DS2
15321          RHO1=RHO2
15322          RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
15323      *                                             (S22+EPS)
15324          IF(RHO2.LT.RHO1) GO TO 125
15325   124 CONTINUE
15326   125 S2SUP=(S22-S21)*.5D0+S21
15327       SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
15328      *                                           (S2SUP+EPS)
15329       SUPRHO=SUPRHO*1.05D0
15330       XO=S21-DS2
15331       IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
15332       IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
15333       XX(1)=XO
15334       XX(3)=S22
15335       X1=(XO+S22)*0.5D0
15336       XX(2)=X1
15337       F(3)=RHO2
15338       F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS)
15339       F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS)
15340       DO 126 I=1,16
15341          X4=(XX(1)+XX(2))*0.5D0
15342          X5=(XX(2)+XX(3))*0.5D0
15343          F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/
15344      *                                               (X4+EPS)
15345          F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
15346      *                                               (X5+EPS)
15347          XX(4)=X4
15348          XX(5)=X5
15349          DO 128 II=1,5
15350             IA=II
15351             DO 128 III=IA,5
15352                IF (F (II).GE.F (III)) GO TO 128
15353                FH=F(II)
15354                F(II)=F(III)
15355                F(III)=FH
15356                FH=XX(II)
15357                XX(II)=XX(III)
15358                XX(III)=FH
15359 128      CONTINUE
15360          SUPRHO=F(1)
15361          S2SUP=XX(1)
15362          DO 129 II=1,3
15363             IA=II
15364             DO 129 III=IA,3
15365                IF (XX(II).GE.XX(III)) GO TO 129
15366                FH=F(II)
15367                F(II)=F(III)
15368                F(III)=FH
15369                FH=XX(II)
15370                XX(II)=XX(III)
15371                XX(III)=FH
15372 129      CONTINUE
15373 126   CONTINUE
15374       AM23=(AM2+AM3)**2
15375       ITH=0
15376       REDU=2.D0
15377     1 CONTINUE
15378       ITH=ITH+1
15379       IF (ITH.GT.200) REDU=-9.D0
15380       IF (ITH.GT.200) GO TO 400
15381       C=DT_RNDM(REDU)
15382 *     S2=AM23+C*((UMO-AM1)**2-AM23)
15383       S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
15384       Y=DT_RNDM(S2)
15385       Y=Y*SUPRHO
15386       RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
15387       IF(Y.GT.RHO) GO TO 1
15388 C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
15389       S1=DT_RNDM(S2)
15390       S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
15391      &RHO*.5D0
15392       S3=UMO2+AM11+AM22+AM33-S1-S2
15393       ECM1=(UMO2+AM11-S2)/UMOO
15394       ECM2=(UMO2+AM22-S3)/UMOO
15395       ECM3=(UMO2+AM33-S1)/UMOO
15396       PCM1=SQRT((ECM1+AM1)*(ECM1-AM1))
15397       PCM2=SQRT((ECM2+AM2)*(ECM2-AM2))
15398       PCM3=SQRT((ECM3+AM3)*(ECM3-AM3))
15399       CALL DT_DSFECF(SFE,CFE)
15400 C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
15401 C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
15402       PCM12 = PCM1 * PCM2
15403       IF ( PCM12 .LT. ANGLSQ ) GO TO 200
15404       COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12
15405       GO TO 300
15406  200  CONTINUE
15407          UW=DT_RNDM(S1)
15408          COSTH=(UW-0.5D+00)*2.D+00
15409  300  CONTINUE
15410 *     IF(ABS(COSTH).GT.0.9999999999999999D0)
15411 *    &COSTH=SIGN(0.9999999999999999D0,COSTH)
15412       IF(ABS(COSTH).GT.ONEONE)
15413      &COSTH=SIGN(ONEONE,COSTH)
15414       IF (REDU.LT.1.D+00) RETURN
15415       COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3)
15416 *     IF(ABS(COSTH2).GT.0.9999999999999999D0)
15417 *    &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
15418       IF(ABS(COSTH2).GT.ONEONE)
15419      &COSTH2=SIGN(ONEONE,COSTH2)
15420       SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2))
15421       SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH))
15422       SINTH1=COSTH2*SINTH-COSTH*SINTH2
15423       COSTH1=COSTH*COSTH2+SINTH2*SINTH
15424 C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
15425 C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
15426 C***THE DIRECTION OF PARTICLE 3
15427 C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
15428       CX11=-COSTH1
15429       CY11=SINTH1*CFE
15430       CZ11=SINTH1*SFE
15431       CX22=-COSTH2
15432       CY22=-SINTH2*CFE
15433       CZ22=-SINTH2*SFE
15434       CALL DT_DSFECF(SIF3,COF3)
15435       COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
15436       SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
15437     2 FORMAT(5F20.15)
15438       COD1=CX11*COD3+CZ11*SID3
15439       CHLP=(ONEONE-COD1)*(ONEONE+COD1)
15440       IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3,
15441      &CX11,CZ11
15442       SID1=SQRT(CHLP)
15443       COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1
15444       SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1
15445       COD2=CX22*COD3+CZ22*SID3
15446       SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2))
15447       COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2
15448       SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2
15449  400  CONTINUE
15450 * === Energy conservation check: === *
15451       EOCHCK = UMO - ECM1 - ECM2 - ECM3
15452 *     SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
15453 *     SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
15454 *     SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
15455       PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3
15456       PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2
15457      &       + PCM3 * COF3 * SID3
15458       PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2
15459      &       + PCM3 * SIF3 * SID3
15460       EOCMPR = 1.D-12 * UMO
15461       IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK)
15462      &     .GT. EOCMPR ) THEN
15463 **sr 5.5.95 output-unit changed
15464          IF (IOULEV(1).GT.0) THEN
15465             WRITE(LOUT,*)
15466      &      ' *** Threpd: energy/momentum conservation failure! ***',
15467      &      EOCHCK,PXCHCK,PYCHCK,PZCHCK
15468             WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
15469          ENDIF
15470 **
15471       END IF
15472       RETURN
15473       END
15474
15475 *$ CREATE DT_DBKLAS.FOR
15476 *COPY DT_DBKLAS
15477 *
15478 *===dbklas=============================================================*
15479 *
15480       SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
15481
15482       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15483       SAVE
15484       PARAMETER ( LINP = 10 ,
15485      &            LOUT = 6 ,
15486      &            LDAT = 9 )
15487
15488 * quark-content to particle index conversion (DTUNUC 1.x)
15489       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15490      &                IA08(6,21),IA10(6,21)
15491
15492       IF (I) 20,20,10
15493 * baryons
15494    10 CONTINUE
15495       CALL DT_INDEXD(J,K,IND)
15496       I8  = IB08(I,IND)
15497       I10 = IB10(I,IND)
15498       IF (I8.LE.0) I8 = I10
15499       RETURN
15500 * antibaryons
15501    20 CONTINUE
15502       II = IABS(I)
15503       JJ = IABS(J)
15504       KK = IABS(K)
15505       CALL DT_INDEXD(JJ,KK,IND)
15506       I8  = IA08(II,IND)
15507       I10 = IA10(II,IND)
15508       IF (I8.LE.0) I8 = I10
15509
15510       RETURN
15511       END
15512
15513 *$ CREATE DT_INDEXD.FOR
15514 *COPY DT_INDEXD
15515 *
15516 *===indexd=============================================================*
15517 *
15518       SUBROUTINE DT_INDEXD(KA,KB,IND)
15519
15520       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15521       SAVE
15522       PARAMETER ( LINP = 10 ,
15523      &            LOUT = 6 ,
15524      &            LDAT = 9 )
15525
15526       KP = KA*KB
15527       KS = KA+KB
15528       IF (KP.EQ.1) IND=1
15529       IF (KP.EQ.2) IND=2
15530       IF (KP.EQ.3) IND=3
15531       IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
15532       IF (KP.EQ.5) IND=5
15533       IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6
15534       IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7
15535       IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8
15536       IF (KP.EQ.8)  IND=9
15537       IF (KP.EQ.10) IND=10
15538       IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11
15539       IF (KP.EQ.9)  IND=12
15540       IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13
15541       IF (KP.EQ.15) IND=14
15542       IF (KP.EQ.18) IND=15
15543       IF (KP.EQ.16) IND=16
15544       IF (KP.EQ.20) IND=17
15545       IF (KP.EQ.24) IND=18
15546       IF (KP.EQ.25) IND=19
15547       IF (KP.EQ.30) IND=20
15548       IF (KP.EQ.36) IND=21
15549
15550       RETURN
15551       END
15552
15553 *$ CREATE DT_DCHANT.FOR
15554 *COPY DT_DCHANT
15555 *
15556 *===dchant=============================================================*
15557 *
15558       SUBROUTINE DT_DCHANT
15559
15560       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15561       SAVE
15562       PARAMETER ( LINP = 10 ,
15563      &            LOUT = 6 ,
15564      &            LDAT = 9 )
15565       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15566
15567 * HADRIN: decay channel information
15568       PARAMETER (IDMAX9=602)
15569       CHARACTER*8 ZKNAME
15570       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15571 * particle properties (BAMJET index convention)
15572       CHARACTER*8  ANAME
15573       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15574      &                IICH(210),IIBAR(210),K1(210),K2(210)
15575
15576       DIMENSION HWT(IDMAX9)
15577
15578 * change of weights wt from absolut values into the sum of wt of a dec.
15579       DO 10 J=1,IDMAX9
15580          HWT(J) = ZERO
15581    10 CONTINUE
15582 C     DO 999 KKK=1,210
15583 C        WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
15584 C    &      ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
15585 C    &      K1(KKK),K2(KKK)
15586 C 999 CONTINUE
15587 C     STOP
15588       DO 30 I=1,210
15589          IK1 = K1(I)
15590          IK2 = K2(I)
15591          HV  = ZERO
15592          DO 20 J=IK1,IK2
15593             HV     = HV+WT(J)
15594             HWT(J) = HV
15595 **sr 13.1.95
15596             IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1
15597  1000       FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
15598    20    CONTINUE
15599    30 CONTINUE
15600       DO 40 J=1,IDMAX9
15601          WT(J) = HWT(J)
15602    40 CONTINUE
15603
15604       RETURN
15605       END
15606
15607 *$ CREATE DT_DDATAR.FOR
15608 *COPY DT_DDATAR
15609 *
15610 *===ddatar=============================================================*
15611 *
15612       SUBROUTINE DT_DDATAR
15613
15614       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15615       SAVE
15616       PARAMETER ( LINP = 10 ,
15617      &            LOUT = 6 ,
15618      &            LDAT = 9 )
15619       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15620
15621 * quark-content to particle index conversion (DTUNUC 1.x)
15622       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15623      &                IA08(6,21),IA10(6,21)
15624
15625       DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
15626
15627       DATA IV/ 33, 34, 38,123,  0,  0, 32, 33, 39,124,
15628      &          0,  0, 36, 37, 96,127,  0,  0,126,125,
15629      &        128,129,14*0/
15630       DATA IP/ 23, 14, 16,116,  0,  0, 13, 23, 25,117,
15631      &          0,  0, 15, 24, 31,120,  0,  0,119,118,
15632      &        121,122,14*0/
15633       DATA IB/  0,  1, 21,140,  0,  0,  8, 22,137,  0,
15634      &          0, 97,138,  0,  0,146,  0,  0,  0,  0,
15635      &          0,  1,  8, 22,137,  0,  0,  0, 20,142,
15636      &          0,  0, 98,139,  0,  0,147,  0,  0,  0,
15637      &          0,  0, 21, 22, 97,138,  0,  0, 20, 98,
15638      &        139,  0,  0,  0,145,  0,  0,148,  0,  0,
15639      &          0,  0,  0,140,137,138,146,  0,  0,142,
15640      &        139,147,  0,  0,145,148,           50*0/
15641       DATA IBB/53, 54,104,161,  0,  0, 55,105,162,  0,
15642      &          0,107,164,  0,  0,167,  0,  0,  0,  0,
15643      &          0, 54, 55,105,162,  0,  0, 56,106,163,
15644      &          0,  0,108,165,  0,  0,168,  0,  0,  0,
15645      &          0,  0,104,105,107,164,  0,  0,106,108,
15646      &        165,  0,  0,109,166,  0,  0,169,  0,  0,
15647      &          0,  0,  0,161,162,164,167,  0,  0,163,
15648      &        165,168,  0,  0,166,169,  0,  0,170,47*0/
15649       DATA IA/  0,  2, 99,152,  0,  0,  9,100,149,  0,
15650      &          0,102,150,  0,  0,158,  0,  0,  0,  0,
15651      &          0,  2,  9,100,149,  0,  0,  0,101,154,
15652      &          0,  0,103,151,  0,  0,159,  0,  0,  0,
15653      &          0,  0, 99,100,102,150,  0,  0,101,103,
15654      &        151,  0,  0,  0,157,  0,  0,160,  0,  0,
15655      &          0,  0,  0,152,149,150,158,  0,  0,154,
15656      &        151,159,  0,  0,157,160,           50*0/
15657       DATA IAA/67, 68,110,171,  0,  0, 69,111,172,  0,
15658      &          0,113,174,  0,  0,177,  0,  0,  0,  0,
15659      &          0, 68, 69,111,172,  0,  0, 70,112,173,
15660      &          0,  0,114,175,  0,  0,178,  0,  0,  0,
15661      &          0,  0,110,111,113,174,  0,  0,112,114,
15662      &        175,  0,  0,115,176,  0,  0,179,  0,  0,
15663      &          0,  0,  0,171,172,174,177,  0,  0,173,
15664      &        175,178,  0,  0,176,179,  0,  0,180,47*0/
15665
15666       L=0
15667       DO 2 I=1,6
15668          DO 1 J=1,6
15669             L = L+1
15670             IMPS(I,J) = IP(L)
15671             IMVE(I,J) = IV(L)
15672     1    CONTINUE
15673     2 CONTINUE
15674       L=0
15675       DO 4 I=1,6
15676          DO 3 J=1,21
15677             L = L+1
15678             IB08(I,J) = IB(L)
15679             IB10(I,J) = IBB(L)
15680             IA08(I,J) = IA(L)
15681             IA10(I,J) = IAA(L)
15682     3    CONTINUE
15683     4 CONTINUE
15684 C     A1  = 0.88D0
15685 C     B1  = 3.0D0
15686 C     B2  = 3.0D0
15687 C     B3  = 8.0D0
15688 C     LT  = 0
15689 C     LB  = 0
15690 C     BET = 12.0D0
15691 C     AS  = 0.25D0
15692 C     B8  = 0.33D0
15693 C     AME = 0.95D0
15694 C     DIQ = 0.375D0
15695 C     ISU = 4
15696
15697       RETURN
15698       END
15699
15700 *$ CREATE DT_INITJS.FOR
15701 *COPY DT_INITJS
15702 *
15703 *===initjs=============================================================*
15704 *
15705       SUBROUTINE DT_INITJS(MODE)
15706
15707 ************************************************************************
15708 * Initialize JETSET paramters.                                         *
15709 *           MODE = 0 default settings                                  *
15710 *                = 1 PHOJET settings                                   *
15711 *                = 2 DTUNUC settings                                   *
15712 * This version dated 16.02.96 is written by S. Roesler                 *
15713 *                                                                      *
15714 * Last change 27.12.2006 by S. Roesler.                                *
15715 ************************************************************************
15716
15717       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15718       SAVE
15719       PARAMETER ( LINP = 10 ,
15720      &            LOUT = 6 ,
15721      &            LDAT = 9 )
15722       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15723
15724       LOGICAL LFIRST,LFIRDT,LFIRPH
15725
15726       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15727       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15728       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15729 * flags for particle decays
15730       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
15731      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
15732      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
15733 * flags for input different options
15734       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15735       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15736      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15737
15738       INTEGER PYCOMP
15739
15740       DIMENSION IDXSTA(40)
15741       DATA IDXSTA
15742 *          K0s   pi0  lam   alam  sig+  asig+ sig-  asig- tet0  atet0
15743      &  /  310,  111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322,
15744 *          tet- atet-  om-  aom-   D+    D-    D0    aD0   Ds+   aDs+
15745      &    3312,-3312, 3334,-3334,  411, -411,  421, -421,  431, -431,
15746 *          etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+
15747      &     441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232,
15748 *         Ksic0 aKsic+aKsic0 sig0 asig0
15749      &    4132,-4232,-4132, 3212,-3212, 5*0/
15750
15751       DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
15752
15753       IF (LFIRST) THEN
15754 * save default settings
15755          PDEF1  = PARJ(1)
15756          PDEF2  = PARJ(2)
15757          PDEF3  = PARJ(3)
15758          PDEF5  = PARJ(5)
15759          PDEF6  = PARJ(6)
15760          PDEF7  = PARJ(7)
15761          PDEF18 = PARJ(18)
15762          PDEF19 = PARJ(19)
15763          PDEF21 = PARJ(21)
15764          PDEF42 = PARJ(42)
15765          MDEF12 = MSTJ(12)
15766 * LUJETS / PYJETS array-dimensions
15767          MSTU(4) = 4000
15768 * increase maximum number of JETSET-error prints
15769          MSTU(22) = 50000
15770 * prevent particles decaying
15771          DO 1 I=1,35
15772             IF (I.LT.34) THEN
15773                KC = PYCOMP(IDXSTA(I))
15774                IF (KC.GT.0) THEN
15775                   IF (I.EQ.2) THEN
15776 *  pi0 decay
15777 C                    MDCY(KC,1) = 1
15778                      MDCY(KC,1) = 0
15779 **cr mode
15780 C                 ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
15781 C   &                    (I.EQ.8).OR.(I.EQ.10)) THEN
15782 C                 ELSEIF (I.EQ.4) THEN
15783 C                    MDCY(KC,1) = 1
15784 **
15785                   ELSE
15786 C AM                     MDCY(KC,1) = 0
15787                   ENDIF
15788                ENDIF
15789             ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
15790                KC = PYCOMP(IDXSTA(I))
15791                IF (KC.GT.0) THEN
15792 C AM                 MDCY(KC,1) = 0
15793                ENDIF
15794             ENDIF
15795     1    CONTINUE
15796 *
15797 *
15798 * popcorn:
15799          IF (PDB.LE.ZERO) THEN
15800 *   no popcorn-mechanism
15801             MSTJ(12) = 1
15802          ELSE
15803             MSTJ(12) = 3
15804             PARJ(5)  = PDB
15805          ENDIF
15806 * set JETSET-parameter requested by input cards
15807          IF (NMSTU.GT.0) THEN
15808             DO 2 I=1,NMSTU
15809                MSTU(IMSTU(I)) = MSTUX(I)
15810     2       CONTINUE
15811          ENDIF
15812          IF (NMSTJ.GT.0) THEN
15813             DO 3 I=1,NMSTJ
15814                MSTJ(IMSTJ(I)) = MSTJX(I)
15815     3       CONTINUE
15816          ENDIF
15817          IF (NPARU.GT.0) THEN
15818             DO 4 I=1,NPARU
15819                PARU(IPARU(I)) = PARUX(I)
15820     4       CONTINUE
15821          ENDIF
15822          LFIRST = .FALSE.
15823       ENDIF
15824 *
15825 * PARJ(1)  suppression of qq-aqaq pair prod. compared to
15826 *          q-aq pair prod.                      (default: 0.1)
15827 * PARJ(2)  strangeness suppression               (default: 0.3)
15828 * PARJ(3)  extra suppression of strange diquarks (default: 0.4)
15829 * PARJ(6)  extra suppression of sas-pair shared by B and
15830 *          aB in BMaB                           (default: 0.5)
15831 * PARJ(7)  extra suppression of strange meson M in BMaB
15832 *          configuration                        (default: 0.5)
15833 * PARJ(18) spin 3/2 baryon suppression           (default: 1.0)
15834 * PARJ(21) width sigma in Gaussian p_x, p_y transverse
15835 *          momentum distrib. for prim. hadrons  (default: 0.35)
15836 * PARJ(42) b-parameter for symmetric Lund-fragmentation
15837 *          function                             (default: 0.9 GeV^-2)
15838 *
15839 * PHOJET settings
15840       IF (MODE.EQ.1) THEN
15841 *   JETSET default
15842 C        PARJ(1)  = PDEF1
15843 C        PARJ(2)  = PDEF2
15844 C        PARJ(3)  = PDEF3
15845 C        PARJ(6)  = PDEF6
15846 C        PARJ(7)  = PDEF7
15847 C        PARJ(18) = PDEF18
15848 C        PARJ(21) = PDEF21
15849 C        PARJ(42) = PDEF42
15850 **sr 18.11.98 parameter tuning
15851 C        PARJ(1)  = 0.092D0
15852 C        PARJ(2)  = 0.25D0
15853 C        PARJ(3)  = 0.45D0
15854 C        PARJ(19) = 0.3D0
15855 C        PARJ(21) = 0.45D0
15856 C        PARJ(42) = 1.0D0
15857 **sr 28.04.99 parameter tuning (May 99 minor modifications)
15858          PARJ(1)  = 0.085D0
15859          PARJ(2)  = 0.26D0
15860          PARJ(3)  = 0.8D0
15861          PARJ(11) = 0.38D0
15862          PARJ(18) = 0.3D0
15863          PARJ(19) = 0.4D0
15864          PARJ(21) = 0.36D0
15865          PARJ(41) = 0.3D0
15866          PARJ(42) = 0.86D0
15867          IF (NPARJ.GT.0) THEN
15868             DO 10 I=1,NPARJ
15869                IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
15870    10       CONTINUE
15871          ENDIF
15872          IF (LFIRPH) THEN
15873             WRITE(LOUT,'(1X,A)')
15874      &         'DT_INITJS: JETSET-parameter for PHOJET'
15875             CALL DT_JSPARA(0)
15876             LFIRPH = .FALSE.
15877          ENDIF
15878 * DTUNUC settings
15879       ELSEIF (MODE.EQ.2) THEN
15880          IF (IFRAG(2).EQ.1) THEN
15881 **sr parameters before 9.3.96
15882 C           PARJ(2)  = 0.27D0
15883 C           PARJ(3)  = 0.6D0
15884 C           PARJ(6)  = 0.75D0
15885 C           PARJ(7)  = 0.75D0
15886 C           PARJ(21) = 0.55D0
15887 C           PARJ(42) = 1.3D0
15888 **sr 18.11.98 parameter tuning
15889 C           PARJ(1)  = 0.05D0
15890 C           PARJ(2)  = 0.27D0
15891 C           PARJ(3)  = 0.4D0
15892 C           PARJ(19) = 0.2D0
15893 C           PARJ(21) = 0.45D0
15894 C           PARJ(42) = 1.0D0
15895 **sr 28.04.99 parameter tuning
15896             PARJ(1)  = 0.11D0
15897             PARJ(2)  = 0.36D0
15898             PARJ(3)  = 0.8D0
15899             PARJ(19) = 0.2D0
15900             PARJ(21) = 0.3D0
15901             PARJ(41) = 0.3D0
15902             PARJ(42) = 0.58D0
15903             IF (NPARJ.GT.0) THEN
15904                DO 20 I=1,NPARJ
15905                   IF (IPARJ(I).LT.0) THEN
15906                      IDX = ABS(IPARJ(I))
15907                      PARJ(IDX) = PARJX(I)
15908                   ENDIF
15909    20          CONTINUE
15910             ENDIF
15911             IF (LFIRDT) THEN
15912                WRITE(LOUT,'(1X,A)')
15913      &           'DT_INITJS: JETSET-parameter for DTUNUC'
15914                CALL DT_JSPARA(0)
15915                LFIRDT = .FALSE.
15916             ENDIF
15917          ELSEIF (IFRAG(2).EQ.2) THEN
15918             PARJ(1)  = 0.11D0
15919             PARJ(2)  = 0.27D0
15920             PARJ(3)  = 0.3D0
15921             PARJ(6)  = 0.35D0
15922             PARJ(7)  = 0.45D0
15923             PARJ(18) = 0.66D0
15924 C           PARJ(21) = 0.55D0
15925 C           PARJ(42) = 1.0D0
15926             PARJ(21) = 0.60D0
15927             PARJ(42) = 1.3D0
15928          ELSE
15929             PARJ(1)  = PDEF1
15930             PARJ(2)  = PDEF2
15931             PARJ(3)  = PDEF3
15932             PARJ(6)  = PDEF6
15933             PARJ(7)  = PDEF7
15934             PARJ(18) = PDEF18
15935             PARJ(21) = PDEF21
15936             PARJ(42) = PDEF42
15937          ENDIF
15938       ELSE
15939          PARJ(1)  = PDEF1
15940          PARJ(2)  = PDEF2
15941          PARJ(3)  = PDEF3
15942          PARJ(5)  = PDEF5
15943          PARJ(6)  = PDEF6
15944          PARJ(7)  = PDEF7
15945          PARJ(18) = PDEF18
15946          PARJ(19) = PDEF19
15947          PARJ(21) = PDEF21
15948          PARJ(42) = PDEF42
15949          MSTJ(12) = MDEF12
15950       ENDIF
15951
15952       RETURN
15953       END
15954
15955 *$ CREATE DT_JSPARA.FOR
15956 *COPY DT_JSPARA
15957 *
15958 *===jspara=============================================================*
15959 *
15960       SUBROUTINE DT_JSPARA(MODE)
15961
15962       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15963       SAVE
15964       PARAMETER ( LINP = 10 ,
15965      &            LOUT = 6 ,
15966      &            LDAT = 9 )
15967       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
15968      &           ONE=1.0D0,ZERO=0.0D0)
15969
15970       LOGICAL LFIRST
15971
15972       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15973
15974       DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
15975
15976       DATA LFIRST /.TRUE./
15977
15978 * save the default JETSET-parameter on the first call
15979       IF (LFIRST) THEN
15980          DO 1 I=1,200
15981             ISTU(I) = MSTU(I)
15982             QARU(I) = PARU(I)
15983             ISTJ(I) = MSTJ(I)
15984             QARJ(I) = PARJ(I)
15985     1    CONTINUE
15986          LFIRST = .FALSE.
15987       ENDIF
15988
15989       WRITE(LOUT,1000)
15990  1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
15991
15992 * compare the default JETSET-parameter with the present values
15993       DO 2 I=1,200
15994          IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
15995             WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
15996 C           ISTU(I) = MSTU(I)
15997          ENDIF
15998          DIFF = ABS(PARU(I)-QARU(I))
15999          IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
16000             WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
16001 C           QARU(I) = PARU(I)
16002          ENDIF
16003          IF (MSTJ(I).NE.ISTJ(I)) THEN
16004             WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
16005 C           ISTJ(I) = MSTJ(I)
16006          ENDIF
16007          DIFF = ABS(PARJ(I)-QARJ(I))
16008          IF (DIFF.GE.1.0D-5) THEN
16009             WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
16010 C           QARJ(I) = PARJ(I)
16011          ENDIF
16012     2 CONTINUE
16013  1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
16014  1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
16015
16016       RETURN
16017       END
16018
16019 *$ CREATE DT_FOZOCA.FOR
16020 *COPY DT_FOZOCA
16021 *
16022 *===fozoca=============================================================*
16023 *
16024       SUBROUTINE DT_FOZOCA(LFZC,IREJ)
16025
16026 ************************************************************************
16027 * This subroutine treats the complete FOrmation ZOne supressed intra-  *
16028 * nuclear CAscade.                                                     *
16029 *               LFZC = .true.  cascade has been treated                *
16030 *                    = .false. cascade skipped                         *
16031 * This is a completely revised version of the original FOZOKL.         *
16032 * This version dated 18.11.95 is written by S. Roesler                 *
16033 ************************************************************************
16034
16035       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16036       SAVE
16037       PARAMETER ( LINP = 10 ,
16038      &            LOUT = 6 ,
16039      &            LDAT = 9 )
16040       PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
16041       PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16042
16043       LOGICAL LSTART,LCAS,LFZC
16044
16045 * event history
16046       PARAMETER (NMXHKK=200000)
16047       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16048      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16049      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16050 * extended event history
16051       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16052      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16053      &                IHIST(2,NMXHKK)
16054 * rejection counter
16055       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
16056      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
16057      &                IREXCI(3),IRDIFF(2),IRINC
16058 * properties of interacting particles
16059       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
16060 * Glauber formalism: collision properties
16061       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16062      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16063 * flags for input different options
16064       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16065       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16066      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16067 * final state after intranuclear cascade step
16068       COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16069 * parameter for intranuclear cascade
16070       LOGICAL LPAULI
16071       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16072
16073       DIMENSION NCWOUN(2)
16074
16075       DATA LSTART /.TRUE./
16076
16077       LFZC = .TRUE.
16078       IREJ = 0
16079
16080 * skip cascade if hadron-hadron interaction or if supressed by user
16081       IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999
16082 * skip cascade if not all possible chains systems are hadronized
16083       DO 1 I=1,8
16084          IF (.NOT.LHADRO(I)) GOTO 9999
16085     1 CONTINUE
16086
16087       IF (LSTART) THEN
16088          WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD
16089  1000    FORMAT(/,1X,'FOZOCA:  intranuclear cascade treated for a ',
16090      &          'maximum of',I4,' generations',/,10X,'formation time ',
16091      &          'parameter:',F5.1,'  fm/c',9X,'modus:',I2)
16092          IF (ITAUVE.EQ.1) WRITE(LOUT,1001)
16093          IF (ITAUVE.EQ.2) WRITE(LOUT,1002)
16094  1001    FORMAT(10X,'p_t dependent formation zone',/)
16095  1002    FORMAT(10X,'constant formation zone',/)
16096          LSTART = .FALSE.
16097       ENDIF
16098
16099 * in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons
16100 * which may interact with final state particles are stored in a seperate
16101 * array - here all proj./target nucleon-indices (just for simplicity)
16102       NOINC = 0
16103       DO 9 I=1,NPOINT(1)-1
16104          NOINC = NOINC+1
16105          IDXINC(NOINC) = I
16106     9 CONTINUE
16107
16108 * initialize Pauli-principle treatment (find wounded nucleons)
16109       NWOUND(1) = 0
16110       NWOUND(2) = 0
16111       NCWOUN(1) = 0
16112       NCWOUN(2) = 0
16113       DO 2 J=1,NPOINT(1)
16114          DO 3 I=1,2
16115             IF (ISTHKK(J).EQ.10+I) THEN
16116                NWOUND(I) = NWOUND(I)+1
16117                EWOUND(I,NWOUND(I)) = PHKK(4,J)
16118                IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1
16119             ENDIF
16120     3    CONTINUE
16121     2 CONTINUE
16122
16123 * modify nuclear potential for wounded nucleons
16124       IPRCL  = IP -NWOUND(1)
16125       IPZRCL = IPZ-NCWOUN(1)
16126       ITRCL  = IT -NWOUND(2)
16127       ITZRCL = ITZ-NCWOUN(2)
16128       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
16129
16130       NSTART = NPOINT(4)
16131       NEND   = NHKK
16132
16133     7 CONTINUE
16134       DO 8 I=NSTART,NEND
16135
16136          IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
16137 * select nucleus the cascade starts first (proj. - 1, target - -1)
16138             NCAS   = 1
16139 *   projectile/target with probab. 1/2
16140             IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN
16141                IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16142 *   in the nucleus with highest mass
16143             ELSEIF (INCMOD.EQ.2) THEN
16144                IF (IP.GT.IT) THEN
16145                   NCAS = -NCAS
16146                ELSEIF (IP.EQ.IT) THEN
16147                   IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16148                ENDIF
16149 * the nucleus the cascade starts first is requested to be the one
16150 * moving in the direction of the secondary
16151             ELSEIF (INCMOD.EQ.3) THEN
16152                NCAS = INT(SIGN(1.0D0,PHKK(3,I)))
16153             ENDIF
16154 * check that the selected "nucleus" is not a hadron
16155             IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR.
16156      &          ((NCAS.EQ.-1).AND.(IT.LE.1)))    NCAS = -NCAS
16157
16158 * treat intranuclear cascade in the nucleus selected first
16159             LCAS = .FALSE.
16160             CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16161             IF (IREJ1.NE.0) GOTO 9998
16162 * treat intranuclear cascade in the other nucleus if this isn't a had.
16163             NCAS = -NCAS
16164             IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR.
16165      &          ((NCAS.EQ.-1).AND.(IT.GT.1)))    THEN
16166                IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16167                IF (IREJ1.NE.0) GOTO 9998
16168             ENDIF
16169
16170          ENDIF
16171
16172     8 CONTINUE
16173       NSTART = NEND+1
16174       NEND   = NHKK
16175       IF (NSTART.LE.NEND) GOTO 7
16176
16177       RETURN
16178
16179  9998 CONTINUE
16180 * reject this event
16181       IRINC = IRINC+1
16182       IREJ = 1
16183
16184  9999 CONTINUE
16185 * intranucl. cascade not treated because of interaction properties or
16186 * it is supressed by user or it was rejected or...
16187       LFZC = .FALSE.
16188 * reset flag characterizing direction of motion in n-n-cms
16189 **sr14-11-95
16190 C     DO 9990 I=NPOINT(5),NHKK
16191 C        IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
16192 C9990 CONTINUE
16193
16194       RETURN
16195       END
16196
16197 *$ CREATE DT_INUCAS.FOR
16198 *COPY DT_INUCAS
16199 *
16200 *===inucas=============================================================*
16201 *
16202       SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
16203
16204 ************************************************************************
16205 * Formation zone supressed IntraNUclear CAScade for one final state    *
16206 * particle.                                                            *
16207 *           IT, IP    mass numbers of target, projectile nuclei        *
16208 *           IDXCAS    index of final state particle in DTEVT1          *
16209 *           NCAS =  1 intranuclear cascade in projectile               *
16210 *                = -1 intranuclear cascade in target                   *
16211 * This version dated 18.11.95 is written by S. Roesler                 *
16212 ************************************************************************
16213
16214       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16215       SAVE
16216       PARAMETER ( LINP = 10 ,
16217      &            LOUT = 6 ,
16218      &            LDAT = 9 )
16219
16220       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
16221      &           OHALF=0.5D0,ONE=1.0D0)
16222       PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16223       PARAMETER (TWOPI=6.283185307179586454D+00)
16224       PARAMETER (PLOWH=0.01D0,PHIH=9.0D0)
16225
16226       LOGICAL LABSOR,LCAS
16227
16228 * event history
16229       PARAMETER (NMXHKK=200000)
16230       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16231      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16232      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16233 * extended event history
16234       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16235      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16236      &                IHIST(2,NMXHKK)
16237 * final state after inc step
16238       PARAMETER (MAXFSP=10)
16239       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
16240 * flags for input different options
16241       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16242       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16243      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16244 * particle properties (BAMJET index convention)
16245       CHARACTER*8  ANAME
16246       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
16247      &                IICH(210),IIBAR(210),K1(210),K2(210)
16248 * Glauber formalism: collision properties
16249       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16250      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16251 * nuclear potential
16252       LOGICAL LFERMI
16253       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
16254      &                EBINDP(2),EBINDN(2),EPOT(2,210),
16255      &                ETACOU(2),ICOUL,LFERMI
16256 * parameter for intranuclear cascade
16257       LOGICAL LPAULI
16258       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16259 * final state after intranuclear cascade step
16260       COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16261 * nucleon-nucleon event-generator
16262       CHARACTER*8 CMODEL
16263       LOGICAL LPHOIN
16264       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
16265 * statistics: residual nuclei
16266       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
16267      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
16268      &                NINCST(2,4),NINCEV(2),
16269      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
16270      &                NRESPB(2),NRESCH(2),NRESEV(4),
16271      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
16272      &                NEVAFI(2,2)
16273
16274       DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4),
16275      &          PCAS1(5),PNUC(5),BGTA(4),
16276      &          BGCAS(2),GACAS(2),BECAS(2),
16277      &          RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2)
16278
16279       DATA PDIF /0.545D0/
16280
16281       IREJ = 0
16282
16283 * update counter
16284       IF (NINCEV(1).NE.NEVHKK) THEN
16285          NINCEV(1) = NEVHKK
16286          NINCEV(2) = NINCEV(2)+1
16287       ENDIF
16288
16289 * "BAMJET-index" of this hadron
16290       IDCAS = IDBAM(IDXCAS)
16291       IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
16292
16293 * skip gammas, electrons, etc..
16294       IF (AAM(IDCAS).LT.TINY2) RETURN
16295
16296 * Lorentz-trsf. into projectile rest system
16297       IF (IP.GT.1) THEN
16298          CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16299      &               PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3),
16300      &               PCAS(1,4),IDCAS,-2)
16301          PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2)
16302          PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1))
16303          IF (PCAS(1,5).GT.ZERO) THEN
16304             PCAS(1,5) = SQRT(PCAS(1,5))
16305          ELSE
16306             PCAS(1,5) = AAM(IDCAS)
16307          ENDIF
16308          DO 20 K=1,3
16309             COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
16310    20    CONTINUE
16311 * Lorentz-parameters
16312 *   particle rest system --> projectile rest system
16313          BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10)
16314          GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10)
16315          BECAS(1) = BGCAS(1)/GACAS(1)
16316       ELSE
16317          DO 21 K=1,5
16318             PCAS(1,K) = ZERO
16319             IF (K.LE.3) COSCAS(1,K) = ZERO
16320    21    CONTINUE
16321          PTOCAS(1) = ZERO
16322          BGCAS(1)  = ZERO
16323          GACAS(1)  = ZERO
16324          BECAS(1)  = ZERO
16325       ENDIF
16326 * Lorentz-trsf. into target rest system
16327       IF (IT.GT.1) THEN
16328 * LEPTO: final state particles are already in target rest frame
16329 C        IF (MCGENE.EQ.3) THEN
16330 C           PCAS(2,1) = PHKK(1,IDXCAS)
16331 C           PCAS(2,2) = PHKK(2,IDXCAS)
16332 C           PCAS(2,3) = PHKK(3,IDXCAS)
16333 C           PCAS(2,4) = PHKK(4,IDXCAS)
16334 C        ELSE
16335             CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16336      &                  PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3),
16337      &                  PCAS(2,4),IDCAS,-3)
16338 C        ENDIF
16339          PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2)
16340          PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2))
16341          IF (PCAS(2,5).GT.ZERO) THEN
16342             PCAS(2,5) = SQRT(PCAS(2,5))
16343          ELSE
16344             PCAS(2,5) = AAM(IDCAS)
16345          ENDIF
16346          DO 22 K=1,3
16347             COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
16348    22    CONTINUE
16349 * Lorentz-parameters
16350 *   particle rest system --> target rest system
16351          BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10)
16352          GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10)
16353          BECAS(2) = BGCAS(2)/GACAS(2)
16354       ELSE
16355          DO 23 K=1,5
16356             PCAS(2,K) = ZERO
16357             IF (K.LE.3) COSCAS(2,K) = ZERO
16358    23    CONTINUE
16359          PTOCAS(2) = ZERO
16360          BGCAS(2)  = ZERO
16361          GACAS(2)  = ZERO
16362          BECAS(2)  = ZERO
16363       ENDIF
16364
16365 * radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
16366 * potential (see CONUCL)
16367       RNUC(1)  = (RPROJ+4.605D0*PDIF)*FM2MM
16368       RNUC(2)  = (RTARG+4.605D0*PDIF)*FM2MM
16369 * impact parameter (the projectile moving along z)
16370       BIMPC(1) = ZERO
16371       BIMPC(2) = BIMPAC*FM2MM
16372
16373 * get position of initial hadron in projectile/target rest-syst.
16374       DO 3 K=1,4
16375          VTXCAS(1,K) = WHKK(K,IDXCAS)
16376          VTXCAS(2,K) = VHKK(K,IDXCAS)
16377     3 CONTINUE
16378
16379       ICAS = 1
16380       I2   = 2
16381       IF (NCAS.EQ.-1) THEN
16382          ICAS = 2
16383          I2   = 1
16384       ENDIF
16385
16386       IF (PTOCAS(ICAS).LT.TINY10) THEN
16387          WRITE(LOUT,1000) PTOCAS
16388  1000    FORMAT(1X,'INUCAS:   warning! zero momentum of initial',
16389      &          '  hadron ',/,20X,2E12.4)
16390          GOTO 9999
16391       ENDIF
16392
16393 * reset spectator flags
16394       NSPE = 0
16395       IDXSPE(1) = 0
16396       IDXSPE(2) = 0
16397       IDSPE(1)  = 0
16398       IDSPE(2)  = 0
16399
16400 * formation length (in fm)
16401 C     IF (LCAS) THEN
16402 C        DEL0 = ZERO
16403 C     ELSE
16404          DEL0 = TAUFOR*BGCAS(ICAS)
16405          IF (ITAUVE.EQ.1) THEN
16406             AMT  = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2
16407             DEL0 = DEL0*PCAS(ICAS,5)**2/AMT
16408          ENDIF
16409 C     ENDIF
16410 *   sample from exp(-del/del0)
16411       DEL1   = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10))
16412 * save formation time
16413       TAUSA1 = DEL1/BGCAS(ICAS)
16414       REL1   = TAUSA1*BGCAS(I2)
16415
16416       DEL    = DEL1
16417       TAUSAM = DEL/BGCAS(ICAS)
16418       REL    = TAUSAM*BGCAS(I2)
16419
16420 * special treatment for negative particles unable to escape
16421 * nuclear potential (implemented for ap, pi-, K- only)
16422       LABSOR = .FALSE.
16423       IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN
16424 *   threshold energy = nuclear potential + Coulomb potential
16425 *   (nuclear potential for hadron-nucleus interactions only)
16426          ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS)
16427          IF (PCAS(ICAS,4).LT.ETHR) THEN
16428             DO 4 K=1,5
16429                PCAS1(K) = PCAS(ICAS,K)
16430     4       CONTINUE
16431 *   "absorb" negative particle in nucleus
16432             CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1)
16433             IF (IREJ1.NE.0) GOTO 9999
16434             IF (NSPE.GE.1) LABSOR = .TRUE.
16435          ENDIF
16436       ENDIF
16437
16438 * if the initial particle has not been absorbed proceed with
16439 * "normal" cascade
16440       IF (.NOT.LABSOR) THEN
16441
16442 *   calculate coordinates of hadron at the end of the formation zone
16443 *   transport-time and -step in the rest system where this step is
16444 *   treated
16445          DSTEP  = DEL*FM2MM
16446          DTIME  = DSTEP/BECAS(ICAS)
16447          RSTEP  = REL*FM2MM
16448          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16449             RTIME = RSTEP/BECAS(I2)
16450          ELSE
16451             RTIME = ZERO
16452          ENDIF
16453 *   save step whithout considering the overlapping region
16454          DSTEP1 = DEL1*FM2MM
16455          DTIME1 = DSTEP1/BECAS(ICAS)
16456          RSTEP1 = REL1*FM2MM
16457          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16458             RTIME1 = RSTEP1/BECAS(I2)
16459          ELSE
16460             RTIME1 = ZERO
16461          ENDIF
16462 *   transport to the end of the formation zone in this system
16463          DO 5 K=1,3
16464             VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K)
16465             VTXCA1(I2,K)   = VTXCAS(I2,K)  +RSTEP1*COSCAS(I2,K)
16466             VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K)
16467             VTXCAS(I2,K)   = VTXCAS(I2,K)  +RSTEP*COSCAS(I2,K)
16468     5    CONTINUE
16469          VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1
16470          VTXCA1(I2,4)   = VTXCAS(I2,4)  +RTIME1
16471          VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME
16472          VTXCAS(I2,4)   = VTXCAS(I2,4)  +RTIME
16473
16474          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16475             XCAS   = VTXCAS(ICAS,1)
16476             YCAS   = VTXCAS(ICAS,2)
16477             XNCLTA = BIMPAC*FM2MM
16478             RNCLPR = (RPROJ+RNUCLE)*FM2MM
16479             RNCLTA = (RTARG+RNUCLE)*FM2MM
16480 C           RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
16481 C           RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
16482 C           RNCLPR = (RPROJ)*FM2MM
16483 C           RNCLTA = (RTARG)*FM2MM
16484             RCASPR = SQRT( XCAS**2        +YCAS**2)
16485             RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2)
16486             IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN
16487                IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3
16488             ENDIF
16489          ENDIF
16490
16491 *   check if particle is already outside of the corresp. nucleus
16492          RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+
16493      &                VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2)
16494          IF (RDIST.GE.RNUC(ICAS)) THEN
16495 *   here: IDCH is the generation of the final state part. starting
16496 *   with zero for hadronization products
16497 *   flag particles of generation 0 being outside the nuclei after
16498 *   formation time (to be used for excitation energy calculation)
16499             IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3))
16500      &         NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS
16501             GOTO 9997
16502          ENDIF
16503          DIST   = DLARGE
16504          DISTP  = DLARGE
16505          DISTN  = DLARGE
16506          IDXP   = 0
16507          IDXN   = 0
16508
16509 *   already here: skip particles being outside HADRIN "energy-window"
16510 *   to avoid wasting of time
16511          NINCHR(ICAS,1) = NINCHR(ICAS,1)+1
16512          IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN
16513             NINCHR(ICAS,2) = NINCHR(ICAS,2)+1
16514 C           WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
16515 C1002       FORMAT(1X,'INUCAS:   warning! momentum of particle with ',
16516 C    &             'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
16517 C    &             E12.4,', above or below HADRIN-thresholds',I6)
16518             NSPE = 0
16519             GOTO 9997
16520          ENDIF
16521
16522          DO 7 IDXHKK=1,NOINC
16523             I = IDXINC(IDXHKK)
16524 *   scan DTEVT1 for unwounded or excited nucleons
16525             IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
16526                DO 8 K=1,3
16527                   IF (ICAS.EQ.1) THEN
16528                      VTXDST(K) = WHKK(K,I)-VTXCAS(1,K)
16529                   ELSEIF (ICAS.EQ.2) THEN
16530                      VTXDST(K) = VHKK(K,I)-VTXCAS(2,K)
16531                   ENDIF
16532     8          CONTINUE
16533                POSNUC = VTXDST(1)*COSCAS(ICAS,1)+
16534      &                  VTXDST(2)*COSCAS(ICAS,2)+
16535      &                  VTXDST(3)*COSCAS(ICAS,3)
16536 *   check if nucleon is situated in forward direction
16537                IF (POSNUC.GT.ZERO) THEN
16538 *   distance between hadron and this nucleon
16539                   DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16540      &                          VTXDST(3)**2)
16541 *   impact parameter
16542                   BIMNU2 = DISTNU**2-POSNUC**2
16543                   IF (BIMNU2.LT.ZERO) THEN
16544                      WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2
16545  1001                FORMAT(1X,'INUCAS:   warning! inconsistent impact',
16546      &                      '  parameter ',/,20X,3E12.4)
16547                      GOTO 7
16548                   ENDIF
16549                   BIMNU  = SQRT(BIMNU2)
16550 *   maximum impact parameter to have interaction
16551                   IDNUC  = IDT_ICIHAD(IDHKK(I))
16552                   IDNUC1 = IDT_MCHAD(IDNUC)
16553                   IDCAS1 = IDT_MCHAD(IDCAS)
16554                   DO 19 K=1,5
16555                      PCAS1(K) = PCAS(ICAS,K)
16556                      PNUC(K)  = PHKK(K,I)
16557    19             CONTINUE
16558 * Lorentz-parameter for trafo into rest-system of target
16559                   DO 18 K=1,4
16560                      BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
16561    18             CONTINUE
16562 * transformation of projectile into rest-system of target
16563                   CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
16564      &                        PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4),
16565      &                        PPTOT,PX,PY,PZ,PE)
16566 **
16567 C                 CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
16568 C                 CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
16569                   DUMZER = ZERO
16570                   CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL)
16571                   CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB)
16572                   IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND.
16573      &                (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0
16574                   SIGIN = SIGTOT-SIGEL-SIGAB
16575 C                 SIGTOT = SIGIN+SIGEL+SIGAB
16576 **
16577                   BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM
16578 *   check if interaction is possible
16579                   IF (BIMNU.LE.BIMMAX) THEN
16580 *   get nucleon with smallest distance and kind of interaction
16581 *   (elastic/inelastic)
16582                      IF (DISTNU.LT.DIST) THEN
16583                         DIST      = DISTNU
16584                         BINT      = BIMNU
16585                         IF (IDNUC.NE.IDSPE(1)) THEN
16586                            IDSPE(2)  = IDSPE(1)
16587                            IDXSPE(2) = IDXSPE(1)
16588                            IDSPE(1)  = IDNUC
16589                         ENDIF
16590                         IDXSPE(1) = I
16591                         NSPE      = 1
16592 **sr
16593                         SELA = SIGEL
16594                         SABS = SIGAB
16595                         STOT = SIGTOT
16596 C                       IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
16597 C                          SELA = SIGEL
16598 C                          STOT = SIGIN+SIGEL
16599 C                       ELSE
16600 C                          SELA = SIGEL+0.75D0*SIGIN
16601 C                          STOT = 0.25D0*SIGIN+SELA
16602 C                       ENDIF
16603 **
16604                      ENDIF
16605                   ENDIf
16606                ENDIF
16607                DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16608      &                       VTXDST(3)**2)
16609                IDNUC  = IDT_ICIHAD(IDHKK(I))
16610                IF (IDNUC.EQ.1) THEN
16611                   IF (DISTNU.LT.DISTP) THEN
16612                      DISTP = DISTNU
16613                      IDXP  = I
16614                      POSP  = POSNUC
16615                   ENDIF
16616                ELSEIF (IDNUC.EQ.8) THEN
16617                   IF (DISTNU.LT.DISTN) THEN
16618                      DISTN = DISTNU
16619                      IDXN  = I
16620                      POSN  = POSNUC
16621                   ENDIF
16622                ENDIF
16623             ENDIF
16624     7    CONTINUE
16625
16626 * there is no nucleon for a secondary interaction
16627          IF (NSPE.EQ.0) GOTO 9997
16628
16629 C        IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
16630 C    &      WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
16631          IF (IDXSPE(2).EQ.0) THEN
16632             IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
16633 C              DO 80 K=1,3
16634 C                 IF (ICAS.EQ.1) THEN
16635 C                    VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
16636 C                 ELSEIF (ICAS.EQ.2) THEN
16637 C                    VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
16638 C                 ENDIF
16639 C  80          CONTINUE
16640 C              DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16641 C    &                       VTXDST(3)**2)
16642 C              IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
16643                   IDXSPE(2) = IDXN
16644                   IDSPE(2)  = 8
16645 C              ELSE
16646 C                 STOT = STOT-SABS
16647 C                 SABS = ZERO
16648 C              ENDIF
16649             ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
16650 C              DO 81 K=1,3
16651 C                 IF (ICAS.EQ.1) THEN
16652 C                    VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
16653 C                 ELSEIF (ICAS.EQ.2) THEN
16654 C                    VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
16655 C                 ENDIF
16656 C  81          CONTINUE
16657 C              DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16658 C    &                       VTXDST(3)**2)
16659 C              IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
16660                   IDXSPE(2) = IDXP
16661                   IDSPE(2)  = 1
16662 C              ELSE
16663 C                 STOT = STOT-SABS
16664 C                 SABS = ZERO
16665 C              ENDIF
16666             ELSE
16667                STOT = STOT-SABS
16668                SABS = ZERO
16669             ENDIF
16670          ENDIF
16671          RR = DT_RNDM(DIST)
16672          IF (RR.LT.SELA/STOT) THEN
16673             IPROC = 2
16674          ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
16675             IPROC = 3
16676          ELSE
16677             IPROC = 1
16678          ENDIF
16679
16680          DO 9 K=1,5
16681             PCAS1(K) = PCAS(ICAS,K)
16682             PNUC(K)  = PHKK(K,IDXSPE(1))
16683     9    CONTINUE
16684          IF (IPROC.EQ.3) THEN
16685 * 2-nucleon absorption of pion
16686             NSPE = 2
16687             CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1)
16688             IF (IREJ1.NE.0) GOTO 9999
16689             IF (NSPE.GE.1) LABSOR = .TRUE.
16690          ELSE
16691 * sample secondary interaction
16692             IDNUC = IDBAM(IDXSPE(1))
16693             CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1)
16694             IF (IREJ1.EQ.1) GOTO 9999
16695             IF (IREJ1.GT.1) GOTO 9998
16696          ENDIF
16697       ENDIF
16698
16699 * update arrays to include Pauli-principle
16700       DO 10 I=1,NSPE
16701          IF (NWOUND(ICAS).LE.299) THEN
16702             NWOUND(ICAS) = NWOUND(ICAS)+1
16703             EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
16704          ENDIF
16705    10 CONTINUE
16706
16707 * dump initial hadron for energy-momentum conservation check
16708       IF (LEMCCK)
16709      &   CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
16710      &               PCAS(ICAS,4),1,IDUM,IDUM)
16711
16712 * dump final state particles into DTEVT1
16713
16714 *   check if Pauli-principle is fulfilled
16715       NPAULI = 0
16716       NWTMP(1) = NWOUND(1)
16717       NWTMP(2) = NWOUND(2)
16718       DO 111 I=1,NFSP
16719          NPAULI = 0
16720          J1 = 2
16721          IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16722      &       ((NCAS.EQ.-1).AND.(IP.LE.1)))    J1 = 1
16723          DO 117 J=1,J1
16724             IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
16725             IF (J.EQ.1) THEN
16726                IDX = ICAS
16727                PE  = PFSP(4,I)
16728             ELSE
16729                IDX  = I2
16730                MODE = 1
16731                IF (IDX.EQ.1) MODE = -1
16732                CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
16733             ENDIF
16734 * first check if cascade step is forbidden due to Pauli-principle
16735 * (in case of absorpion this step is forced)
16736             IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16737      &          (IDFSP(I).EQ.8))) THEN
16738 *   get nuclear potential barrier
16739                POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16740                IF (IDFSP(I).EQ.1) THEN
16741                   POTLOW = POT-EBINDP(IDX)
16742                ELSE
16743                   POTLOW = POT-EBINDN(IDX)
16744                ENDIF
16745 *   final state particle not able to escape nucleus
16746                IF (PE.LE.POTLOW) THEN
16747 *     check if there are wounded nucleons
16748                   IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16749      &                 EWOUND(IDX,NWOUND(IDX)))) THEN
16750                      NPAULI      = NPAULI+1
16751                      NWOUND(IDX) = NWOUND(IDX)-1
16752                   ELSE
16753 *     interaction prohibited by Pauli-principle
16754                      NWOUND(1) = NWTMP(1)
16755                      NWOUND(2) = NWTMP(2)
16756                      GOTO 9997
16757                   ENDIF
16758                ENDIF
16759             ENDIF
16760   117    CONTINUE
16761   111 CONTINUE
16762
16763       NPAULI = 0
16764       NWOUND(1) = NWTMP(1)
16765       NWOUND(2) = NWTMP(2)
16766
16767       DO 11 I=1,NFSP
16768
16769          IST = ISTHKK(IDXCAS)
16770
16771          NPAULI = 0
16772          J1 = 2
16773          IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16774      &       ((NCAS.EQ.-1).AND.(IP.LE.1)))    J1 = 1
16775          DO 17 J=1,J1
16776             IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
16777             IDX = ICAS
16778             PE  = PFSP(4,I)
16779             IF (J.EQ.2) THEN
16780                IDX = I2
16781                CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
16782             ENDIF
16783 * first check if cascade step is forbidden due to Pauli-principle
16784 * (in case of absorpion this step is forced)
16785             IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16786      &          (IDFSP(I).EQ.8))) THEN
16787 *   get nuclear potential barrier
16788                POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16789                IF (IDFSP(I).EQ.1) THEN
16790                   POTLOW = POT-EBINDP(IDX)
16791                ELSE
16792                   POTLOW = POT-EBINDN(IDX)
16793                ENDIF
16794 *   final state particle not able to escape nucleus
16795                IF (PE.LE.POTLOW) THEN
16796 *     check if there are wounded nucleons
16797                   IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16798      &                 EWOUND(IDX,NWOUND(IDX)))) THEN
16799                      NWOUND(IDX) = NWOUND(IDX)-1
16800                      NPAULI = NPAULI+1
16801                      IST    = 14+IDX
16802                   ELSE
16803 *     interaction prohibited by Pauli-principle
16804                      NWOUND(1) = NWTMP(1)
16805                      NWOUND(2) = NWTMP(2)
16806                      GOTO 9997
16807                   ENDIF
16808 **sr
16809 c               ELSEIF (PE.LE.POT) THEN
16810 cC              ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
16811 cC                 NWOUND(IDX) = NWOUND(IDX)-1
16812 c**
16813 c                  NPAULI = NPAULI+1
16814 c                  IST    = 14+IDX
16815                ENDIF
16816             ENDIF
16817    17    CONTINUE
16818
16819 * dump final state particles for energy-momentum conservation check
16820          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I),
16821      &                           -PFSP(4,I),2,IDUM,IDUM)
16822
16823          PX = PFSP(1,I)
16824          PY = PFSP(2,I)
16825          PZ = PFSP(3,I)
16826          PE = PFSP(4,I)
16827          IF (ABS(IST).EQ.1) THEN
16828 * transform particles back into n-n cms
16829 * LEPTO: leave final state particles in target rest frame
16830 C           IF (MCGENE.EQ.3) THEN
16831 C              PFSP(1,I) = PX
16832 C              PFSP(2,I) = PY
16833 C              PFSP(3,I) = PZ
16834 C              PFSP(4,I) = PE
16835 C           ELSE
16836                IMODE = ICAS+1
16837                CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16838      &                     PFSP(4,I),IDFSP(I),IMODE)
16839 C           ENDIF
16840          ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN
16841 * target cascade but fsp got stuck in proj. --> transform it into
16842 * proj. rest system
16843             CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16844      &                  PFSP(4,I),IDFSP(I),-1)
16845          ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN
16846 * proj. cascade but fsp got stuck in target --> transform it into
16847 * target rest system
16848             CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16849      &                  PFSP(4,I),IDFSP(I),1)
16850          ENDIF
16851
16852 * dump final state particles into DTEVT1
16853          IGEN = IDCH(IDXCAS)+1
16854          ID   = IDT_IPDGHA(IDFSP(I))
16855          IXR  = 0
16856          IF (LABSOR) IXR = 99
16857          CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I),
16858      &               PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN)
16859
16860 * update the counter for particles which got stuck inside the nucleus
16861          IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
16862             NOINC = NOINC+1
16863             IDXINC(NOINC) = NHKK
16864          ENDIF
16865          IF (LABSOR) THEN
16866 *   in case of absorption the spatial treatment is an approximate
16867 *   solution anyway (the positions of the nucleons which "absorb" the
16868 *   cascade particle are not taken into consideration) therefore the
16869 *   particles are produced at the position of the cascade particle
16870             DO 12 K=1,4
16871                WHKK(K,NHKK) = WHKK(K,IDXCAS)
16872                VHKK(K,NHKK) = VHKK(K,IDXCAS)
16873    12       CONTINUE
16874          ELSE
16875 *   DDISTL - distance the cascade particle moves to the intera. point
16876 *   (the position where impact-parameter = distance to the interacting
16877 *   nucleon), DIST - distance to the interacting nucleon at the time of
16878 *   formation of the cascade particle, BINT - impact-parameter of this
16879 *   cascade-interaction
16880             DDISTL = SQRT(DIST**2-BINT**2)
16881             DTIME  = DDISTL/BECAS(ICAS)
16882             DTIMEL = DDISTL/BGCAS(ICAS)
16883             RDISTL = DTIMEL*BGCAS(I2)
16884             IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16885                RTIME = RDISTL/BECAS(I2)
16886             ELSE
16887                RTIME = ZERO
16888             ENDIF
16889 *   RDISTL, RTIME are this step and time in the rest system of the other
16890 *   nucleus
16891             DO 13 K=1,3
16892                VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
16893                VTXCA1(I2,K)   = VTXCAS(I2,K)  +COSCAS(I2,K)  *RDISTL
16894    13       CONTINUE
16895             VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME
16896             VTXCA1(I2,4)   = VTXCAS(I2,4)  +RTIME
16897 *   position of particle production is half the impact-parameter to
16898 *   the interacting nucleon
16899             DO 14 K=1,3
16900                WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
16901                VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
16902    14       CONTINUE
16903 *   time of production of secondary = time of interaction
16904             WHKK(4,NHKK) = VTXCA1(1,4)
16905             VHKK(4,NHKK) = VTXCA1(2,4)
16906          ENDIF
16907
16908    11 CONTINUE
16909
16910 * modify status and position of cascade particle (the latter for
16911 * statistics reasons only)
16912       ISTHKK(IDXCAS) = 2
16913       IF (LABSOR) ISTHKK(IDXCAS) = 19
16914       IF (.NOT.LABSOR) THEN
16915          DO 15 K=1,4
16916             WHKK(K,IDXCAS) = VTXCA1(1,K)
16917             VHKK(K,IDXCAS) = VTXCA1(2,K)
16918    15    CONTINUE
16919       ENDIF
16920
16921       DO 16 I=1,NSPE
16922          IS = IDXSPE(I)
16923 * dump interacting nucleons for energy-momentum conservation check
16924          IF (LEMCCK)
16925      &      CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
16926      &                                                  2,IDUM,IDUM)
16927 * modify entry for interacting nucleons
16928          IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS
16929          IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2
16930          IF (I.GE.2) THEN
16931             JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
16932             JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
16933          ENDIF
16934    16 CONTINUE
16935
16936 * check energy-momentum conservation
16937       IF (LEMCCK) THEN
16938          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
16939          IF (IREJ1.NE.0) GOTO 9999
16940       ENDIF
16941
16942 * update counter
16943       IF (LABSOR) THEN
16944          NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
16945       ELSE
16946          IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
16947          IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
16948       ENDIF
16949
16950       RETURN
16951
16952  9997 CONTINUE
16953  9998 CONTINUE
16954 * transport-step but no cascade step due to configuration (i.e. there
16955 * is no nucleon for interaction etc.)
16956       IF (LCAS) THEN
16957          DO 100 K=1,4
16958 C           WHKK(K,IDXCAS) = VTXCAS(1,K)
16959 C           VHKK(K,IDXCAS) = VTXCAS(2,K)
16960             WHKK(K,IDXCAS) = VTXCA1(1,K)
16961             VHKK(K,IDXCAS) = VTXCA1(2,K)
16962   100    CONTINUE
16963       ENDIF
16964
16965 C9998 CONTINUE
16966 * no cascade-step because of configuration
16967 * (i.e. hadron outside nucleus etc.)
16968       LCAS = .TRUE.
16969       RETURN
16970
16971  9999 CONTINUE
16972 * rejection
16973       IREJ = 1
16974       RETURN
16975       END
16976
16977 *$ CREATE DT_ABSORP.FOR
16978 *COPY DT_ABSORP
16979 *
16980 *===absorp=============================================================*
16981 *
16982       SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
16983
16984 ************************************************************************
16985 * Two-nucleon absorption of antiprotons, pi-, and K-.                  *
16986 * Antiproton absorption is handled by HADRIN.                          *
16987 * The following channels for meson-absorption are considered:          *
16988 *          pi- + p + p ---> n + p                                      *
16989 *          pi- + p + n ---> n + n                                      *
16990 *          K-  + p + p ---> sigma+ + n / Lam + p / sigma0 + p          *
16991 *          K-  + p + n ---> sigma- + n / Lam + n / sigma0 + n          *
16992 *          K-  + p + p ---> sigma- + n                                 *
16993 *      IDCAS, PCAS   identity, momentum of particle to be absorbed     *
16994 *      NCAS =  1     intranuclear cascade in projectile                *
16995 *           = -1     intranuclear cascade in target                    *
16996 *      NSPE          number of spectator nucleons involved             *
16997 *      IDXSPE(2)     DTEVT1-indices of spectator nucleons involved     *
16998 * Revised version of the original STOPIK written by HJM and J. Ranft.  *
16999 * This version dated 24.02.95 is written by S. Roesler                 *
17000 ************************************************************************
17001
17002       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17003       SAVE
17004       PARAMETER ( LINP = 10 ,
17005      &            LOUT = 6 ,
17006      &            LDAT = 9 )
17007       PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0,
17008      &           ONETHI=0.3333D0,TWOTHI=0.6666D0)
17009
17010 * event history
17011       PARAMETER (NMXHKK=200000)
17012       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17013      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17014      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17015 * extended event history
17016       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17017      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17018      &                IHIST(2,NMXHKK)
17019 * flags for input different options
17020       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17021       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17022      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17023 * final state after inc step
17024       PARAMETER (MAXFSP=10)
17025       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17026 * particle properties (BAMJET index convention)
17027       CHARACTER*8  ANAME
17028       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17029      &                IICH(210),IIBAR(210),K1(210),K2(210)
17030
17031       DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5),
17032      &          PTOT3P(4),BG3P(4),
17033      &          ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2)
17034
17035       IREJ = 0
17036       NFSP = 0
17037
17038 * skip particles others than ap, pi-, K- for mode=0
17039       IF ((MODE.EQ.0).AND.
17040      &    (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN
17041 * skip particles others than pions for mode=1
17042 * (2-nucleon absorption in intranuclear cascade)
17043       IF ((MODE.EQ.1).AND.
17044      &    (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN
17045
17046       NUCAS = NCAS
17047       IF (NUCAS.EQ.-1) NUCAS = 2
17048
17049       IF (MODE.EQ.0) THEN
17050 * scan spectator nucleons for nucleons being able to "absorb"
17051          NSPE      = 0
17052          IDXSPE(1) = 0
17053          IDXSPE(2) = 0
17054          DO 1 I=1,NHKK
17055             IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
17056                NSPE         = NSPE+1
17057                IDXSPE(NSPE) = I
17058                IDSPE(NSPE)  = IDBAM(I)
17059                IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2
17060                IF (NSPE.EQ.2) THEN
17061                   IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND.
17062      &                                  (IDSPE(2).EQ.8)) THEN
17063 *    there is no pi-+n+n channel
17064                      NSPE = 1
17065                      GOTO 1
17066                   ELSE
17067                      GOTO 2
17068                   ENDIF
17069                ENDIF
17070             ENDIF
17071     1    CONTINUE
17072
17073     2    CONTINUE
17074       ENDIF
17075 * transform excited projectile nucleons (status=15) into proj. rest s.
17076       DO 3 I=1,NSPE
17077          DO 4 K=1,5
17078             PSPE(I,K) = PHKK(K,IDXSPE(I))
17079     4    CONTINUE
17080     3 CONTINUE
17081
17082 * antiproton absorption
17083       IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
17084          DO 5 K=1,5
17085             PSPE1(K) = PSPE(1,K)
17086     5    CONTINUE
17087          CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
17088          IF (IREJ1.NE.0) GOTO 9999
17089
17090 * meson absorption
17091       ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23)
17092      &                      .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN
17093          IF (IDCAS.EQ.14) THEN
17094 *   pi- absorption
17095             IDFSP(1) = 8
17096             IDFSP(2) = 8
17097             IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
17098          ELSEIF (IDCAS.EQ.13) THEN
17099 *   pi+ absorption
17100             IDFSP(1) = 1
17101             IDFSP(2) = 1
17102             IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
17103          ELSEIF (IDCAS.EQ.23) THEN
17104 *   pi0 absorption
17105             IDFSP(1) = IDSPE(1)
17106             IDFSP(2) = IDSPE(2)
17107          ELSEIF (IDCAS.EQ.16) THEN
17108 *   K- absorption
17109             R = DT_RNDM(PCAS)
17110             IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
17111                IF (R.LT.ONETHI) THEN
17112                   IDFSP(1) = 21
17113                   IDFSP(2) = 8
17114                ELSEIF (R.LT.TWOTHI) THEN
17115                   IDFSP(1) = 17
17116                   IDFSP(2) = 1
17117                ELSE
17118                   IDFSP(1) = 22
17119                   IDFSP(2) = 1
17120                ENDIF
17121             ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
17122                IDFSP(1) = 20
17123                IDFSP(2) = 8
17124             ELSE
17125                IF (R.LT.ONETHI) THEN
17126                   IDFSP(1) = 20
17127                   IDFSP(2) = 1
17128                ELSEIF (R.LT.TWOTHI) THEN
17129                   IDFSP(1) = 17
17130                   IDFSP(2) = 8
17131                ELSE
17132                   IDFSP(1) = 22
17133                   IDFSP(2) = 8
17134                ENDIF
17135             ENDIF
17136          ENDIF
17137 *   dump initial particles for energy-momentum cons. check
17138          IF (LEMCCK) THEN
17139             CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM)
17140             CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2,
17141      &                                                    IDUM,IDUM)
17142             CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
17143      &                                                    IDUM,IDUM)
17144          ENDIF
17145 *   get Lorentz-parameter of 3 particle initial state
17146          DO 6 K=1,4
17147             PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
17148     6    CONTINUE
17149          P3P  = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
17150          AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
17151          DO 7 K=1,4
17152             BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
17153     7    CONTINUE
17154 *   2-particle decay of the 3-particle compound system
17155          CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2),
17156      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
17157      &               AAM(IDFSP(1)),AAM(IDFSP(2)))
17158          DO 8 I=1,2
17159             SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I)))
17160             PX  = PCMF(I)*COFF(I)*SDF
17161             PY  = PCMF(I)*SIFF(I)*SDF
17162             PZ  = PCMF(I)*CODF(I)
17163             CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ,
17164      &                  ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17165      &                  PFSP(4,I))
17166             PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) )
17167 *   check consistency of kinematics
17168             IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN
17169                WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I)
17170  1001          FORMAT(1X,'ABSORP:   warning! inconsistent',
17171      &                ' tree-particle kinematics',/,20X,'id: ',I3,
17172      &                ' AAM = ',E10.4,' MFSP = ',E10.4)
17173             ENDIF
17174 *   dump final state particles for energy-momentum cons. check
17175             IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17176      &                              -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17177     8    CONTINUE
17178          NFSP = 2
17179          IF (LEMCCK) THEN
17180             CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1)
17181             IF (IREJ1.NE.0) THEN
17182                WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)),
17183      &                      AM3P
17184                GOTO 9999
17185             ENDIF
17186          ENDIF
17187       ELSE
17188          IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
17189  1000    FORMAT(1X,'ABSORP:   warning! absorption for particle ',I3,
17190      &          ' impossible',/,20X,'too few spectators (',I2,')')
17191          NSPE = 0
17192       ENDIF
17193
17194       RETURN
17195
17196  9999 CONTINUE
17197       IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
17198       IREJ = 1
17199       RETURN
17200       END
17201
17202 *$ CREATE DT_HADRIN.FOR
17203 *COPY DT_HADRIN
17204 *
17205 *===hadrin=============================================================*
17206 *
17207       SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
17208
17209 ************************************************************************
17210 * Interface to the HADRIN-routines for inelastic and elastic           *
17211 * scattering.                                                          *
17212 *      IDPR,PPR(5)   identity, momentum of projectile                  *
17213 *      IDTA,PTA(5)   identity, momentum of target                      *
17214 *      MODE  = 1     inelastic interaction                             *
17215 *            = 2     elastic   interaction                             *
17216 * Revised version of the original FHAD.                                *
17217 * This version dated 27.10.95 is written by S. Roesler                 *
17218 ************************************************************************
17219
17220       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17221       SAVE
17222       PARAMETER ( LINP = 10 ,
17223      &            LOUT = 6 ,
17224      &            LDAT = 9 )
17225       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,
17226      &           TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0)
17227
17228       LOGICAL LCORR,LMSSG
17229
17230 * flags for input different options
17231       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17232       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17233      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17234 * final state after inc step
17235       PARAMETER (MAXFSP=10)
17236       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17237 * particle properties (BAMJET index convention)
17238       CHARACTER*8  ANAME
17239       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17240      &                IICH(210),IIBAR(210),K1(210),K2(210)
17241 * output-common for DHADRI/ELHAIN
17242 * final state from HADRIN interaction
17243       PARAMETER (MAXFIN=10)
17244       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
17245      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
17246
17247       DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
17248      &          P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
17249
17250       DATA LMSSG /.TRUE./
17251
17252       IREJ  = 0
17253       NFSP  = 0
17254       KCORR = 0
17255       IMCORR(1) = 0
17256       IMCORR(2) = 0
17257       LCORR = .FALSE.
17258
17259 *   dump initial particles for energy-momentum cons. check
17260       IF (LEMCCK) THEN
17261          CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM)
17262          CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM)
17263       ENDIF
17264
17265       AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2
17266       AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2
17267       IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR.
17268      &    (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR.
17269      &    (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN
17270          IF (LMSSG.AND.(IOULEV(3).GT.0))
17271      &   WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2
17272  1000    FORMAT(1X,'HADRIN:   warning! inconsistent projectile/target',
17273      &          ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ',
17274      &          E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4)
17275          LMSSG = .FALSE.
17276          LCORR = .TRUE.
17277       ENDIF
17278
17279 * convert initial state particles into particles which can be
17280 * handled by HADRIN
17281       IDHPR = IDPR
17282       IDHTA = IDTA
17283       IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
17284          IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
17285          DO 1 K=1,4
17286             P1IN(K) = PPR(K)
17287             P2IN(K) = PTA(K)
17288     1    CONTINUE
17289          XM1 = AAM(IDHPR)
17290          XM2 = AAM(IDHTA)
17291          CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17292          IF (IREJ1.GT.0) THEN
17293             WRITE(LOUT,'(1X,A)') 'HADRIN:   inconsistent mass trsf.'
17294             GOTO 9999
17295          ENDIF
17296          DO 2 K=1,4
17297             PPR(K) = P1OUT(K)
17298             PTA(K) = P2OUT(K)
17299     2    CONTINUE
17300          PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2)
17301          PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2)
17302       ENDIF
17303
17304 * Lorentz-parameter for trafo into rest-system of target
17305       DO 3 K=1,4
17306          BGTA(K) = PTA(K)/PTA(5)
17307     3 CONTINUE
17308 * transformation of projectile into rest-system of target
17309       CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2),
17310      &            PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3),
17311      &            PPR1(4))
17312
17313 * direction cosines of projectile in target rest system
17314       CX = PPR1(1)/PPRTO1
17315       CY = PPR1(2)/PPRTO1
17316       CZ = PPR1(3)/PPRTO1
17317
17318 * sample inelastic interaction
17319       IF (MODE.EQ.1) THEN
17320          CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA)
17321          IF (IRH.EQ.1) GOTO 9998
17322 * sample elastic interaction
17323       ELSEIF (MODE.EQ.2) THEN
17324          CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1)
17325          IF (IREJ1.NE.0) THEN
17326             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN'
17327             GOTO 9999
17328          ENDIF
17329          IF (IRH.EQ.1) GOTO 9998
17330       ELSE
17331          WRITE(LOUT,1001) MODE,INTHAD
17332  1001    FORMAT(1X,'HADRIN:   warning! inconsistent interaction mode',
17333      &          I4,' (INTHAD =',I4,')')
17334          GOTO 9999
17335       ENDIF
17336
17337 * transform final state particles back into Lab.
17338       DO 4 I=1,IRH
17339          NFSP = NFSP+1
17340          PX   = CXRH(I)*PLRH(I)
17341          PY   = CYRH(I)*PLRH(I)
17342          PZ   = CZRH(I)*PLRH(I)
17343          CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3),
17344      &               PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP),
17345      &               PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP))
17346          IDFSP(NFSP) = ITRH(I)
17347          AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2-
17348      &                                            PFSP(3,NFSP)**2
17349          IF (AMFSP2.LT.-TINY3) THEN
17350             WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP),
17351      &                       PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2
17352  1002       FORMAT(1X,'HADRIN:   warning! final state particle (id = ',
17353      &             I2,') with negative mass^2',/,1X,5E12.4)
17354             GOTO 9999
17355          ELSE
17356             PFSP(5,NFSP) = SQRT(ABS(AMFSP2))
17357             IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN
17358                WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
17359      &                          PFSP(5,NFSP)
17360  1003          FORMAT(1X,'HADRIN:   warning! final state particle',
17361      &                ' (id = ',I2,') with inconsistent mass',/,1X,
17362      &                2E12.4)
17363                KCORR         = KCORR+1
17364                IF (KCORR.GT.2) GOTO 9999
17365                IMCORR(KCORR) = NFSP
17366             ENDIF
17367          ENDIF
17368 *   dump final state particles for energy-momentum cons. check
17369          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17370      &                           -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17371     4 CONTINUE
17372
17373 * transform momenta on mass shell in case of inconsistencies in
17374 * HADRIN
17375       IF (KCORR.GT.0) THEN
17376          IF (KCORR.EQ.2) THEN
17377             I1 = IMCORR(1)
17378             I2 = IMCORR(2)
17379          ELSE
17380             IF (IMCORR(1).EQ.1) THEN
17381                I1 = 1
17382                I2 = 2
17383             ELSE
17384                I1 = 1
17385                I2 = IMCORR(1)
17386             ENDIF
17387          ENDIF
17388          IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1),
17389      &                           PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM)
17390          IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2),
17391      &                           PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM)
17392          DO 5 K=1,4
17393             P1IN(K) = PFSP(K,I1)
17394             P2IN(K) = PFSP(K,I2)
17395     5    CONTINUE
17396          XM1 = AAM(IDFSP(I1))
17397          XM2 = AAM(IDFSP(I2))
17398          CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17399          IF (IREJ1.GT.0) THEN
17400             WRITE(LOUT,'(1X,A)') 'HADRIN:   inconsistent mass trsf.'
17401 C           GOTO 9999
17402          ENDIF
17403          DO 6 K=1,4
17404             PFSP(K,I1) = P1OUT(K)
17405             PFSP(K,I2) = P2OUT(K)
17406     6    CONTINUE
17407          PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2
17408      &                    -PFSP(2,I1)**2-PFSP(3,I1)**2)
17409          PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2
17410      &                    -PFSP(2,I2)**2-PFSP(3,I2)**2)
17411 *   dump final state particles for energy-momentum cons. check
17412          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1),
17413      &                           -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM)
17414          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2),
17415      &                           -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM)
17416       ENDIF
17417
17418 * check energy-momentum conservation
17419       IF (LEMCCK) THEN
17420          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
17421          IF (IREJ1.NE.0) GOTO 9999
17422       ENDIF
17423
17424       RETURN
17425
17426  9998 CONTINUE
17427       IREJ = 2
17428       RETURN
17429
17430  9999 CONTINUE
17431       IREJ = 1
17432       RETURN
17433       END
17434
17435 *$ CREATE DT_HADCOL.FOR
17436 *COPY DT_HADCOL
17437 *
17438 *===hadcol=============================================================*
17439 *
17440       SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
17441
17442 ************************************************************************
17443 * Interface to the HADRIN-routines for inelastic and elastic           *
17444 * scattering. This subroutine samples hadron-nucleus interactions      *
17445 * below DPM-threshold.                                                 *
17446 *      IDPROJ        BAMJET-index of projectile hadron                 *
17447 *      PPN           projectile momentum in target rest frame          *
17448 *      IDXTAR        DTEVT1-index of target nucleon undergoing         *
17449 *                    interaction with projectile hadron                *
17450 * This subroutine replaces HADHAD.                                     *
17451 * This version dated 5.5.95 is written by S. Roesler                   *
17452 ************************************************************************
17453
17454       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17455       SAVE
17456       PARAMETER ( LINP = 10 ,
17457      &            LOUT = 6 ,
17458      &            LDAT = 9 )
17459       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0)
17460
17461       LOGICAL LSTART
17462
17463 * event history
17464       PARAMETER (NMXHKK=200000)
17465       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17466      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17467      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17468 * extended event history
17469       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17470      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17471      &                IHIST(2,NMXHKK)
17472 * nuclear potential
17473       LOGICAL LFERMI
17474       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17475      &                EBINDP(2),EBINDN(2),EPOT(2,210),
17476      &                ETACOU(2),ICOUL,LFERMI
17477 * interface HADRIN-DPM
17478       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
17479 * parameter for intranuclear cascade
17480       LOGICAL LPAULI
17481       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
17482 * final state after inc step
17483       PARAMETER (MAXFSP=10)
17484       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17485 * particle properties (BAMJET index convention)
17486       CHARACTER*8  ANAME
17487       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17488      &                IICH(210),IIBAR(210),K1(210),K2(210)
17489
17490       DIMENSION PPROJ(5),PNUC(5)
17491
17492       DATA LSTART /.TRUE./
17493
17494       IREJ   = 0
17495
17496       NPOINT(1) = NHKK+1
17497
17498       TAUSAV = TAUFOR
17499 **sr 6/9/01 commented
17500 C     TAUFOR = TAUFOR/2.0D0
17501 **
17502       IF (LSTART) THEN
17503          WRITE(LOUT,1000)
17504  1000    FORMAT(/,1X,'HADCOL:  Scattering handled by HADRIN')
17505          WRITE(LOUT,1001) TAUFOR
17506  1001    FORMAT(/,1X,'HADCOL:  Formation zone parameter set to ',
17507      &          F5.1,' fm/c')
17508          LSTART = .FALSE.
17509       ENDIF
17510
17511       IDNUC  = IDBAM(IDXTAR)
17512       IDNUC1 = IDT_MCHAD(IDNUC)
17513       IDPRO1 = IDT_MCHAD(IDPROJ)
17514
17515       IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
17516          IPROC = INTHAD
17517       ELSE
17518 **
17519 C        CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
17520 C        CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
17521          DUMZER = ZERO
17522          CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
17523          SIGIN = SIGTOT-SIGEL
17524 C        SIGTOT = SIGIN+SIGEL
17525 **
17526          IPROC  = 1
17527          IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
17528       ENDIF
17529
17530       PPROJ(1) = ZERO
17531       PPROJ(2) = ZERO
17532       PPROJ(3) = PPN
17533       PPROJ(5) = AAM(IDPROJ)
17534       PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
17535       DO 1 K=1,5
17536          PNUC(K)  = PHKK(K,IDXTAR)
17537     1 CONTINUE
17538
17539       ILOOP = 0
17540     2 CONTINUE
17541       ILOOP = ILOOP+1
17542       IF (ILOOP.GT.100) GOTO 9999
17543
17544       CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
17545       IF (IREJ1.EQ.1) GOTO 9999
17546
17547       IF (IREJ1.GT.1) THEN
17548 * no interaction possible
17549 *   require Pauli blocking
17550          IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2
17551          IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2
17552          IF ((IIBAR(IDPROJ).NE.1).AND.
17553      &       (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5)))              GOTO 2
17554 *   store incoming particle as final state particle
17555          CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3)
17556          CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0)
17557          NPOINT(4) = NHKK
17558       ELSE
17559 * require Pauli blocking for final state nucleons
17560          DO 4 I=1,NFSP
17561             IF ((IDFSP(I).EQ.1).AND.
17562      &          (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I))))       GOTO 2
17563             IF ((IDFSP(I).EQ.8).AND.
17564      &          (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I))))       GOTO 2
17565             IF ((IIBAR(IDFSP(I)).NE.1).AND.
17566      &          (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2
17567     4    CONTINUE
17568 * store final state particles
17569          DO 5 I=1,NFSP
17570             IST = 1
17571             IF ((IIBAR(IDFSP(I)).EQ.1).AND.
17572      &          (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16
17573             IDHAD = IDT_IPDGHA(IDFSP(I))
17574             CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3)
17575             CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I),
17576      &                                        PCMS,ECMS,0,0,0)
17577             IF (I.EQ.1) NPOINT(4) = NHKK
17578             VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR))
17579             VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR))
17580             VHKK(3,NHKK) = VHKK(3,IDXTAR)
17581             VHKK(4,NHKK) = VHKK(4,IDXTAR)
17582             WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR))
17583             WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR))
17584             WHKK(3,NHKK) = WHKK(3,1)
17585             WHKK(4,NHKK) = WHKK(4,1)
17586     5    CONTINUE
17587       ENDIF
17588       TAUFOR = TAUSAV
17589       RETURN
17590
17591  9999 CONTINUE
17592       IREJ = 1
17593       TAUFOR = TAUSAV
17594       RETURN
17595       END
17596
17597 *$ CREATE DT_GETEMU.FOR
17598 *COPY DT_GETEMU
17599 *
17600 *===getemu=============================================================*
17601 *
17602       SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
17603
17604 ************************************************************************
17605 * Sampling of emulsion component to be considered as target-nucleus.   *
17606 * This version dated 6.5.95   is written by S. Roesler.                *
17607 ************************************************************************
17608
17609       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17610       SAVE
17611       PARAMETER ( LINP = 10 ,
17612      &            LOUT = 6 ,
17613      &            LDAT = 9 )
17614       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
17615
17616       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
17617 * emulsion treatment
17618       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
17619      &                NCOMPO,IEMUL
17620 * Glauber formalism: flags and parameters for statistics
17621       LOGICAL LPROD
17622       CHARACTER*8 CGLB
17623       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
17624
17625       IF (MODE.EQ.0) THEN
17626          SUMFRA = ZERO
17627          RR = DT_RNDM(SUMFRA)
17628          IT  = 0
17629          ITZ = 0
17630          DO 1 ICOMP=1,NCOMPO
17631             SUMFRA = SUMFRA+EMUFRA(ICOMP)
17632             IF (SUMFRA.GT.RR) THEN
17633                IT    = IEMUMA(ICOMP)
17634                ITZ   = IEMUCH(ICOMP)
17635                KKMAT = ICOMP
17636                GOTO 2
17637             ENDIF
17638     1    CONTINUE
17639     2    CONTINUE
17640          IF (IT.LE.0) THEN
17641             WRITE(LOUT,'(1X,A,E12.3)')
17642      &       'Warning!  norm. failure within emulsion fractions',
17643      &       SUMFRA
17644             STOP
17645          ENDIF
17646       ELSEIF (MODE.EQ.1) THEN
17647          NDIFF = 10000
17648          DO 3 I=1,NCOMPO
17649             IDIFF = ABS(IT-IEMUMA(I))
17650             IF (IDIFF.LT.NDIFF) THEN
17651                KKMAT = I
17652                NDIFF = IDIFF
17653             ENDIF
17654     3    CONTINUE
17655       ELSE
17656          STOP 'DT_GETEMU'
17657       ENDIF
17658
17659 * bypass for variable projectile/target/energy runs: the correct
17660 * Glauber data will be always loaded on kkmat=1
17661       IF (IOGLB.EQ.100) THEN
17662          KKMAT = 1
17663       ENDIF
17664
17665       RETURN
17666       END
17667
17668 *$ CREATE DT_NCLPOT.FOR
17669 *COPY DT_NCLPOT
17670 *
17671 *===nclpot=============================================================*
17672 *
17673       SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
17674
17675 ************************************************************************
17676 * Calculation of Coulomb and nuclear potential for a given configurat. *
17677 *               IPZ, IP       charge/mass number of proj.              *
17678 *               ITZ, IT       charge/mass number of targ.              *
17679 *               AFERP,AFERT   factors modifying proj./target pot.      *
17680 *                             if =0, FERMOD is used                    *
17681 *               MODE = 0      calculation of binding energy            *
17682 *                    = 1      pre-calculated binding energy is used    *
17683 * This version dated 16.11.95  is written by S. Roesler.               *
17684 *                                                                      *
17685 * Last change 28.12.2006 by S. Roesler.                                *
17686 ************************************************************************
17687
17688       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17689       SAVE
17690       PARAMETER ( LINP = 10 ,
17691      &            LOUT = 6 ,
17692      &            LDAT = 9 )
17693       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
17694      &           TINY10=1.0D-10)
17695
17696       LOGICAL LSTART
17697
17698 * particle properties (BAMJET index convention)
17699       CHARACTER*8  ANAME
17700       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17701      &                IICH(210),IIBAR(210),K1(210),K2(210)
17702 * nuclear potential
17703       LOGICAL LFERMI
17704       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17705      &                EBINDP(2),EBINDN(2),EPOT(2,210),
17706      &                ETACOU(2),ICOUL,LFERMI
17707
17708       DIMENSION IDXPOT(14)
17709 *                   ap   an  lam  alam sig- sig+ sig0 tet0 tet- asig-
17710       DATA IDXPOT /   2,   9,  17,  18,  20,  21,  22,  97,  98,  99,
17711 *                 asig0 asig+ atet0 atet+
17712      &              100, 101, 102, 103/
17713
17714       DATA AN     /0.4D0/
17715       DATA LSTART /.TRUE./
17716
17717       IF (MODE.EQ.0) THEN
17718          EBINDP(1) = ZERO
17719          EBINDN(1) = ZERO
17720          EBINDP(2) = ZERO
17721          EBINDN(2) = ZERO
17722       ENDIF
17723       AIP  = DBLE(IP)
17724       AIPZ = DBLE(IPZ)
17725       AIT  = DBLE(IT)
17726       AITZ = DBLE(ITZ)
17727
17728       FERMIP = AFERP
17729       IF (AFERP.LE.ZERO) FERMIP = FERMOD
17730       FERMIT = AFERT
17731       IF (AFERT.LE.ZERO) FERMIT = FERMOD
17732
17733 * Fermi momenta and binding energy for projectile
17734       IF ((IP.GT.1).AND.LFERMI) THEN
17735          IF (MODE.EQ.0) THEN
17736 C           EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
17737 C           EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
17738             BIP  = AIP -ONE
17739             BIPZ = AIPZ-ONE
17740             EBINDP(1) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIP,BIPZ)
17741      &                                            -DT_ENERGY(AIP,AIPZ))
17742             IF (AIP.LE.AIPZ) THEN
17743                EBINDN(1) = EBINDP(1)
17744                WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
17745             ELSE
17746                EBINDN(1) = 1.0D-3*(DT_ENERGY(ONE,ZERO)
17747      &                     +DT_ENERGY(BIP,AIPZ)-DT_ENERGY(AIP,AIPZ))
17748             ENDIF
17749          ENDIF
17750          PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
17751          PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
17752       ELSE
17753          PFERMP(1) = ZERO
17754          PFERMN(1) = ZERO
17755       ENDIF
17756 * effective nuclear potential for projectile
17757 C     EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
17758 C     EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
17759       EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1)
17760       EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1)
17761
17762 * Fermi momenta and binding energy for target
17763       IF ((IT.GT.1).AND.LFERMI) THEN
17764          IF (MODE.EQ.0) THEN
17765 C           EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
17766 C           EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
17767             BIT  = AIT -ONE
17768             BITZ = AITZ-ONE
17769
17770             EBINDP(2) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIT,BITZ)
17771      &                                            -DT_ENERGY(AIT,AITZ))
17772
17773             IF (AIT.LE.AITZ) THEN
17774                EBINDN(2) = EBINDP(2)
17775                WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
17776             ELSE
17777
17778                EBINDN(2) = 1.0D-3*(DT_ENERGY(ONE,ZERO)
17779      &                     +DT_ENERGY(BIT,AITZ)-DT_ENERGY(AIT,AITZ))
17780
17781             ENDIF
17782          ENDIF
17783          PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
17784          PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
17785       ELSE
17786          PFERMP(2) = ZERO
17787          PFERMN(2) = ZERO
17788       ENDIF
17789 * effective nuclear potential for target
17790 C     EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
17791 C     EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
17792       EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2)
17793       EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2)
17794
17795       DO 2 I=1,14
17796          EPOT(1,IDXPOT(I)) = EPOT(1,8)
17797          EPOT(2,IDXPOT(I)) = EPOT(2,8)
17798     2 CONTINUE
17799
17800 * Coulomb energy
17801       ETACOU(1) = ZERO
17802       ETACOU(2) = ZERO
17803       IF (ICOUL.EQ.1) THEN
17804          IF (IP.GT.1)
17805      &   ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
17806          IF (IT.GT.1)
17807      &   ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
17808       ENDIF
17809
17810       IF (LSTART) THEN
17811          WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN,
17812      &                    EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2),
17813      &                    EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2),
17814      &                    FERMOD,ETACOU
17815  1000    FORMAT(/,/,1X,'NCLPOT:    quantities for inclusion of nuclear'
17816      &           ,' effects',/,12X,'---------------------------',
17817      &           '----------------',/,/,38X,'projectile',
17818      &           '      target',/,/,1X,'Mass number / charge',
17819      &           17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy  -',
17820      &           ' proton   (GeV) ',2E14.4,/,17X,'- neutron  (GeV)'
17821      &          ,1X,2E14.4,/,1X,'Fermi-potential - proton   (GeV)',
17822      &           1X,2E14.4,/,17X,'- neutron  (GeV) ',2E14.4,/,/,
17823      &           1X,'Scale factor for Fermi-momentum    ',F4.2,/,
17824      &           /,1X,'Coulomb-energy ',2(E14.4,' GeV  '),/,/)
17825          LSTART = .FALSE.
17826       ENDIF
17827
17828       RETURN
17829       END
17830
17831 *$ CREATE DT_RESNCL.FOR
17832 *COPY DT_RESNCL
17833 *
17834 *===resncl=============================================================*
17835 *
17836       SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
17837
17838 ************************************************************************
17839 * Treatment of residual nuclei and nuclear effects.                    *
17840 *         MODE = 1     initializations                                 *
17841 *              = 2     treatment of final state                        *
17842 * This version dated 16.11.95 is written by S. Roesler.                *
17843 *                                                                      *
17844 * Last change 05.01.2007 by S. Roesler.                                *
17845 ************************************************************************
17846
17847       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17848       SAVE
17849       PARAMETER ( LINP = 10 ,
17850      &            LOUT = 6 ,
17851      &            LDAT = 9 )
17852       PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
17853      &           TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10,
17854      &           ONETHI=ONE/THREE)
17855       PARAMETER (AMUAMU = 0.93149432D0,
17856      &           FM2MM  = 1.0D-12,
17857      &           RNUCLE = 1.12D0)
17858       PARAMETER ( EMVGEV = 1.0                D-03 )
17859       PARAMETER ( AMUGEV = 0.93149432         D+00 )
17860       PARAMETER ( AMPRTN = 0.93827231         D+00 )
17861       PARAMETER ( AMNTRN = 0.93956563         D+00 )
17862       PARAMETER ( AMELCT = 0.51099906         D-03 )
17863       PARAMETER ( HLFHLF = 0.5D+00 )
17864       PARAMETER ( FERTHO = 14.33       D-09 )
17865       PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
17866       PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
17867       PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
17868
17869 * event history
17870       PARAMETER (NMXHKK=200000)
17871       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17872      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17873      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17874 * extended event history
17875       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17876      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17877      &                IHIST(2,NMXHKK)
17878 * particle properties (BAMJET index convention)
17879       CHARACTER*8  ANAME
17880       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17881      &                IICH(210),IIBAR(210),K1(210),K2(210)
17882 * flags for input different options
17883       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17884       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17885      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17886 * nuclear potential
17887       LOGICAL LFERMI
17888       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17889      &                EBINDP(2),EBINDN(2),EPOT(2,210),
17890      &                ETACOU(2),ICOUL,LFERMI
17891 * properties of interacting particles
17892       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
17893 * properties of photon/lepton projectiles
17894       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
17895 * Lorentz-parameters of the current interaction
17896       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
17897      &                UMO,PPCM,EPROJ,PPROJ
17898 * treatment of residual nuclei: wounded nucleons
17899       COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
17900 * treatment of residual nuclei: 4-momenta
17901       LOGICAL LRCLPR,LRCLTA
17902       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
17903      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
17904
17905       DIMENSION PFSP(4),PSEC(4),PSEC0(4)
17906       DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
17907      &          IDXCOR(15000),IDXOTH(NMXHKK)
17908
17909       GOTO (1,2) MODE
17910
17911 *------- initializations
17912     1 CONTINUE
17913
17914 * initialize arrays for residual nuclei
17915       DO 10 K=1,5
17916          IF (K.LE.4) THEN
17917             PFSP(K)     = ZERO
17918          ENDIF
17919          PINIPR(K) = ZERO
17920          PINITA(K) = ZERO
17921          PRCLPR(K) = ZERO
17922          PRCLTA(K) = ZERO
17923          TRCLPR(K) = ZERO
17924          TRCLTA(K) = ZERO
17925    10 CONTINUE
17926       SCPOT = ONE
17927       NLOOP = 0
17928
17929 * correction of projectile 4-momentum for effective target pot.
17930 * and Coulomb-energy (in case of hadron-nucleus interaction only)
17931 *      IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
17932 *         EPNI = EPN
17933 *   Coulomb-energy:
17934 *     positively charged hadron - check energy for Coloumb pot.
17935 *         IF (IICH(IJPROJ).EQ.1) THEN
17936 *            THRESH = ETACOU(2)+AAM(IJPROJ)
17937 *            IF (EPNI.LE.THRESH) THEN
17938 *               WRITE(LOUT,1000)
17939 * 1000          FORMAT(/,1X,'KKINC:  WARNING!  projectile energy',
17940 *     &                ' below Coulomb threshold - event rejected',/)
17941 *               ISTHKK(1) = 1
17942 *               RETURN
17943 *            ENDIF
17944 *     negatively charged hadron - increase energy by Coulomb energy
17945 *         ELSEIF (IICH(IJPROJ).EQ.-1) THEN
17946 *            EPNI = EPNI+ETACOU(2)
17947 *         ENDIF
17948 *         IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN
17949 *   Effective target potential
17950 *sr 6.6. binding energy only (to avoid negative exc. energies)
17951 C           EPNI = EPNI+EPOT(2,IJPROJ)
17952 *            EBIPOT = EBINDP(2)
17953 *            IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3))
17954 *     &         EBIPOT = EBINDN(2)
17955 *            EPNI = EPNI+ABS(EBIPOT)
17956 * re-initialization of DTLTRA
17957 *            DUM1 = ZERO
17958 *            DUM2 = ZERO
17959 *
17960 *            CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
17961 *         ENDIF
17962 *      ENDIF
17963
17964 * projectile in n-n cms
17965       IF ((IP.LE.1).AND.(IT.GT.1)) THEN
17966          PMASS1 = AAM(IJPROJ)
17967 C* VDM assumption
17968 C         IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
17969          IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
17970          PMASS2 = AAM(1)
17971          PM1 = SIGN(PMASS1**2,PMASS1)
17972          PM2 = SIGN(PMASS2**2,PMASS2)
17973          PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
17974          PINIPR(5) = PMASS1
17975          IF (PMASS1.GT.ZERO) THEN
17976             PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
17977      &                      *(PINIPR(4)+PINIPR(5)))
17978          ELSE
17979             PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
17980          ENDIF
17981          AIT  = DBLE(IT)
17982          AITZ = DBLE(ITZ)
17983          PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ)
17984          CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
17985       ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
17986          PMASS1 = AAM(1)
17987          PMASS2 = AAM(IJTARG)
17988          PM1 = SIGN(PMASS1**2,PMASS1)
17989          PM2 = SIGN(PMASS2**2,PMASS2)
17990          PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO)
17991          PINITA(5) = PMASS2
17992          PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
17993      &                    *(PINITA(4)+PINITA(5)))
17994          AIP  = DBLE(IP)
17995          AIPZ = DBLE(IPZ)
17996          PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ)
17997          CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
17998       ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
17999          AIP  = DBLE(IP)
18000          AIPZ = DBLE(IPZ)
18001          PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ)
18002          CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18003          AIT  = DBLE(IT)
18004          AITZ = DBLE(ITZ)
18005          PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ)
18006          CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18007       ENDIF
18008
18009       RETURN
18010
18011 *------- treatment of final state
18012     2 CONTINUE
18013
18014       NLOOP = NLOOP+1
18015       IF (NLOOP.GT.1) SCPOT = 0.10D0
18016 C     WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
18017
18018       JPW  = NPW
18019       JPCW = NPCW
18020       JTW  = NTW
18021       JTCW = NTCW
18022       DO 40 K=1,4
18023          PFSP(K)   = ZERO
18024    40 CONTINUE
18025
18026       NOB = 0
18027       NOM = 0
18028       DO 900 I=NPOINT(4),NHKK
18029          IDXOTH(I) = -1
18030          IF (ISTHKK(I).EQ.1) THEN
18031             IF (IDBAM(I).EQ.7) GOTO 900
18032             IPOT = 0
18033             IOTHER = 0
18034 * particle moving into forward direction
18035             IF (PHKK(3,I).GE.ZERO) THEN
18036 *   most likely to be effected by projectile potential
18037                IPOT = 1
18038 *     there is no projectile nucleus, try target
18039                IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
18040                   IPOT   = 2
18041                   IF (IP.GT.1) IOTHER = 1
18042 *       there is no target nucleus --> skip
18043                   IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900
18044                ENDIF
18045 * particle moving into backward direction
18046             ELSE
18047 *   most likely to be effected by target potential
18048                IPOT = 2
18049 *     there is no target nucleus, try projectile
18050                IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
18051                   IPOT   = 1
18052                   IF (IT.GT.1) IOTHER = 1
18053 *       there is no projectile nucleus --> skip
18054                   IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900
18055                ENDIF
18056             ENDIF
18057             IFLG = -IPOT
18058 * nobam=3: particle is in overlap-region or neither inside proj. nor target
18059 *      =1: particle is not in overlap-region AND is inside target (2)
18060 *      =2: particle is not in overlap-region AND is inside projectile (1)
18061 * flag particles which are inside the nucleus ipot but not in its
18062 * overlap region
18063             IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT
18064             IF (IDBAM(I).NE.0) THEN
18065 * baryons: keep all nucleons and all others where flag is set
18066                IF (IIBAR(IDBAM(I)).NE.0) THEN
18067                   IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0))
18068      &                                                              THEN
18069                      NOB = NOB+1
18070                      PMOMB(NOB) = PHKK(3,I)
18071                      IDXB(NOB)  = SIGN(10000000*IABS(IFLG)
18072      &                           +1000000*IOTHER+I,IFLG)
18073                   ENDIF
18074 * mesons: keep only those mesons where flag is set
18075                ELSE
18076                   IF (IFLG.GT.0) THEN
18077                      NOM = NOM+1
18078                      PMOMM(NOM) = PHKK(3,I)
18079                      IDXM(NOM)  = 10000000*IFLG+1000000*IOTHER+I
18080                   ENDIF
18081                ENDIF
18082             ENDIF
18083          ENDIF
18084   900 CONTINUE
18085 *
18086 * sort particles in the arrays according to increasing long. momentum
18087       CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1)
18088       CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1)
18089 *
18090 * shuffle indices into one and the same array according to the later
18091 * sequence of correction
18092       NCOR = 0
18093       IF (IT.GT.1) THEN
18094          DO 910 I=1,NOB
18095             IF (PMOMB(I).GT.ZERO) GOTO 911
18096             NCOR = NCOR+1
18097             IDXCOR(NCOR) = IDXB(I)
18098   910    CONTINUE
18099   911    CONTINUE
18100          IF (IP.GT.1) THEN
18101             DO 912 J=1,NOB
18102                I = NOB+1-J
18103                IF (PMOMB(I).LT.ZERO) GOTO 913
18104                NCOR = NCOR+1
18105                IDXCOR(NCOR) = IDXB(I)
18106   912       CONTINUE
18107   913       CONTINUE
18108          ELSE
18109             DO 914 I=1,NOB
18110                IF (PMOMB(I).GT.ZERO) THEN
18111                   NCOR = NCOR+1
18112                   IDXCOR(NCOR) = IDXB(I)
18113                ENDIF
18114   914       CONTINUE
18115          ENDIF
18116       ELSE
18117          DO 915 J=1,NOB
18118             I = NOB+1-J
18119             NCOR = NCOR+1
18120             IDXCOR(NCOR) = IDXB(I)
18121   915    CONTINUE
18122       ENDIF
18123       DO 925 I=1,NOM
18124          IF (PMOMM(I).GT.ZERO) GOTO 926
18125          NCOR = NCOR+1
18126          IDXCOR(NCOR) = IDXM(I)
18127   925 CONTINUE
18128   926 CONTINUE
18129       DO 927 J=1,NOM
18130          I = NOM+1-J
18131          IF (PMOMM(I).LT.ZERO) GOTO 928
18132          NCOR = NCOR+1
18133          IDXCOR(NCOR) = IDXM(I)
18134   927 CONTINUE
18135   928 CONTINUE
18136 *
18137 C      IF (NEVHKK.EQ.484) THEN
18138 C         WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
18139 C 9000    FORMAT(1X,'wounded nucleons (proj.-p,n  targ.-p,n)',/,4I10)
18140 C         WRITE(LOUT,9001) NOB,NOM,NCOR
18141 C 9001    FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
18142 C         WRITE(LOUT,'(/,A)') ' baryons '
18143 C         DO 950 I=1,NOB
18144 CC           J     = IABS(IDXB(I))
18145 CC           INDEX = J-IABS(J/10000000)*10000000
18146 C            IPOT   = IABS(IDXB(I))/10000000
18147 C            IOTHER = IABS(IDXB(I))/1000000-IPOT*10
18148 C            INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000
18149 C            WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
18150 C  950    CONTINUE
18151 C         WRITE(LOUT,'(/,A)') ' mesons '
18152 C         DO 951 I=1,NOM
18153 CC           INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000
18154 C            IPOT   = IABS(IDXM(I))/10000000
18155 C            IOTHER = IABS(IDXM(I))/1000000-IPOT*10
18156 C            INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000
18157 C            WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
18158 C  951    CONTINUE
18159 C 9002    FORMAT(1X,4I14,E14.5)
18160 C         WRITE(LOUT,'(/,A)') ' all '
18161 C         DO 952 I=1,NCOR
18162 CC           J     = IABS(IDXCOR(I))
18163 CC           INDEX = J-IABS(J/10000000)*10000000
18164 CC            IPOT   = IABS(IDXCOR(I))/10000000
18165 C            IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10
18166 C            INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000
18167 C            WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
18168 C  952    CONTINUE
18169 C 9003    FORMAT(1X,4I14)
18170 C      ENDIF
18171 *
18172       DO 20 ICOR=1,NCOR
18173          IPOT   = IABS(IDXCOR(ICOR))/10000000
18174          IOTHER = IABS(IDXCOR(ICOR))/1000000-IPOT*10
18175          I = IABS(IDXCOR(ICOR))-IPOT*10000000-IOTHER*1000000
18176          IDXOTH(I) = 1
18177
18178          IDSEC  = IDBAM(I)
18179
18180 * reduction of particle momentum by corresponding nuclear potential
18181 * (this applies only if Fermi-momenta are requested)
18182
18183          IF (LFERMI) THEN
18184
18185 *   Lorentz-transformation into the rest system of the selected nucleus
18186             IMODE = -IPOT-1
18187             CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18188      &                  PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE)
18189             PSECO  = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2)
18190             AMSEC  = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO)))
18191             JPMOD  = 0
18192
18193             CHKLEV = TINY3
18194             IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1
18195             IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0
18196             IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN
18197                IF (IOULEV(3).GT.0)
18198      &            WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
18199  2000          FORMAT(1X,'RESNCL: inconsistent mass of particle',
18200      &                ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
18201      &                I4,'   AMSEC: ',E12.3,'  AAM(IDSEC): ',E12.3,/)
18202                GOTO 23
18203             ENDIF
18204
18205             DO 21 K=1,4
18206                PSEC0(K) = PSEC(K)
18207    21       CONTINUE
18208
18209 *   the correction for nuclear potential effects is applied to as many
18210 *   p/n as many nucleons were wounded; the momenta of other final state
18211 *   particles are corrected only if they materialize inside the corresp.
18212 *   nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
18213 *   = 3 part. outside proj. and targ., >=10 in overlapping region)
18214             IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN
18215                IF (IPOT.EQ.1) THEN
18216                   IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN
18217 *      this is most likely a wounded nucleon
18218 **test
18219 C                    RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
18220 C    &                           +(VHKK(2,IPW(JPW))/FM2MM)**2
18221 C    &                           +(VHKK(3,IPW(JPW))/FM2MM)**2)
18222 C                    RAD   = RNUCLE*DBLE(IP)**ONETHI
18223 C                    FDEN  = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
18224 C                    PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18225 **
18226                      PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18227                      JPW = JPW-1
18228                      JPMOD = 1
18229                   ELSE
18230 *      correct only if part. was materialized inside nucleus
18231 *      and if it is ouside the overlapping region
18232                      IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN
18233                         PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18234                         JPMOD = 1
18235                      ENDIF
18236                   ENDIF
18237                ELSEIF (IPOT.EQ.2) THEN
18238                   IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
18239 *      this is most likely a wounded nucleon
18240 **test
18241 C                    RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
18242 C    &                           +(VHKK(2,ITW(JTW))/FM2MM)**2
18243 C    &                           +(VHKK(3,ITW(JTW))/FM2MM)**2)
18244 C                    RAD   = RNUCLE*DBLE(IT)**ONETHI
18245 C                    FDEN  = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
18246 C                    PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18247 **
18248                      PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18249                      JTW = JTW-1
18250                      JPMOD = 1
18251                   ELSE
18252 *      correct only if part. was materialized inside nucleus
18253                      IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN
18254                         PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18255                         JPMOD = 1
18256                      ENDIF
18257                   ENDIF
18258                ENDIF
18259             ELSE
18260                IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
18261                   PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18262                   JPMOD = 1
18263                ENDIF
18264             ENDIF
18265
18266             IF (NLOOP.EQ.1) THEN
18267 * Coulomb energy correction:
18268 * the treatment of Coulomb potential correction is similar to the
18269 * one for nuclear potential
18270                IF (IDSEC.EQ.1) THEN
18271                   IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN
18272                      JPCW = JPCW-1
18273                   ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
18274                      JTCW = JTCW-1
18275                   ELSE
18276                      IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18277                   ENDIF
18278                ELSE
18279                   IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18280                ENDIF
18281                IF (IICH(IDSEC).EQ.1) THEN
18282 *    pos. particles: check if they are able to escape Coulomb potential
18283                   IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN
18284                      ISTHKK(I) = 14+IPOT
18285                      IF (ISTHKK(I).EQ.15) THEN
18286                         DO 26 K=1,4
18287                            PHKK(K,I) = PSEC0(K)
18288                            TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18289    26                CONTINUE
18290                         IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18291                         IF (IDSEC.EQ.1) NPCW = NPCW-1
18292                      ELSEIF (ISTHKK(I).EQ.16) THEN
18293                         DO 27 K=1,4
18294                            PHKK(K,I) = PSEC0(K)
18295                            TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18296    27                   CONTINUE
18297                         IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18298                         IF (IDSEC.EQ.1) NTCW = NTCW-1
18299                      ENDIF
18300                      GOTO 20
18301                   ENDIF
18302                ELSEIF (IICH(IDSEC).EQ.-1) THEN
18303 *    neg. particles: decrease energy by Coulomb-potential
18304                   PSEC(4) = PSEC(4)-ETACOU(IPOT)
18305                   JPMOD = 1
18306                ENDIF
18307             ENDIF
18308
18309    25       CONTINUE
18310
18311             IF (PSEC(4).LT.AMSEC) THEN
18312                IF (IOULEV(6).GT.0)
18313      &            WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
18314  2001          FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5,
18315      &                ' is not allowed to escape nucleus',/,
18316      &                8X,'id : ',I3,'   reduced energy: ',E15.4,
18317      &                '   mass: ',E12.3)
18318                ISTHKK(I) = 14+IPOT
18319                IF (ISTHKK(I).EQ.15) THEN
18320                   DO 28 K=1,4
18321                      PHKK(K,I) = PSEC0(K)
18322                      TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18323    28             CONTINUE
18324                   IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18325                   IF (IDSEC.EQ.1) NPCW = NPCW-1
18326                ELSEIF (ISTHKK(I).EQ.16) THEN
18327                   DO 29 K=1,4
18328                      PHKK(K,I) = PSEC0(K)
18329                      TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18330    29             CONTINUE
18331                   IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18332                   IF (IDSEC.EQ.1) NTCW = NTCW-1
18333                ENDIF
18334                GOTO 20
18335             ENDIF
18336
18337             IF (JPMOD.EQ.1) THEN
18338                PSECN  = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
18339 * 4-momentum after correction for nuclear potential
18340                DO 22 K=1,3
18341                   PSEC(K) = PSEC(K)*PSECN/PSECO
18342    22          CONTINUE
18343
18344 * store recoil momentum from particles escaping the nuclear potentials
18345                DO 30 K=1,4
18346                   IF (IPOT.EQ.1) THEN
18347                      TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K)
18348                   ELSEIF (IPOT.EQ.2) THEN
18349                      TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K)
18350                   ENDIF
18351    30          CONTINUE
18352
18353 * transform momentum back into n-n cms
18354                IMODE = IPOT+1
18355                CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4),
18356      &                     PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18357      &                     IDSEC,IMODE)
18358             ENDIF
18359
18360          ENDIF
18361
18362    23    CONTINUE
18363          DO 31 K=1,4
18364             PFSP(K) = PFSP(K)+PHKK(K,I)
18365    31    CONTINUE
18366
18367    20 CONTINUE
18368
18369       DO 33 I=NPOINT(4),NHKK
18370          IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN
18371             PFSP(1) = PFSP(1)+PHKK(1,I)
18372             PFSP(2) = PFSP(2)+PHKK(2,I)
18373             PFSP(3) = PFSP(3)+PHKK(3,I)
18374             PFSP(4) = PFSP(4)+PHKK(4,I)
18375          ENDIF
18376    33 CONTINUE
18377
18378       DO 34 K=1,5
18379          PRCLPR(K) = TRCLPR(K)
18380          PRCLTA(K) = TRCLTA(K)
18381    34 CONTINUE
18382
18383       IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18384 * hadron-nucleus interactions: get residual momentum from energy-
18385 * momentum conservation
18386          DO 32 K=1,4
18387             PRCLPR(K) = ZERO
18388             PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
18389    32    CONTINUE
18390       ELSE
18391 * nucleus-hadron, nucleus-nucleus: get residual momentum from
18392 * accumulated recoil momenta of particles leaving the spectators
18393 *   transform accumulated recoil momenta of residual nuclei into
18394 *   n-n cms
18395          PZI = PRCLPR(3)
18396          PEI = PRCLPR(4)
18397          CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
18398          PZI = PRCLTA(3)
18399          PEI = PRCLTA(4)
18400          CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
18401 C        IF (IP.GT.1) THEN
18402             PRCLPR(3) = PRCLPR(3)+PINIPR(3)
18403             PRCLPR(4) = PRCLPR(4)+PINIPR(4)
18404 C        ENDIF
18405          IF (IT.GT.1) THEN
18406             PRCLTA(3) = PRCLTA(3)+PINITA(3)
18407             PRCLTA(4) = PRCLTA(4)+PINITA(4)
18408          ENDIF
18409       ENDIF
18410
18411 * check momenta of residual nuclei
18412       IF (LEMCCK) THEN
18413          CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
18414      &               1,IDUM,IDUM)
18415          CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
18416      &               2,IDUM,IDUM)
18417          CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
18418      &               2,IDUM,IDUM)
18419          CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
18420      &               2,IDUM,IDUM)
18421          CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM)
18422 **sr 19.12. changed to avoid output when used with phojet
18423 C        CHKLEV = TINY3
18424          CHKLEV = TINY1
18425          CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
18426 C        IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
18427 C    &      CALL DT_EVTOUT(4)
18428          IF (IREJ1.GT.0) RETURN
18429       ENDIF
18430
18431       RETURN
18432       END
18433
18434 *$ CREATE DT_SCN4BA.FOR
18435 *COPY DT_SCN4BA
18436 *
18437 *===scn4ba=============================================================*
18438 *
18439       SUBROUTINE DT_SCN4BA
18440
18441 ************************************************************************
18442 * SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot.    *
18443 * This version dated 12.12.95 is written by S. Roesler.                *
18444 ************************************************************************
18445
18446       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18447       SAVE
18448       PARAMETER ( LINP = 10 ,
18449      &            LOUT = 6 ,
18450      &            LDAT = 9 )
18451       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
18452      &           TINY10=1.0D-10)
18453
18454 * event history
18455       PARAMETER (NMXHKK=200000)
18456       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18457      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18458      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18459 * extended event history
18460       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18461      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18462      &                IHIST(2,NMXHKK)
18463 * particle properties (BAMJET index convention)
18464       CHARACTER*8  ANAME
18465       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18466      &                IICH(210),IIBAR(210),K1(210),K2(210)
18467 * properties of interacting particles
18468       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18469 * nuclear potential
18470       LOGICAL LFERMI
18471       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18472      &                EBINDP(2),EBINDN(2),EPOT(2,210),
18473      &                ETACOU(2),ICOUL,LFERMI
18474 * treatment of residual nuclei: wounded nucleons
18475       COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18476 * treatment of residual nuclei: 4-momenta
18477       LOGICAL LRCLPR,LRCLTA
18478       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18479      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18480
18481       DIMENSION PLAB(2,5),PCMS(4)
18482
18483       IREJ = 0
18484
18485 * get number of wounded nucleons
18486       NPW    = 0
18487       NPW0   = 0
18488       NPCW   = 0
18489       NPSTCK = 0
18490       NTW    = 0
18491       NTW0   = 0
18492       NTCW   = 0
18493       NTSTCK = 0
18494
18495       ISGLPR = 0
18496       ISGLTA = 0
18497       LRCLPR = .FALSE.
18498       LRCLTA = .FALSE.
18499
18500 C     DO 2 I=1,NHKK
18501       DO 2 I=1,NPOINT(1)
18502 * projectile nucleons wounded in primary interaction and in fzc
18503          IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
18504             NPW      = NPW+1
18505             IPW(NPW) = I
18506             NPSTCK   = NPSTCK+1
18507             IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
18508             IF (ISTHKK(I).EQ.11)  NPW0 = NPW0+1
18509 C           IF (IP.GT.1) THEN
18510                DO 5 K=1,4
18511                   TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
18512     5          CONTINUE
18513 C           ENDIF
18514 * target nucleons wounded in primary interaction and in fzc
18515          ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
18516             NTW      = NTW+1
18517             ITW(NTW) = I
18518             NTSTCK   = NTSTCK+1
18519             IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
18520             IF (ISTHKK(I).EQ.12)  NTW0 = NTW0+1
18521             IF (IT.GT.1) THEN
18522                DO 6 K=1,4
18523                   TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
18524     6          CONTINUE
18525             ENDIF
18526          ELSEIF (ISTHKK(I).EQ.13) THEN
18527             ISGLPR = I
18528          ELSEIF (ISTHKK(I).EQ.14) THEN
18529             ISGLTA = I
18530          ENDIF
18531     2 CONTINUE
18532
18533       DO 11 I=NPOINT(4),NHKK
18534 * baryons which are unable to escape the nuclear potential of proj.
18535          IF (ISTHKK(I).EQ.15) THEN
18536             ISGLPR = I
18537             NPSTCK = NPSTCK-1
18538             IF (IIBAR(IDBAM(I)).NE.0) THEN
18539                NPW    = NPW-1
18540                IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
18541             ENDIF
18542             DO 7 K=1,4
18543                TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18544     7       CONTINUE
18545 * baryons which are unable to escape the nuclear potential of targ.
18546          ELSEIF (ISTHKK(I).EQ.16) THEN
18547             ISGLTA = I
18548             NTSTCK = NTSTCK-1
18549             IF (IIBAR(IDBAM(I)).NE.0) THEN
18550                NTW    = NTW-1
18551                IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
18552             ENDIF
18553             DO 8 K=1,4
18554                TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18555     8       CONTINUE
18556          ENDIF
18557    11 CONTINUE
18558
18559 * residual nuclei so far
18560       IRESP = IP-NPSTCK
18561       IREST = IT-NTSTCK
18562
18563 * ckeck for "residual nuclei" consisting of one nucleon only
18564 * treat it as final state particle
18565       IF (IRESP.EQ.1) THEN
18566          ID  = IDBAM(ISGLPR)
18567          IST = ISTHKK(ISGLPR)
18568          CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR),
18569      &               PHKK(3,ISGLPR),PHKK(4,ISGLPR),
18570      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2)
18571          IF (IST.EQ.13) THEN
18572             ISTHKK(ISGLPR) = 11
18573          ELSE
18574             ISTHKK(ISGLPR) = 2
18575          ENDIF
18576          CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0,
18577      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18578      &               IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR))
18579          NOBAM(NHKK)      = NOBAM(ISGLPR)
18580          JDAHKK(1,ISGLPR) = NHKK
18581          DO 21 K=1,4
18582             TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
18583    21    CONTINUE
18584       ENDIF
18585       IF (IREST.EQ.1) THEN
18586          ID  = IDBAM(ISGLTA)
18587          IST = ISTHKK(ISGLTA)
18588          CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA),
18589      &               PHKK(3,ISGLTA),PHKK(4,ISGLTA),
18590      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3)
18591          IF (IST.EQ.14) THEN
18592             ISTHKK(ISGLTA) = 12
18593          ELSE
18594             ISTHKK(ISGLTA) = 2
18595          ENDIF
18596          CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0,
18597      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18598      &               IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA))
18599          NOBAM(NHKK)      = NOBAM(ISGLTA)
18600          JDAHKK(1,ISGLTA) = NHKK
18601          DO 22 K=1,4
18602             TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
18603    22    CONTINUE
18604       ENDIF
18605
18606 * get nuclear potential corresp. to the residual nucleus
18607       IPRCL  = IP -NPW
18608       IPZRCL = IPZ-NPCW
18609       ITRCL  = IT -NTW
18610       ITZRCL = ITZ-NTCW
18611       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
18612
18613 * baryons unable to escape the nuclear potential are treated as
18614 * excited nucleons (ISTHKK=15,16)
18615       DO 3 I=NPOINT(4),NHKK
18616          IF (ISTHKK(I).EQ.1) THEN
18617             ID  = IDBAM(I)
18618             IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN
18619 *   final state n and p not being outside of both nuclei are considered
18620                NPOTP = 1
18621                NPOTT = 1
18622                IF ( (IP.GT.1)      .AND.(IRESP.GT.1).AND.
18623      &              (NOBAM(I).NE.1).AND.(NPW.GT.0)        ) THEN
18624 *     Lorentz-trsf. into proj. rest sys. for those being inside proj.
18625                   CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18626      &                        PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3),
18627      &                        PLAB(1,4),ID,-2)
18628                   PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2)
18629                   PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)*
18630      &                                  (PLAB(1,4)+PLABT) ))
18631                   EKIN = PLAB(1,4)-PLAB(1,5)
18632                   IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15
18633                   IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1
18634                ENDIF
18635                IF ( (IT.GT.1)      .AND.(IREST.GT.1).AND.
18636      &              (NOBAM(I).NE.2).AND.(NTW.GT.0)        ) THEN
18637 *     Lorentz-trsf. into targ. rest sys. for those being inside targ.
18638                   CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18639      &                        PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3),
18640      &                        PLAB(2,4),ID,-3)
18641                   PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2)
18642                   PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)*
18643      &                                  (PLAB(2,4)+PLABT) ))
18644                   EKIN = PLAB(2,4)-PLAB(2,5)
18645                   IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16
18646                   IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1
18647                ENDIF
18648                IF (PHKK(3,I).GE.ZERO) THEN
18649                   ISTHKK(I) = NPOTT
18650                   IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
18651                ELSE
18652                   ISTHKK(I) = NPOTP
18653                   IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
18654                ENDIF
18655                IF (ISTHKK(I).NE.1) THEN
18656                   J = ISTHKK(I)-14
18657                   DO 4 K=1,5
18658                      PHKK(K,I) = PLAB(J,K)
18659     4             CONTINUE
18660                   IF (ISTHKK(I).EQ.15) THEN
18661                      NPW = NPW-1
18662                      IF (ID.EQ.1) NPCW = NPCW-1
18663                      DO 9 K=1,4
18664                         TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18665     9                CONTINUE
18666                   ELSEIF (ISTHKK(I).EQ.16) THEN
18667                      NTW = NTW-1
18668                      IF (ID.EQ.1) NTCW = NTCW-1
18669                      DO 10 K=1,4
18670                         TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18671    10                CONTINUE
18672                   ENDIF
18673                ENDIF
18674             ENDIF
18675          ENDIF
18676     3 CONTINUE
18677
18678 * again: get nuclear potential corresp. to the residual nucleus
18679       IPRCL  = IP -NPW
18680       IPZRCL = IPZ-NPCW
18681       ITRCL  = IT -NTW
18682       ITZRCL = ITZ-NTCW
18683 c      AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
18684 cC     AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
18685 c     &             *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
18686 C     AFERP = 0.0D0
18687 c      AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
18688 cC     AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
18689 c     &             *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
18690 C     AFERT = 0.0D0
18691 C     IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
18692 C     IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
18693 C     IF (AFERP.GT.0.85D0) AFERP = 0.85D0
18694 C     IF (AFERT.GT.0.85D0) AFERT = 0.85D0
18695       AFERP = FERMOD+0.1D0
18696       AFERT = FERMOD+0.1D0
18697
18698       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
18699
18700       RETURN
18701       END
18702
18703 *$ CREATE DT_FICONF.FOR
18704 *COPY DT_FICONF
18705 *
18706 *===ficonf=============================================================*
18707 *
18708       SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
18709
18710 ************************************************************************
18711 * Treatment of FInal CONFiguration including evaporation, fission and  *
18712 * Fermi-break-up (for light nuclei only).                              *
18713 * Adopted from the original routine FINALE and extended to residual    *
18714 * projectile nuclei.                                                   *
18715 * This version dated 12.12.95 is written by S. Roesler.                *
18716 *                                                                      *
18717 * Last change 27.12.2006 by S. Roesler.                                *
18718 ************************************************************************
18719
18720       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18721       SAVE
18722       PARAMETER ( LINP = 10 ,
18723      &            LOUT = 6 ,
18724      &            LDAT = 9 )
18725       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
18726       PARAMETER (ANGLGB=5.0D-16)
18727       PARAMETER (AMUAMU=0.93149432D0,AMELEC=0.51099906D-3)
18728
18729 * event history
18730       PARAMETER (NMXHKK=200000)
18731       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18732      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18733      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18734 * extended event history
18735       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18736      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18737      &                IHIST(2,NMXHKK)
18738 * rejection counter
18739       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
18740      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
18741      &                IREXCI(3),IRDIFF(2),IRINC
18742 * central particle production, impact parameter biasing
18743       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
18744 * particle properties (BAMJET index convention)
18745       CHARACTER*8  ANAME
18746       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18747      &                IICH(210),IIBAR(210),K1(210),K2(210)
18748 * treatment of residual nuclei: 4-momenta
18749       LOGICAL LRCLPR,LRCLTA
18750       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18751      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18752 * treatment of residual nuclei: properties of residual nuclei
18753       COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
18754      &                NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
18755      &                NTOTFI(2),NPROFI(2)
18756 * statistics: residual nuclei
18757       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
18758      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
18759      &                NINCST(2,4),NINCEV(2),
18760      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
18761      &                NRESPB(2),NRESCH(2),NRESEV(4),
18762      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
18763      &                NEVAFI(2,2)
18764 * flags for input different options
18765       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18766       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18767      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18768 * (original name: FINUC)
18769       PARAMETER (MXP=999)
18770       COMMON /FKFINU/ CXR    (MXP), CYR    (MXP), CZR    (MXP),
18771      &                CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
18772      &                TKI    (MXP), PLR    (MXP), WEI    (MXP),
18773      &                TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
18774      &                KPART  (MXP)
18775 * (original name: RESNUC)
18776       LOGICAL LRNFSS, LFRAGM
18777       COMMON /FKRESN/  AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
18778      &                   ANOW,   ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
18779      &                   ERES,  EKRES, AMNRES, AMMRES,  PTRES,  PXRES,
18780      &                  PYRES,  PZRES, PTRES2,  KTARP,  KTARN, IGREYP,
18781      &                 IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
18782      &                  ICRES,  IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
18783      &                 IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
18784      &                  IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
18785      &                 LFRAGM
18786       COMMON /FKNDAT/ AV0WEL,     APFRMX,     AEFRMX,     AEFRMA,
18787      &                RDSNUC,     V0WELL (2), PFRMMX (2), EFRMMX (2),
18788      &                EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
18789      &                VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
18790      &                PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
18791      &                EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
18792      &                ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV    ,
18793      &                AMRCSQ    , ATO1O3    , ZTO1O3    , ELBNDE (0:100)
18794 * (original name: PAREVT)
18795       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
18796      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
18797       PARAMETER ( NALLWP = 39   )
18798       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
18799      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
18800      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
18801      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
18802 * event flag
18803       COMMON /DTEVNO/ NEVENT,ICASCA
18804
18805       DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2),
18806      &          PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4),
18807      &          P1IN(4),P2IN(4),P1OUT(4),P2OUT(4)
18808
18809       DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260)
18810       LOGICAL LLCPOT
18811       DATA EXC,NEXC /520*ZERO,520*0/
18812       DATA EXPNUC /4.0D-3,4.0D-3/
18813
18814       IREJ   = 0
18815       LRCLPR = .FALSE.
18816       LRCLTA = .FALSE.
18817
18818 * skip residual nucleus treatment if not requested or in case
18819 * of central collisions
18820       IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN
18821
18822       DO 1 K=1,2
18823          IDPAR(K) = 0
18824          IDXPAR(K)= 0
18825          NTOT(K)  = 0
18826          NTOTFI(K)= 0
18827          NPRO(K)  = 0
18828          NPROFI(K)= 0
18829          NN(K)    = 0
18830          NH(K)    = 0
18831          NHPOS(K) = 0
18832          NQ(K)    = 0
18833          EEXC(K)  = ZERO
18834          MO1(K)   = 0
18835          MO2(K)   = 0
18836          DO 2 I=1,4
18837             VRCL(K,I) = ZERO
18838             WRCL(K,I) = ZERO
18839     2    CONTINUE
18840     1 CONTINUE
18841       NFSP = 0
18842       INUC(1) = IP
18843       INUC(2) = IT
18844
18845       DO 3 I=1,NHKK
18846
18847 * number of final state particles
18848          IF (ABS(ISTHKK(I)).EQ.1) THEN
18849             NFSP  = NFSP+1
18850             IDFSP = IDBAM(I)
18851          ENDIF
18852
18853 * properties of remaining nucleon configurations
18854          KF = 0
18855          IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1
18856          IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2
18857          IF (KF.GT.0) THEN
18858             IF (MO1(KF).EQ.0) MO1(KF) = I
18859             MO2(KF)  = I
18860 *   position of residual nucleus = average position of nucleons
18861             DO 4 K=1,4
18862                VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
18863                WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
18864     4       CONTINUE
18865 *   total number of particles contributing to each residual nucleus
18866             NTOT(KF)  = NTOT(KF)+1
18867             IDTMP     = IDBAM(I)
18868             IDXTMP    = I
18869 *   total charge of residual nuclei
18870             NQ(KF) = NQ(KF)+IICH(IDTMP)
18871 *   number of protons
18872             IF (IDHKK(I).EQ.2212) THEN
18873                NPRO(KF) = NPRO(KF)+1
18874 *   number of neutrons
18875             ELSEIF (IDHKK(I).EQ.2112) THEN
18876                NN(KF) = NN(KF)+1
18877             ELSE
18878 *   number of baryons other than n, p
18879                IF (IIBAR(IDTMP).EQ.1) THEN
18880                   NH(KF) = NH(KF)+1
18881                   IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
18882                ELSE
18883 *   any other mesons (status set to 1)
18884 C                 WRITE(LOUT,1002) KF,IDTMP
18885 C1002             FORMAT(1X,'FICONF:   residual nucleus ',I2,
18886 C    &                   ' containing meson ',I4,', status set to 1')
18887                   ISTHKK(I) = 1
18888                   IDTMP     = IDPAR(KF)
18889                   IDXTMP    = IDXPAR(KF)
18890                   NTOT(KF)  = NTOT(KF)-1
18891                ENDIF
18892             ENDIF
18893             IDPAR(KF)  = IDTMP
18894             IDXPAR(KF) = IDXTMP
18895          ENDIF
18896     3 CONTINUE
18897
18898 * reject elastic events (def: one final state particle = projectile)
18899       IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN
18900          IREXCI(3) = IREXCI(3)+1
18901          GOTO 9999
18902 C        RETURN
18903       ENDIF
18904
18905 * check if one nucleus disappeared..
18906 C     IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
18907 C        DO 5 K=1,4
18908 C           PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
18909 C           PRCLPR(K) = ZERO
18910 C   5    CONTINUE
18911 C     ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
18912 C        DO 6 K=1,4
18913 C           PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
18914 C           PRCLTA(K) = ZERO
18915 C   6    CONTINUE
18916 C     ENDIF
18917
18918       ICOR   = 0
18919       INORCL = 0
18920       DO 7 I=1,2
18921          DO 8 K=1,4
18922 * get the average of the nucleon positions
18923             VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1)
18924             WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1)
18925             IF (I.EQ.1) PRCL(1,K) = PRCLPR(K)
18926             IF (I.EQ.2) PRCL(2,K) = PRCLTA(K)
18927     8    CONTINUE
18928 * mass number and charge of residual nuclei
18929          AIF(I)  = DBLE(NTOT(I))
18930          AIZF(I) = DBLE(NPRO(I)+NHPOS(I))
18931          IF (NTOT(I).GT.1) THEN
18932 * masses of residual nuclei in ground state
18933             AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*DT_ENERGY(AIF(I),AIZF(I))
18934 * masses of residual nuclei
18935             PTORCL   = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2)
18936             AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL)
18937             IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I))
18938 *
18939 *   M_res^2 < 0 : configuration not allowed
18940 *
18941 *      a) re-calculate E_exc with scaled nuclear potential
18942 *         (conditional jump to label 9998)
18943 *      b) or reject event if N_loop(max) is exceeded
18944 *         (conditional jump to label 9999)
18945 *
18946             IF (AMRCL(I).LE.ZERO) THEN
18947                IF (IOULEV(3).GT.0)
18948      &            WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3),
18949      &                             PRCL(I,4),NTOT
18950  1000          FORMAT(1X,'warning! negative excitation energy',/,
18951      &                I4,4E15.4,2I4)
18952                AMRCL(I) = ZERO
18953                EEXC(I)  = ZERO
18954                IF (NLOOP.LE.500) THEN
18955                   GOTO 9998
18956                ELSE
18957                   IREXCI(2) = IREXCI(2)+1
18958                   GOTO 9999
18959                ENDIF
18960 *
18961 *   0 < M_res < M_res0 : mass below ground-state mass
18962 *
18963 *      a) we had residual nuclei with mass N_tot and reasonable E_exc
18964 *         before- assign average E_exc of those configurations to this
18965 *         one ( Nexc(i,N_tot) > 0 )
18966 *      b) or (and this applies always if run in transport codes) go up
18967 *         one mass number and
18968 *           i) if mass now larger than proj/targ mass or if run in
18969 *              transport codes assign average E_exc per wounded nucleon
18970 *              x number of wounded nucleons (Inuc-Ntot)
18971 *          ii) or assign average E_exc of those configurations to this
18972 *              one ( Nexc(i,m) > 0 )
18973 *
18974             ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
18975      &                                                         THEN
18976                M = MIN(NTOT(I),260)
18977                IF (NEXC(I,M).GT.0) THEN
18978                   AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
18979                ELSE
18980    70             CONTINUE
18981                   M = M+1
18982 **sr corrected 27.12.06
18983 *                 IF (M.GE.INUC(I)) THEN
18984 *                    AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
18985                   IF ((M.GE.INUC(I)).OR.(ICASCA.GT.0)) THEN
18986                      IF ( INUC (I) .GT. NTOT (I) ) THEN
18987                         AMRCL(I) = AMRCL0(I)
18988      &                         + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0))
18989                      ELSE
18990                         AMRCL(I) = AMRCL0(I) + 0.5D+00 * EXPNUC(I)
18991                      END IF
18992 **
18993                   ELSE
18994                      IF (NEXC(I,M).GT.0) THEN
18995                         AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
18996                      ELSE
18997                         GOTO 70
18998                      ENDIF
18999                   ENDIF
19000                ENDIF
19001                EEXC(I)  = AMRCL(I)-AMRCL0(I)
19002                ICOR     = ICOR+I
19003 *
19004 *   M_res > 2.5 x M_res0 : unreasonably(?) high E_exc
19005 *
19006 *      a) re-calculate E_exc with scaled nuclear potential
19007 *         (conditional jump to label 9998)
19008 *      b) or reject event if N_loop(max) is exceeded
19009 *         (conditional jump to label 9999)
19010 *
19011 *
19012             ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN
19013                IF (IOULEV(3).GT.0)
19014      &            WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK
19015  1004          FORMAT(1X,'warning! too high excitation energy',/,
19016      &                I4,1P,2E15.4,3I5)
19017                AMRCL(I) = ZERO
19018                EEXC(I)  = ZERO
19019                IF (NLOOP.LE.500) THEN
19020                   GOTO 9998
19021                ELSE
19022                   IREXCI(2) = IREXCI(2)+1
19023                   GOTO 9999
19024                ENDIF
19025 *
19026 *   Otherwise (reasonable E_exc) :
19027 *      E_exc = M_res - M_res0
19028 *      in addition: calculate and save E_exc per wounded nucleon as
19029 *                   well as E_exc in <E_exc> counter
19030 *
19031             ELSE
19032 * excitation energies of residual nuclei
19033                EEXC(I)   = AMRCL(I)-AMRCL0(I)
19034 **sr 27.12.06 new excitation energy correction by A.F.
19035 *
19036 * all parts with Ilcopt<3 commented since not used
19037 *
19038 * still to be done/decided:
19039 *   Increase Icor and put back both residual nuclei on mass shell
19040 *   with the exciting correction further below.
19041 *   For the moment the modification in the excitation energy is simply
19042 *   corrected by scaling the energy of the residual nucleus.
19043 *
19044                LLCPOT = .TRUE.
19045                ILCOPT = 3
19046                IF ( LLCPOT ) THEN
19047                   NNCHIT = MAX ( INUC (I) - NTOT (I), 0 )
19048                   IF ( ILCOPT .LE. 2 ) THEN
19049 C* Patch for Fermi momentum reduction correlated with impact parameter:
19050 C                     FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE )
19051 C                     DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I)))
19052 C                     AKPRHO = ONE - DLKPRH
19053 C* f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen
19054 C                     FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO  - ONE,
19055 C     &                              0.05D+00 )
19056 C*                    REDORI = 0.75D+00
19057 C*                    REDORI = ONE
19058 C                     REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
19059                   ELSE
19060                      DLKPRH = ZERO
19061                      RDCORE = 1.14D+00 * DBLE(INUC(I))**(ONE/3.D+00)
19062 *  Take out roughly one/half of the skin:
19063                      RDCORE = RDCORE - 0.5D+00
19064                      FRCFLL = RDCORE**3
19065                      PRSKIN = (RDCORE+2.4D+00)**3 - FRCFLL
19066                      PRSKIN = 0.5D+00 * PRSKIN / ( PRSKIN + FRCFLL )
19067                      FRCFLL = ONE - PRSKIN
19068                      FRMRDC = FRCFLL + 0.5D+00 * PRSKIN
19069                      REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
19070                   END IF
19071                   IF ( NNCHIT .GT. 0 ) THEN
19072 C                     IF ( ILCOPT .EQ. 1 ) THEN
19073 C                        SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE)
19074 C                        DO 1220 NCH = 1, 10
19075 C                           ETAETA = ( ONE - SKINRH**INUC(I)
19076 C     &                            - DBLE(INUC(I))* ( ONE - FRCFLL )
19077 C     &                            * ( ONE - SKINRH ) )
19078 C     &                            / ( SKINRH**INUC(I) - DBLE (INUC(I))
19079 C     &                            * ( ONE - FRCFLL) * SKINRH )
19080 C                           SKINRH = SKINRH * ( ONE + ETAETA )
19081 C 1220                   CONTINUE
19082 C                        PRSKIN = SKINRH**(NNCHIT-1)
19083 C                     ELSE IF ( ILCOPT .EQ. 2 ) THEN
19084 C                        PRSKIN = ONE - FRCFLL
19085 C                     END IF
19086                      REDCTN = ZERO
19087                      DO 1230 NCH = 1, NNCHIT
19088                         IF (DT_RNDM(PRFRMI) .LT. PRSKIN) THEN
19089                            PRFRMI = (( ONE - 2.D+00 * DLKPRH )
19090      &                            * DT_RNDM(PRFRMI))**0.333333333333D+00
19091                         ELSE
19092                            PRFRMI = ( ONE - 2.D+00 * DLKPRH
19093      &                            * DT_RNDM(PRFRMI))**0.333333333333D+00
19094                         END IF
19095                         REDCTN = REDCTN + PRFRMI**2
19096  1230                CONTINUE
19097                      REDCTN = REDCTN / DBLE (NNCHIT)
19098                   ELSE
19099                      REDCTN = 0.5D+00
19100                   END IF
19101                   EEXC  (I) = EEXC   (I) * REDCTN / REDORI
19102                   AMRCL (I) = AMRCL0 (I) + EEXC (I)
19103                   PRCL(I,4) = SQRT ( PTORCL**2 + AMRCL(I)**2 )
19104                END IF
19105 **
19106                IF (ICASCA.EQ.0) THEN
19107                   EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I))
19108                   M = MIN(NTOT(I),260)
19109                   EXC(I,M)  = EXC(I,M)+EEXC(I)
19110                   NEXC(I,M) = NEXC(I,M)+1
19111                ENDIF
19112             ENDIF
19113          ELSEIF (NTOT(I).EQ.1) THEN
19114             WRITE(LOUT,1003) I
19115  1003       FORMAT(1X,'FICONF:   warning! NTOT(I)=1? (I=',I3,')')
19116             GOTO 9999
19117          ELSE
19118             AMRCL0(I) = ZERO
19119             AMRCL(I)  = ZERO
19120             EEXC(I)   = ZERO
19121             INORCL    = INORCL+I
19122          ENDIF
19123     7 CONTINUE
19124
19125       PRCLPR(5) = AMRCL(1)
19126       PRCLTA(5) = AMRCL(2)
19127
19128       IF (ICOR.GT.0) THEN
19129          IF (INORCL.EQ.0) THEN
19130 * one or both residual nuclei consist of one nucleon only, transform
19131 * this nucleon on mass shell
19132             DO 9 K=1,4
19133                P1IN(K) = PRCL(1,K)
19134                P2IN(K) = PRCL(2,K)
19135     9       CONTINUE
19136             XM1 = AMRCL(1)
19137             XM2 = AMRCL(2)
19138             CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
19139             IF (IREJ1.GT.0) THEN
19140                WRITE(LOUT,*) 'ficonf-mashel rejection'
19141                GOTO 9999
19142             ENDIF
19143             DO 10 K=1,4
19144                PRCL(1,K) = P1OUT(K)
19145                PRCL(2,K) = P2OUT(K)
19146                PRCLPR(K) = P1OUT(K)
19147                PRCLTA(K) = P2OUT(K)
19148    10       CONTINUE
19149             PRCLPR(5) = AMRCL(1)
19150             PRCLTA(5) = AMRCL(2)
19151          ELSE
19152             IF (IOULEV(3).GT.0)
19153      &      WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)),
19154      &                       INT(AIF(2)),INT(AIZF(2)),AMRCL0(1),
19155      &                       AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2),
19156      &                       AMRCL(2),AMRCL(2)-AMRCL0(2)
19157  1001       FORMAT(1X,'FICONF:   warning! no residual nucleus for',
19158      &             ' correction',/,11X,'at event',I8,
19159      &             ',  nucleon config. 1:',2I4,' 2:',2I4,
19160      &             2(/,11X,3E12.3))
19161             IF (NLOOP.LE.500) THEN
19162                GOTO 9998
19163             ELSE
19164                IREXCI(1) = IREXCI(1)+1
19165             ENDIF
19166          ENDIF
19167       ENDIF
19168
19169 * update counter
19170 C     IF (NRESEV(1).NE.NEVHKK) THEN
19171 C        NRESEV(1) = NEVHKK
19172 C        NRESEV(2) = NRESEV(2)+1
19173 C     ENDIF
19174       NRESEV(2) = NRESEV(2)+1
19175       DO 15 I=1,2
19176          EXCDPM(I)   = EXCDPM(I)+EEXC(I)
19177          EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1))
19178          NRESTO(I) = NRESTO(I)+NTOT(I)
19179          NRESPR(I) = NRESPR(I)+NPRO(I)
19180          NRESNU(I) = NRESNU(I)+NN(I)
19181          NRESBA(I) = NRESBA(I)+NH(I)
19182          NRESPB(I) = NRESPB(I)+NHPOS(I)
19183          NRESCH(I) = NRESCH(I)+NQ(I)
19184    15 CONTINUE
19185
19186 * evaporation
19187       IF (LEVPRT) THEN
19188          DO 13 I=1,2
19189 * initialize evaporation counter
19190             EEXCFI(I) = ZERO
19191             IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
19192      &          (EEXC(I).GT.ZERO)) THEN
19193 * put residual nuclei into DTEVT1
19194                IDRCL = 80000
19195                JMASS = INT( AIF(I))
19196                JCHAR = INT(AIZF(I))
19197 *  the following patch is required to transmit the correct excitation
19198 *   energy to Eventd
19199                IF (ITRSPT.EQ.1) THEN
19200                   IF ((ABS(AMRCL(I)-AMRCL0(I)-EEXC(I)).GT.1.D-04).AND.
19201      &                (IOULEV(3).GT.0))
19202      &               WRITE(LOUT,*)
19203      &                  ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)',
19204      &                              AMRCL(I),AMRCL0(I),EEXC(I)
19205                   PRCL0 = PRCL(I,4)
19206                   PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
19207      &                                                    +PRCL(I,3)**2)
19208                   IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
19209                      WRITE(LOUT,*)
19210      &                  ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
19211                   ENDIF
19212                ENDIF
19213                CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1),
19214      &              PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0)
19215 **sr 22.6.97
19216                NOBAM(NHKK) = I
19217 **
19218                DO 14 J=1,4
19219                   VHKK(J,NHKK) = VRCL(I,J)
19220                   WHKK(J,NHKK) = WRCL(I,J)
19221    14          CONTINUE
19222 *  interface to evaporation module - fill final residual nucleus into
19223 *  common FKRESN
19224 *   fill resnuc only if code is not used as event generator in Fluka
19225                IF (ITRSPT.NE.1) THEN
19226                   PXRES  = PRCL(I,1)
19227                   PYRES  = PRCL(I,2)
19228                   PZRES  = PRCL(I,3)
19229                   IBRES  = NPRO(I)+NN(I)+NH(I)
19230                   ICRES  = NPRO(I)+NHPOS(I)
19231                   ANOW   = DBLE(IBRES)
19232                   ZNOW   = DBLE(ICRES)
19233                   PTRES  = SQRT(PXRES**2+PYRES**2+PZRES**2)
19234 *   ground state mass of the residual nucleus (should be equal to AM0T)
19235                   AMMRES = AMRCL0(I)
19236                   AMNRES = AMMRES-ZNOW*AMELEC+ELBNDE(ICRES)
19237 *  common FKFINU
19238                   TV = ZERO
19239 *   kinetic energy of residual nucleus
19240                   TVRECL = PRCL(I,4)-AMRCL(I)
19241 *   excitation energy of residual nucleus
19242                   TVCMS  = EEXC(I)
19243                   PTOLD  = PTRES
19244                   PTRES  = SQRT(ABS(TVRECL*(TVRECL+
19245      &                          2.0D0*(AMMRES+TVCMS))))
19246                   IF (PTOLD.LT.ANGLGB) THEN
19247                      CALL DT_RACO(PXRES,PYRES,PZRES)
19248                      PTOLD = ONE
19249                   ENDIF
19250                   PXRES = PXRES*PTRES/PTOLD
19251                   PYRES = PYRES*PTRES/PTOLD
19252                   PZRES = PZRES*PTRES/PTOLD
19253 * zero counter of secondaries from evaporation
19254                   NP = 0
19255 * evaporation
19256                   WE = ONE
19257                   CALL DT_EVEVAP(WE)
19258 * put evaporated particles and residual nuclei to DTEVT1
19259                   MO = NHKK
19260                   CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
19261                ENDIF
19262                EEXCFI(I) = EXCITF
19263                EXCEVA(I) = EXCEVA(I)+EXCITF
19264             ENDIF
19265    13    CONTINUE
19266       ENDIF
19267
19268       RETURN
19269
19270 C9998 IREXCI(1) = IREXCI(1)+1
19271  9998 IREJ   = IREJ+1
19272  9999 CONTINUE
19273       LRCLPR = .TRUE.
19274       LRCLTA = .TRUE.
19275       IREJ   = IREJ+1
19276       RETURN
19277       END
19278
19279 *$ CREATE DT_EVA2HE.FOR
19280 *COPY DT_EVA2HE
19281 *                                                                      *
19282 *====eva2he============================================================*
19283 *                                                                      *
19284       SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
19285
19286 ************************************************************************
19287 * Interface between common's of evaporation module (FKFINU,FKFHVY)     *
19288 * and DTEVT1.                                                          *
19289 *    MO    DTEVT1-index of "mother" (residual) nucleus before evap.    *
19290 *    EEXCF exitation energy of residual nucleus after evaporation      *
19291 *    IRCL  = 1 projectile residual nucleus                             *
19292 *          = 2 target     residual nucleus                             *
19293 * This version dated 19.04.95 is written by S. Roesler.                *
19294 *                                                                      *
19295 * Last change 27.12.2006 by S. Roesler.                                *
19296 ************************************************************************
19297
19298       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19299       SAVE
19300       PARAMETER ( LINP = 10 ,
19301      &            LOUT = 6 ,
19302      &            LDAT = 9 )
19303       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3)
19304
19305 * event history
19306       PARAMETER (NMXHKK=200000)
19307       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19308      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19309      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19310 * Note: DTEVT2 - special use for heavy fragments !
19311 *       (IDRES(I) = mass number, IDXRES(I) = charge)
19312 * extended event history
19313       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19314      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19315      &                IHIST(2,NMXHKK)
19316 * particle properties (BAMJET index convention)
19317       CHARACTER*8  ANAME
19318       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19319      &                IICH(210),IIBAR(210),K1(210),K2(210)
19320 * flags for input different options
19321       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
19322       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
19323      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
19324 * statistics: residual nuclei
19325       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
19326      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
19327      &                NINCST(2,4),NINCEV(2),
19328      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
19329      &                NRESPB(2),NRESCH(2),NRESEV(4),
19330      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
19331      &                NEVAFI(2,2)
19332 * treatment of residual nuclei: properties of residual nuclei
19333       COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
19334      &                NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
19335      &                NTOTFI(2),NPROFI(2)
19336 * (original name: FINUC)
19337       PARAMETER (MXP=999)
19338       COMMON /FKFINU/ CXR    (MXP), CYR    (MXP), CZR    (MXP),
19339      &                CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
19340      &                TKI    (MXP), PLR    (MXP), WEI    (MXP),
19341      &                TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
19342      &                KPART  (MXP)
19343 * (original name: FHEAVY,FHEAVC)
19344       PARAMETER ( MXHEAV = 100 )
19345       CHARACTER*8 ANHEAV
19346       COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
19347      &                CZHEAV (MXHEAV), TKHEAV (MXHEAV),
19348      &                PHEAVY (MXHEAV), WHEAVY (MXHEAV),
19349      &                AMHEAV  ( 12 ) , AMNHEA  ( 12 ) ,
19350      &                KHEAVY (MXHEAV), ICHEAV  ( 12 ) ,
19351      &                IBHEAV  ( 12 ) , NPHEAV
19352       COMMON /FKFHVC/ ANHEAV  ( 12 )
19353 * (original name: RESNUC)
19354       LOGICAL LRNFSS, LFRAGM
19355       COMMON /FKRESN/  AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
19356      &                   ANOW,   ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
19357      &                   ERES,  EKRES, AMNRES, AMMRES,  PTRES,  PXRES,
19358      &                  PYRES,  PZRES, PTRES2,  KTARP,  KTARN, IGREYP,
19359      &                 IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
19360      &                  ICRES,  IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
19361      &                 IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
19362      &                  IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
19363      &                 LFRAGM
19364
19365       DIMENSION IPTOKP(39)
19366       DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
19367      & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
19368      & 100, 101, 97, 102, 98, 103, 109, 115 /
19369
19370       IREJ = 0
19371
19372 * skip if evaporation package is not included
19373       IF (.NOT.LEVAPO) RETURN
19374
19375 * update counter
19376       IF (NRESEV(3).NE.NEVHKK) THEN
19377          NRESEV(3) = NEVHKK
19378          NRESEV(4) = NRESEV(4)+1
19379       ENDIF
19380
19381       IF (LEMCCK)
19382      &   CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
19383      &                                                   IDUM,IDUM)
19384 * mass number/charge of residual nucleus before evaporation
19385       IBTOT = IDRES(MO)
19386       IZTOT = IDXRES(MO)
19387
19388 * protons/neutrons/gammas
19389       DO 1 I=1,NP
19390          PX    = CXR(I)*PLR(I)
19391          PY    = CYR(I)*PLR(I)
19392          PZ    = CZR(I)*PLR(I)
19393          ID    = IPTOKP(KPART(I))
19394          IDPDG = IDT_IPDGHA(ID)
19395          AM    = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/
19396      &           (2.0D0*MAX(TKI(I),TINY10))
19397          IF (ABS(AM-AAM(ID)).GT.TINY3) THEN
19398             WRITE(LOUT,1000) ID,AM,AAM(ID)
19399  1000       FORMAT(1X,'EVA2HE:  inconsistent mass of evap. ',
19400      &             'particle',I3,2E10.3)
19401          ENDIF
19402          PE = TKI(I)+AM
19403          CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
19404          NOBAM(NHKK) = IRCL
19405          IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19406          IBTOT = IBTOT-IIBAR(ID)
19407          IZTOT = IZTOT-IICH(ID)
19408     1 CONTINUE
19409
19410 * heavy fragments
19411       DO 2 I=1,NPHEAV
19412          PX     = CXHEAV(I)*PHEAVY(I)
19413          PY     = CYHEAV(I)*PHEAVY(I)
19414          PZ     = CZHEAV(I)*PHEAVY(I)
19415          IDHEAV = 80000
19416          AM     = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
19417      &            (2.0D0*MAX(TKHEAV(I),TINY10))
19418          PE     = TKHEAV(I)+AM
19419          CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
19420      &                  IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
19421          NOBAM(NHKK) = IRCL
19422          IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19423          IBTOT = IBTOT-IBHEAV(KHEAVY(I))
19424          IZTOT = IZTOT-ICHEAV(KHEAVY(I))
19425     2 CONTINUE
19426
19427       IF (IBRES.GT.0) THEN
19428 * residual nucleus after evaporation
19429          IDNUC = 80000
19430          CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
19431      &                                        IBRES,ICRES,0)
19432          NOBAM(NHKK) = IRCL
19433       ENDIF
19434       EEXCF = TVCMS
19435       NTOTFI(IRCL) = IBRES
19436       NPROFI(IRCL) = ICRES
19437       IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM)
19438       IBTOT = IBTOT-IBRES
19439       IZTOT = IZTOT-ICRES
19440
19441 * count events with fission
19442       NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
19443       IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
19444
19445 * energy-momentum conservation check
19446       IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
19447 C     IF (IREJ.GT.0) THEN
19448 C        CALL DT_EVTOUT(4)
19449 C        WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
19450 C     ENDIF
19451 * baryon-number/charge conservation check
19452       IF (IBTOT+IZTOT.NE.0) THEN
19453          WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT
19454  1001    FORMAT(1X,'EVA2HE:   baryon-number/charge conservation ',
19455      &          'failure at event ',I8,' :  IBTOT,IZTOT = ',2I3)
19456       ENDIF
19457
19458       RETURN
19459       END
19460
19461 *$ CREATE DT_EBIND.FOR
19462 *COPY DT_EBIND
19463 *
19464 *===ebind==============================================================*
19465 *
19466       DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
19467
19468 ************************************************************************
19469 * Binding energy for nuclei.                                           *
19470 * (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972)                  *
19471 *                 IA        mass number                                *
19472 *                 IZ        atomic number                              *
19473 * This version dated 5.5.95   is updated by S. Roesler.                *
19474 ************************************************************************
19475
19476       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19477       SAVE
19478       PARAMETER ( LINP = 10 ,
19479      &            LOUT = 6 ,
19480      &            LDAT = 9 )
19481       PARAMETER (ZERO=0.0D0)
19482
19483       DATA       A1,       A2,        A3,        A4,      A5
19484      &     / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
19485
19486       IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN
19487          WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0.  ',IA,IZ
19488          DT_EBIND = ZERO
19489          RETURN
19490       ENDIF
19491       AA = IA
19492       DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0)
19493      &        -A4*(IA-2*IZ)**2/AA
19494       IF (MOD(IA,2).EQ.1) THEN
19495          IA5 = 0
19496       ELSEIF (MOD(IZ,2).EQ.1) THEN
19497          IA5 = 1
19498       ELSE
19499          IA5 = -1
19500       ENDIF
19501       DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
19502
19503       RETURN
19504       END
19505
19506 **sr 30.6. routine replaced completely
19507 *$ CREATE DT_ENERGY.FOR
19508 *COPY DT_ENERGY
19509 *                                                                      *
19510 *=== energy ===========================================================*
19511 *                                                                      *
19512       DOUBLE PRECISION FUNCTION DT_ENERGY( A, Z )
19513
19514 C     INCLUDE '(DBLPRC)'
19515 * DBLPRC.ADD
19516       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19517       SAVE
19518 * (original name: GLOBAL)
19519       PARAMETER ( KALGNM = 2 )
19520       PARAMETER ( ANGLGB = 5.0D-16 )
19521       PARAMETER ( ANGLSQ = 2.5D-31 )
19522       PARAMETER ( AXCSSV = 0.2D+16 )
19523       PARAMETER ( ANDRFL = 1.0D-38 )
19524       PARAMETER ( AVRFLW = 1.0D+38 )
19525       PARAMETER ( AINFNT = 1.0D+30 )
19526       PARAMETER ( AZRZRZ = 1.0D-30 )
19527       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
19528       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
19529       PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
19530       PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
19531       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
19532       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
19533       PARAMETER ( CSNNRM = 2.0D-15 )
19534       PARAMETER ( DMXTRN = 1.0D+08 )
19535       PARAMETER ( ZERZER = 0.D+00 )
19536       PARAMETER ( ONEONE = 1.D+00 )
19537       PARAMETER ( TWOTWO = 2.D+00 )
19538       PARAMETER ( THRTHR = 3.D+00 )
19539       PARAMETER ( FOUFOU = 4.D+00 )
19540       PARAMETER ( FIVFIV = 5.D+00 )
19541       PARAMETER ( SIXSIX = 6.D+00 )
19542       PARAMETER ( SEVSEV = 7.D+00 )
19543       PARAMETER ( EIGEIG = 8.D+00 )
19544       PARAMETER ( ANINEN = 9.D+00 )
19545       PARAMETER ( TENTEN = 10.D+00 )
19546       PARAMETER ( HLFHLF = 0.5D+00 )
19547       PARAMETER ( ONETHI = ONEONE / THRTHR )
19548       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
19549       PARAMETER ( ONEFOU = ONEONE / FOUFOU )
19550       PARAMETER ( THRTWO = THRTHR / TWOTWO )
19551       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
19552       PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
19553       PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
19554       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
19555       PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
19556       PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
19557       PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
19558       PARAMETER ( EULERO = 0.577215664901532860606512      D+00 )
19559       PARAMETER ( EULEXP = 1.781072417990197985236504      D+00 )
19560       PARAMETER ( EULLOG =-0.5495393129816448223376619     D+00 )
19561       PARAMETER ( E1M2EU = 0.8569023337737540831433017     D+00 )
19562       PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
19563       PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
19564       PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
19565       PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
19566       PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
19567       PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
19568       PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
19569       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
19570       PARAMETER ( CLIGHT = 2.99792458         D+10 )
19571       PARAMETER ( AVOGAD = 6.0221367          D+23 )
19572       PARAMETER ( BOLTZM = 1.380658           D-23 )
19573       PARAMETER ( AMELGR = 9.1093897          D-28 )
19574       PARAMETER ( PLCKBR = 1.05457266         D-27 )
19575       PARAMETER ( ELCCGS = 4.8032068          D-10 )
19576       PARAMETER ( ELCMKS = 1.60217733         D-19 )
19577       PARAMETER ( AMUGRM = 1.6605402          D-24 )
19578       PARAMETER ( AMMUMU = 0.113428913        D+00 )
19579       PARAMETER ( AMPRMU = 1.007276470        D+00 )
19580       PARAMETER ( AMNEMU = 1.008664904        D+00 )
19581       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
19582       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
19583       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
19584       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
19585       PARAMETER ( PLABRC = 0.197327053        D+00 )
19586       PARAMETER ( AMELCT = 0.51099906         D-03 )
19587       PARAMETER ( AMUGEV = 0.93149432         D+00 )
19588       PARAMETER ( AMMUON = 0.105658389        D+00 )
19589       PARAMETER ( AMPRTN = 0.93827231         D+00 )
19590       PARAMETER ( AMNTRN = 0.93956563         D+00 )
19591       PARAMETER ( AMDEUT = 1.87561339         D+00 )
19592       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
19593      &                   * 1.D-09 )
19594       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
19595       PARAMETER ( BLTZMN = 8.617385           D-14 )
19596       PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
19597       PARAMETER ( GFOHB3 = 1.16639            D-05 )
19598       PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
19599       PARAMETER ( SIN2TW = 0.2319             D+00 )
19600       PARAMETER ( GEVMEV = 1.0                D+03 )
19601       PARAMETER ( EMVGEV = 1.0                D-03 )
19602       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
19603       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
19604       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
19605       LOGICAL LGBIAS, LGBANA
19606       COMMON /FKGLOB/ LGBIAS, LGBANA
19607 C     INCLUDE '(DIMPAR)'
19608 * DIMPAR.ADD
19609       PARAMETER ( MXXRGN = 5000 )
19610       PARAMETER ( MXXMDF = 82   )
19611       PARAMETER ( MXXMDE = 54   )
19612       PARAMETER ( MFSTCK = 1000 )
19613       PARAMETER ( MESTCK = 100  )
19614       PARAMETER ( NALLWP = 39   )
19615       PARAMETER ( NELEMX = 80   )
19616       PARAMETER ( MPDPDX = 8    )
19617       PARAMETER ( ICOMAX = 180  )
19618       PARAMETER ( NSTBIS = 304  )
19619       PARAMETER ( IDMAXP = 220  )
19620       PARAMETER ( IDMXDC = 640  )
19621       PARAMETER ( MKBMX1 = 1    )
19622       PARAMETER ( MKBMX2 = 1    )
19623 C     INCLUDE '(IOUNIT)'
19624 * IOUNIT.ADD
19625       PARAMETER ( LUNIN  =  5 )
19626       PARAMETER ( LUNOUT =  6 )
19627 **sr 19.5. set error output-unit from 15 to 6
19628       PARAMETER ( LUNERR = 6  )
19629       PARAMETER ( LUNBER = 14 )
19630       PARAMETER ( LUNECH =  8 )
19631       PARAMETER ( LUNFLU = 13 )
19632       PARAMETER ( LUNGEO = 16 )
19633       PARAMETER ( LUNPMF = 12 )
19634       PARAMETER ( LUNRAN =  2 )
19635       PARAMETER ( LUNXSC =  9 )
19636       PARAMETER ( LUNDET = 17 )
19637       PARAMETER ( LUNRAY = 10 )
19638       PARAMETER ( LUNRDB =  1 )
19639       PARAMETER ( LUNPGO =  7 )
19640       PARAMETER ( LUNPGS =  4 )
19641       PARAMETER ( LUNSCR =  3 )
19642 *
19643 *----------------------------------------------------------------------*
19644 *                                                                      *
19645 *     Revised version of the original routine from EVAP:               *
19646 *                                                                      *
19647 *     Created on   15 may 1990     by    Alfredo Ferrari & Paola Sala  *
19648 *                                                   Infn - Milan       *
19649 *                                                                      *
19650 *     Last change on 19-sep-95     by    Alfredo Ferrari               *
19651 *                                                                      *
19652 *     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!     *
19653 *     !!!  It is supposed to be used with the updated atomic   !!!     *
19654 *     !!!                    mass data file                    !!!     *
19655 *     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!     *
19656 *                                                                      *
19657 *----------------------------------------------------------------------*
19658 *
19659 *  Mass number below which "unknown" isotopes out of the Z-interval
19660 *  reported in the mass tabulations are completely unstable and made
19661 *  up by Z proton masses + N neutron masses:
19662       PARAMETER ( KAFREE =  4 )
19663 *  Mass number below which "unknown" isotopes out of the Z-interval
19664 *  reported in the mass tabulations are supposed to be particle unstable
19665       PARAMETER ( KAPUNS = 12 )
19666 *  Minimum energy required for particle unstable isotopes
19667       PARAMETER ( DEPUNS = 0.5D+00 )
19668 *
19669 * (original name: EVA0)
19670       COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
19671      *                FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
19672      *                CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
19673      *                T (4,7), RMASS (297), ALPH (297), BET (297),
19674      *                APRIME (250), IA (6), IZ (6)
19675 * (original name: ISOTOP)
19676       PARAMETER ( NAMSMX = 270 )
19677       PARAMETER ( NZGVAX =  15 )
19678       PARAMETER ( NISMMX = 574 )
19679       COMMON /FKISOT/ WAPS   (NAMSMX,NZGVAX),  T12NUC (NAMSMX,NZGVAX),
19680      &                WAPISM (NISMMX), T12ISM (NISMMX),
19681      &                ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
19682      &                AMSSST (100)  , ISOMNM (NSTBIS), ISONDX (2,100),
19683      &                JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
19684      &                INWAPS (NAMSMX), JSPISM (NISMMX),
19685      &                JPTISM (NISMMX), IZWISM (NISMMX),
19686      &                INWISM (0:NAMSMX)
19687 *
19688 CPH      SAVE KA0, KZ0, IZ0
19689       DATA KA0, KZ0, IZ0 / -1, -1, -1 /
19690 *
19691       IFLAG = 1
19692       GO TO 10
19693 *======================================================================*
19694 *                                                                      *
19695 *     Entry ENergy - KNOWn                                             *
19696 *                                                                      *
19697 *======================================================================*
19698       ENTRY DT_ENKNOW ( A, Z, IZZ0 )
19699       IZZ0  =-1
19700       IFLAG = 2
19701    10 CONTINUE
19702 *
19703       KA0 = NINT ( A )
19704       KZ0 = NINT ( Z )
19705       N   = KA0 - KZ0
19706 *  +-------------------------------------------------------------------*
19707 *  |  Null residual nucleus:
19708       IF ( KA0 .EQ. 0 .AND. KZ0 .LE. 0 ) THEN
19709          IF ( IFLAG .EQ. 1 ) THEN
19710             DT_ENERGY = ZERZER
19711          ELSE
19712             DT_ENKNOW = ZERZER
19713             IZZ0   = -1
19714          END IF
19715          RETURN
19716 *  |
19717 *  +-------------------------------------------------------------------*
19718 *  |  Only protons:
19719       ELSE IF ( N .LE. 0 ) THEN
19720          IF ( N .LT. 0 ) THEN
19721             WRITE ( LUNOUT, * )
19722      &     ' DPMJET stopped in energy: mass number =< atomic number !!',
19723      &       KA0, KZ0
19724             WRITE ( LUNOUT, * )
19725      &     ' DPMJET stopped in energy: mass number =< atomic number !!',
19726      &       KA0, KZ0
19727                WRITE ( 77, * )
19728      &  ' ^^^DPMJET stopped in energy: mass number =< atomic number !!',
19729      &       KA0, KZ0
19730             STOP 'DT_ENERGY:KA0-KZ0'
19731          END IF
19732          IZ0    = -1
19733          IF ( IFLAG .EQ. 1 ) THEN
19734             DT_ENERGY = Z * WAPS ( 1, 2 )
19735          ELSE
19736             DT_ENKNOW = Z * WAPS ( 1, 2 )
19737             IZZ0   = -1
19738          END IF
19739          RETURN
19740 *  |
19741 *  +-------------------------------------------------------------------*
19742 *  |  Only neutrons:
19743       ELSE IF ( KZ0 .LE. 0 ) THEN
19744          IF ( KZ0 .LT. 0 ) THEN
19745             WRITE ( LUNOUT, * )
19746      &   ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19747             WRITE ( LUNOUT, * )
19748      &   ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19749             WRITE ( 77, * )
19750      &' ^^^DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19751             STOP 'DT_ENERGY:KZ0<0'
19752          END IF
19753          IZ0    = -1
19754          IF ( IFLAG .EQ. 1 ) THEN
19755             DT_ENERGY = A * WAPS ( 1, 1 )
19756          ELSE
19757             DT_ENKNOW = A * WAPS ( 1, 1 )
19758             IZZ0   = -1
19759          END IF
19760          RETURN
19761       END IF
19762 *  |
19763 *  +-------------------------------------------------------------------*
19764 *  +-------------------------------------------------------------------*
19765 *  |  No actual nucleus
19766 *  |
19767 *  +-------------------------------------------------------------------*
19768 *  +-------------------------------------------------------------------*
19769 *  |  A larger than maximum allowed:
19770       IF ( KA0 .GT. NAMSMX ) THEN
19771          IZ0    = -1
19772          IF ( IFLAG .EQ. 1 ) THEN
19773             DT_ENERGY = DT_ENRG( A, Z )
19774          ELSE
19775             DT_ENKNOW = DT_ENRG( A, Z )
19776             IZZ0   = -1
19777          END IF
19778          RETURN
19779       END IF
19780 *  |
19781 *  +-------------------------------------------------------------------*
19782       IZZ = INWAPS ( KA0 )
19783 *  +-------------------------------------------------------------------*
19784 *  |  Too much neutron rich with respect to the stability line:
19785       IF ( KZ0 .LT. IZZ ) THEN
19786 *  |  +----------------------------------------------------------------*
19787 *  |  |  Up to A=Kafree all "bound" masses are known, set it unbound:
19788          IF ( KA0 .LE. KAFREE ) THEN
19789             DT_ENERGY = AINFNT
19790 *  |  |
19791 *  |  +----------------------------------------------------------------*
19792 *  |  |  Up to Kapuns: be sure it is particle unstable
19793          ELSE IF ( KA0 .LE. KAPUNS ) THEN
19794 *  |  |  Exp. excess mass for A,IZZ
19795             ENEEXP = WAPS ( KA0, 1 )
19796 *  |  |  Cameron excess mass for A, IZZ
19797             ENECA1 = DT_ENRG( A, DBLE (IZZ) )
19798 *  |  |  Cameron excess mass for A, Z
19799             DT_ENERGY = DT_ENRG( A, Z )
19800 *  |  |  Use just the difference according to Cameron!!!
19801             DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19802             JZZ    = INWAPS ( KA0 - 1 )
19803             LZZ    = INWAPS ( KA0 - 2 )
19804 *  |  |  +-------------------------------------------------------------*
19805 *  |  |  |  Residual mass for n-decay known:
19806             IF ( KZ0 .GE. JZZ .AND. KZ0 .LE. JZZ + NZGVAX - 1 ) THEN
19807                IZ0    = KZ0 - JZZ + 1
19808                DT_ENERGY = MAX(DT_ENERGY,WAPS (KA0-1,IZ0) + WAPS (1,1)
19809      &                      + DEPUNS )
19810 *  |  |  |
19811 *  |  |  +-------------------------------------------------------------*
19812 *  |  |  |  Residual mass for 2n-decay known:
19813             ELSE IF ( KZ0 .GE. LZZ .AND. KZ0 .LE. LZZ + NZGVAX - 1 )THEN
19814                IZ0    = KZ0 - LZZ + 1
19815                DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO *
19816      &                      ( WAPS (1,1) + DEPUNS ) )
19817 *  |  |  |
19818 *  |  |  +-------------------------------------------------------------*
19819 *  |  |  |  Set it unbound:
19820             ELSE
19821                DT_ENERGY = AINFNT
19822             END IF
19823 *  |  |  |
19824 *  |  |  +-------------------------------------------------------------*
19825 *  |  |
19826 *  |  +----------------------------------------------------------------*
19827 *  |  |  Proceed as usual:
19828          ELSE
19829 *  |  |  Exp. excess mass for A,IZZ
19830             ENEEXP = WAPS ( KA0, 1 )
19831 *  |  |  Cameron excess mass for A, IZZ
19832             ENECA1 = DT_ENRG( A, DBLE (IZZ) )
19833 *  |  |  Cameron excess mass for A, Z
19834             DT_ENERGY = DT_ENRG( A, Z )
19835 *  |  |  Use just the difference according to Cameron!!!
19836             DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19837          END IF
19838 *  |  |
19839 *  |  +----------------------------------------------------------------*
19840 *  |  Be sure not to have a positive energy state:
19841          DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) )
19842          IZ0    = -1
19843          IF ( IFLAG .EQ. 2 ) THEN
19844             DT_ENKNOW = DT_ENERGY
19845             IZZ0   = -1
19846          END IF
19847          RETURN
19848 *  |
19849 *  +-------------------------------------------------------------------*
19850 *  |  Too much proton rich with respect to the stability line:
19851       ELSE IF ( KZ0 .GT. IZZ + NZGVAX - 1 ) THEN
19852 *  |  +----------------------------------------------------------------*
19853 *  |  |  Up to A=Kafree all "bound" masses are known, set it unbound:
19854          IF ( KA0 .LE. KAFREE ) THEN
19855             DT_ENERGY = AINFNT
19856 *  |  |
19857 *  |  +----------------------------------------------------------------*
19858 *  |  |  Up to Kapuns: be sure it is particle unstable
19859          ELSE IF ( KA0 .LE. KAPUNS ) THEN
19860 *  |  |  Exp. excess mass for A,IZZ+NZGVAX-1
19861             ENEEXP = WAPS ( KA0, NZGVAX )
19862 *  |  |  Cameron excess mass for A, IZZ+NZGVAX-1
19863             ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) )
19864 *  |  |  Cameron excess mass for A, Z
19865             DT_ENERGY = DT_ENRG( A, Z )
19866 *  |  |  Use just the difference according to Cameron!!!
19867             DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19868             JZZ    = INWAPS ( KA0 - 1 )
19869             LZZ    = INWAPS ( KA0 - 2 )
19870 *  |  |  +-------------------------------------------------------------*
19871 *  |  |  |  Residual mass for p-decay known:
19872             IF ( KZ0-1 .GE. JZZ .AND. KZ0-1 .LE. JZZ + NZGVAX - 1 ) THEN
19873                IZ0    = KZ0 - 1 - JZZ + 1
19874                DT_ENERGY = MAX (DT_ENERGY, WAPS (KA0-1,IZ0) + WAPS (1,2)
19875      &                      + DEPUNS )
19876 *  |  |  |
19877 *  |  |  +-------------------------------------------------------------*
19878 *  |  |  |  Residual mass for 2p-decay known:
19879             ELSE IF ( KZ0-2 .GE. LZZ .AND. KZ0-2 .LE. LZZ + NZGVAX - 1 )
19880      &         THEN
19881                IZ0    = KZ0 - 2 - LZZ + 1
19882                DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO *
19883      &                      ( WAPS (1,2) + DEPUNS ) )
19884 *  |  |  |
19885 *  |  |  +-------------------------------------------------------------*
19886 *  |  |  |  Set it unbound:
19887             ELSE
19888                DT_ENERGY = AINFNT
19889             END IF
19890 *  |  |  |
19891 *  |  |  +-------------------------------------------------------------*
19892 *  |  |
19893 *  |  +----------------------------------------------------------------*
19894 *  |  |  Proceed as usual:
19895          ELSE
19896 *  |  |  Exp. excess mass for A,IZZ+NZGVAX-1
19897             ENEEXP = WAPS ( KA0, NZGVAX )
19898 *  |  |  Cameron excess mass for A, IZZ+NZGVAX-1
19899             ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) )
19900 *  |  |  Cameron excess mass for A, Z
19901             DT_ENERGY = DT_ENRG( A, Z )
19902 *  |  |  Use just the difference according to Cameron!!!
19903             DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19904          END IF
19905 *  |  |
19906 *  |  +----------------------------------------------------------------*
19907 *  |  Be sure not to have a positive energy state:
19908          DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) )
19909          IZ0    = -1
19910          IF ( IFLAG .EQ. 2 ) THEN
19911             DT_ENKNOW = DT_ENERGY
19912             IZZ0   = -1
19913          END IF
19914          RETURN
19915 *  |
19916 *  +-------------------------------------------------------------------*
19917 *  |  Known isotope or anyway isotope "inside" the stability zone
19918       ELSE
19919          IZ0    = KZ0 - IZZ + 1
19920          DT_ENERGY = WAPS ( KA0, IZ0 )
19921          IF ( IFLAG .EQ. 2 ) IZZ0 = IZ0
19922 *  |  +----------------------------------------------------------------*
19923 *  |  |  Mass not known
19924          IF ( ABS (DT_ENERGY) .LT. ANGLGB .AND. (KA0 .NE. 12 .OR. KZ0
19925      &        .NE. 6) ) THEN
19926             IF ( IFLAG .EQ. 2 ) IZZ0 = -1
19927 *  |  |  +-------------------------------------------------------------*
19928 *  |  |  |  Set it unbound:
19929             IF ( KA0 .LE. KAFREE ) THEN
19930                DT_ENERGY = AINFNT
19931 *  |  |  |
19932 *  |  |  +-------------------------------------------------------------*
19933 *  |  |  |  Try to get a reasonable excess mass:
19934             ELSE
19935                JZ0 = -100
19936 *  |  |  |  +----------------------------------------------------------*
19937 *  |  |  |  |  Check the closest one known:
19938                DO 500 JZZ = 1, NZGVAX
19939                   IF ( ABS ( WAPS (KA0,JZZ) ) .GT. ANGLGB .AND.
19940      &                 ABS (JZZ-IZ0) .LT. ABS (JZ0-IZ0) ) JZ0 = JZZ
19941                   IF ( ABS (JZ0-IZ0) .EQ. 1 ) GO TO 550
19942   500          CONTINUE
19943 *  |  |  |  |
19944 *  |  |  |  +----------------------------------------------------------*
19945   550          CONTINUE
19946 *  |  |  |  Exp. excess mass for A,IZZ+JZ0-1
19947                ENEEXP = WAPS ( KA0, JZ0 )
19948 *  |  |  |  Cameron excess mass for A, IZZ+JZ0-1
19949                ENECA1 = DT_ENRG( A, DBLE (IZZ+JZ0-1) )
19950 *  |  |  |  Cameron excess mass for A, Z
19951                DT_ENERGY = DT_ENRG( A, Z )
19952 *  |  |  |  Use just the difference according to Cameron!!!
19953                DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19954                IZ0    = -1
19955             END IF
19956 *  |  |  |
19957 *  |  |  +-------------------------------------------------------------*
19958 *  |  |  Be sure not to have a positive energy state:
19959             DT_ENERGY = MIN(DT_ENERGY,(A-Z)*WAPS(1,1)+Z*WAPS (1,2) )
19960          END IF
19961 *  |  |
19962 *  |  +----------------------------------------------------------------*
19963          IF ( IFLAG .EQ. 2 ) DT_ENKNOW = DT_ENERGY
19964          RETURN
19965       END IF
19966 *  |
19967 *  +-------------------------------------------------------------------*
19968 *=== End of Function Energy ===========================================*
19969 *     RETURN
19970       END
19971 **
19972
19973 *$ CREATE DT_ENRG.FOR
19974 *COPY DT_ENRG
19975 *                                                                      *
19976 *=== enrg =============================================================*
19977 *                                                                      *
19978       DOUBLE PRECISION FUNCTION DT_ENRG(A,Z)
19979
19980       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19981       SAVE
19982
19983       PARAMETER ( ZERZER = 0.D+00 )
19984       PARAMETER ( ONEONE = 1.D+00 )
19985       PARAMETER ( LUNIN  = 5  )
19986       PARAMETER ( LUNOUT = 6  )
19987 *
19988 *----------------------------------------------------------------------*
19989 *                                                                      *
19990 *     Revised version of the original routine from EVAP:               *
19991 *                                                                      *
19992 *     Created on   15 may 1990     by    Alfredo Ferrari & Paola Sala  *
19993 *                                                   Infn - Milan       *
19994 *                                                                      *
19995 *     Last change on 01-oct-94     by    Alfredo Ferrari               *
19996 *                                                                      *
19997 *     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!     *
19998 *     !!!  It is supposed to be used with the updated atomic   !!!     *
19999 *     !!!                    mass data file                    !!!     *
20000 *     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!     *
20001 *                                                                      *
20002 *----------------------------------------------------------------------*
20003 *
20004       PARAMETER ( O16OLD = 931.145  D+00 )
20005       PARAMETER ( O16NEW = 931.19826D+00 )
20006       PARAMETER ( O16RAT = O16NEW / O16OLD )
20007       PARAMETER ( C12NEW = 931.49432D+00 )
20008       PARAMETER ( ADJUST = -8.322737768178909D-02 )
20009       PARAMETER ( AINFNT = 1.0D+30 )
20010 * (original name: EVA0)
20011       COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
20012      *                FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
20013      *                CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
20014      *                T (4,7), RMASS (297), ALPH (297), BET (297),
20015      *                APRIME (250), IA (6), IZ (6)
20016       LOGICAL LFIRST
20017 CPH      SAVE LFIRST, EXHYDR, EXNEUT
20018       DATA LFIRST / .TRUE. /
20019 *
20020       IF ( LFIRST ) THEN
20021          LFIRST = .FALSE.
20022 **sr 30.6.
20023 C        EXHYDR = DT_ENERGY( ONEONE, ONEONE )
20024 C        EXNEUT = DT_ENERGY( ONEONE, ZERZER )
20025          EXHYDR = A
20026          EXNEUT = Z
20027          DT_ENRG   = -AINFNT
20028          RETURN
20029 **
20030       END IF
20031       IZ0 = NINT (Z)
20032       IF ( IZ0 .LE. 0 ) THEN
20033          DT_ENRG = A * EXNEUT
20034          RETURN
20035       END IF
20036       N   = NINT (A-Z)
20037       IF ( N .LE. 0 ) THEN
20038          DT_ENRG = Z * EXHYDR
20039          RETURN
20040       END IF
20041       AM2ZOA= (A-Z-Z)/A
20042       AM2ZOA=AM2ZOA*AM2ZOA
20043       A13 = RMASS(NINT(A))
20044 *     A13 = A**.3333333333333333D+00
20045       AM13 = 1.D+00/A13
20046       EV=-17.0354D+00*(1.D+00 -1.84619 D+00*AM2ZOA)*A
20047       ES= 25.8357D+00*(1.D+00 -1.712185D+00*AM2ZOA)*
20048      &    (1.D+00 -0.62025D+00*AM13*AM13)*
20049      &    (A13*A13 -.62025D+00)
20050       EC= 0.799D+00*Z*(Z-1.D+00)*AM13*(((1.5772D+00*AM13 +1.2273D+00)*
20051      &    AM13-1.5849D+00)*
20052      &    AM13*AM13 +1.D+00)
20053       EEX= -0.4323D+00*AM13*Z**1.3333333D+00*
20054      &   (((0.49597D+00*AM13 -0.14518D+00)*AM13 -0.57811D+00) * AM13
20055      &   + 1.D+00)
20056       DT_ENRG=8.367D+00*A-0.783D+00*Z +EV +ES +EC +EEX+CAM2(IZ0)+CAM3(N)
20057       DT_ENRG=(DT_ENRG + A * O16OLD ) * O16RAT - A * ( C12NEW - ADJUST )
20058       DT_ENRG  = MIN ( DT_ENRG, Z * EXHYDR + ( A - Z ) * EXNEUT )
20059       RETURN
20060 *=== End of function Enrg =============================================*
20061       END
20062
20063 *$ CREATE DT_INCINI.FOR
20064 *COPY DT_INCINI
20065 *                                                                      *
20066 *=== incini ===========================================================*
20067 *                                                                      *
20068       SUBROUTINE DT_INCINI
20069
20070       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20071       SAVE
20072
20073       PARAMETER ( ZERZER = 0.D+00 )
20074       PARAMETER ( ONEONE = 1.D+00 )
20075       PARAMETER ( TWOTWO = 2.D+00 )
20076       PARAMETER ( THRTHR = 3.D+00 )
20077       PARAMETER ( FOUFOU = 4.D+00 )
20078       PARAMETER ( EIGEIG = 8.D+00 )
20079       PARAMETER ( ANINEN = 9.D+00 )
20080       PARAMETER ( HLFHLF = 0.5D+00 )
20081       PARAMETER ( ONETHI = ONEONE / THRTHR )
20082       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20083       PARAMETER ( PLABRC = 0.197327053        D+00 )
20084       PARAMETER ( AMELCT = 0.51099906         D-03 )
20085       PARAMETER ( AMUGEV = 0.93149432         D+00 )
20086       PARAMETER ( AMPRTN = 0.93827231         D+00 )
20087       PARAMETER ( AMNTRN = 0.93956563         D+00 )
20088       PARAMETER ( AMDEUT = 1.87561339         D+00 )
20089       PARAMETER ( EMVGEV = 1.0                D-03 )
20090
20091       PARAMETER ( LUNOUT = 6  )
20092 *
20093 *----------------------------------------------------------------------*
20094 *                                                                      *
20095 *     Created on  10  june  1990   by    Alfredo Ferrari & Paola Sala  *
20096 *                                                   Infn - Milan       *
20097 *                                                                      *
20098 *     Last change on 02-may-95     by    Alfredo Ferrari               *
20099 *                                                                      *
20100 *                                                                      *
20101 *----------------------------------------------------------------------*
20102 *
20103 * (original name: FHEAVY,FHEAVC)
20104       PARAMETER ( MXHEAV = 100 )
20105       CHARACTER*8 ANHEAV
20106       COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
20107      &                CZHEAV (MXHEAV), TKHEAV (MXHEAV),
20108      &                PHEAVY (MXHEAV), WHEAVY (MXHEAV),
20109      &                AMHEAV  ( 12 ) , AMNHEA  ( 12 ) ,
20110      &                KHEAVY (MXHEAV), ICHEAV  ( 12 ) ,
20111      &                IBHEAV  ( 12 ) , NPHEAV
20112       COMMON /FKFHVC/ ANHEAV  ( 12 )
20113 * (original name: INPFLG)
20114       COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
20115 * (original name: FRBKCM)
20116       PARAMETER ( MXFFBK =     6 )
20117       PARAMETER ( MXZFBK =     9 )
20118       PARAMETER ( MXNFBK =    10 )
20119       PARAMETER ( MXAFBK =    16 )
20120       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
20121       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
20122       PARAMETER ( NXAFBK = MXAFBK + 1 )
20123       PARAMETER ( MXPSST =   300 )
20124       PARAMETER ( MXPSFB = 41000 )
20125       LOGICAL LFRMBK, LNCMSS
20126       COMMON /FKFRBK/  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
20127      &          EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
20128      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
20129      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
20130      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
20131      &          IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
20132      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
20133      &          IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
20134      &          IFBFRB, NBUFBK, LFRMBK, LNCMSS
20135 * (original name: NUCDAT)
20136       PARAMETER ( AMUAMU = AMUGEV )
20137       PARAMETER ( AMPROT = AMPRTN )
20138       PARAMETER ( AMNEUT = AMNTRN )
20139       PARAMETER ( AMELEC = AMELCT )
20140       PARAMETER ( R0NUCL = 1.12        D+00 )
20141       PARAMETER ( RCCOUL = 1.7         D+00 )
20142       PARAMETER ( FERTHO = 14.33       D-09 )
20143       PARAMETER ( EXPEBN = 2.39        D+00 )
20144       PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
20145       PARAMETER ( AMUC12 = AMUGEV - HLFHLF * AMELCT + BEXC12 / 12.D+00 )
20146       PARAMETER ( AMHYDR = AMPRTN + AMELCT  )
20147       PARAMETER ( AMHTON = AMHYDR - AMNTRN  )
20148       PARAMETER ( AMNTOU = AMNTRN - AMUC12  )
20149       PARAMETER ( AMUCSQ = AMUC12 * AMUC12 )
20150       PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 )
20151       PARAMETER ( GAMMIN = 1.0D-06 )
20152       PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN )
20153       PARAMETER ( TVEPSI = GAMMIN / 100.D+00 )
20154       COMMON /FKNDAT/ AV0WEL,     APFRMX,     AEFRMX,     AEFRMA,
20155      &                RDSNUC,     V0WELL (2), PFRMMX (2), EFRMMX (2),
20156      &                EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
20157      &                VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
20158      &                PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
20159      &                EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
20160      &                ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV    ,
20161      &                AMRCSQ    , ATO1O3    , ZTO1O3    , ELBNDE (0:100)
20162 * (original name: PAREVT)
20163       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
20164      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
20165       PARAMETER ( NALLWP = 39   )
20166       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
20167      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
20168      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
20169      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
20170 * (original name: NUCOLD)
20171       COMMON /FKNOLD/ HELP (2), HHLP (2), FTVTH (2), FINCX (2),
20172      &                EKPOLD (2), BBOLD, ZZOLD, SQROLD, ASEASQ,
20173      &                FSPRED, FEX0RD
20174 *
20175       BBOLD  = - 1.D+10
20176       ZZOLD  = - 1.D+10
20177       SQROLD = - 1.D+10
20178       APFRMX = PLABRC * ( ANINEN * PIPIPI / EIGEIG )**ONETHI / R0NUCL
20179       AMNUCL (1) = AMPROT
20180       AMNUCL (2) = AMNEUT
20181       AMNUSQ (1) = AMPROT * AMPROT
20182       AMNUSQ (2) = AMNEUT * AMNEUT
20183       AMNHLP = HLFHLF * ( AMNUCL (1) + AMNUCL (2) )
20184       ASQHLP = AMNHLP**2
20185 *     ASQHLP = HLFHLF * ( AMNUSQ (1) + AMNUSQ (2) )
20186       AEFRMX = SQRT ( ASQHLP + APFRMX**2 ) - AMNHLP
20187       AEFRMA = 0.3D+00 * APFRMX**2 / AMNHLP * ( ONEONE - APFRMX**2 /
20188      &         ( 5.6D+00 * ASQHLP ) )
20189       AV0WEL = AEFRMX + EBNDAV
20190       EBNDNG (1) = EBNDAV
20191       EBNDNG (2) = EBNDAV
20192       AEXC12 = EMVGEV * DT_ENERGY( 12.D+00, 6.D+00 )
20193       CEXC12 = EMVGEV * DT_ENRG( 12.D+00, 6.D+00 )
20194       AMMC12 = 12.D+00 * AMUGEV + AEXC12
20195       AMNC12 = AMMC12 - 6.D+00 * AMELCT + FERTHO * 6.D+00**EXPEBN
20196       AEXO16 = EMVGEV * DT_ENERGY( 16.D+00, 8.D+00 )
20197       CEXO16 = EMVGEV * DT_ENRG( 16.D+00, 8.D+00 )
20198       AMMO16 = 16.D+00 * AMUGEV + AEXO16
20199       AMNO16 = AMMO16 - 8.D+00 * AMELCT + FERTHO * 8.D+00**EXPEBN
20200       AEXS28 = EMVGEV * DT_ENERGY( 28.D+00, 14.D+00 )
20201       CEXS28 = EMVGEV * DT_ENRG( 28.D+00, 14.D+00 )
20202       AMMS28 = 28.D+00 * AMUGEV + AEXS28
20203       AMNS28 = AMMS28 - 14.D+00 * AMELCT + FERTHO * 14.D+00**EXPEBN
20204       AEXC40 = EMVGEV * DT_ENERGY( 40.D+00, 20.D+00 )
20205       CEXC40 = EMVGEV * DT_ENRG( 40.D+00, 20.D+00 )
20206       AMMC40 = 40.D+00 * AMUGEV + AEXC40
20207       AMNC40 = AMMC40 - 20.D+00 * AMELCT + FERTHO * 20.D+00**EXPEBN
20208       AEXF56 = EMVGEV * DT_ENERGY( 56.D+00, 26.D+00 )
20209       CEXF56 = EMVGEV * DT_ENRG( 56.D+00, 26.D+00 )
20210       AMMF56 = 56.D+00 * AMUGEV + AEXF56
20211       AMNF56 = AMMF56 - 26.D+00 * AMELCT + FERTHO * 26.D+00**EXPEBN
20212       AEX107 = EMVGEV * DT_ENERGY( 107.D+00, 47.D+00 )
20213       CEX107 = EMVGEV * DT_ENRG( 107.D+00, 47.D+00 )
20214       AMM107 = 107.D+00 * AMUGEV + AEX107
20215       AMN107 = AMM107 - 47.D+00 * AMELCT + FERTHO * 47.D+00**EXPEBN
20216       AEX132 = EMVGEV * DT_ENERGY( 132.D+00, 54.D+00 )
20217       CEX132 = EMVGEV * DT_ENRG( 132.D+00, 54.D+00 )
20218       AMM132 = 132.D+00 * AMUGEV + AEX132
20219       AMN132 = AMM132 - 54.D+00 * AMELCT + FERTHO * 54.D+00**EXPEBN
20220       AEX181 = EMVGEV * DT_ENERGY( 181.D+00, 73.D+00 )
20221       CEX181 = EMVGEV * DT_ENRG( 181.D+00, 73.D+00 )
20222       AMM181 = 181.D+00 * AMUGEV + AEX181
20223       AMN181 = AMM181 - 73.D+00 * AMELCT + FERTHO * 73.D+00**EXPEBN
20224       AEX208 = EMVGEV * DT_ENERGY( 208.D+00, 82.D+00 )
20225       CEX208 = EMVGEV * DT_ENRG( 208.D+00, 82.D+00 )
20226       AMM208 = 208.D+00 * AMUGEV + AEX208
20227       AMN208 = AMM208 - 82.D+00 * AMELCT + FERTHO * 82.D+00**EXPEBN
20228       AEX238 = EMVGEV * DT_ENERGY( 238.D+00, 92.D+00 )
20229       CEX238 = EMVGEV * DT_ENRG( 238.D+00, 92.D+00 )
20230       AMM238 = 238.D+00 * AMUGEV + AEX238
20231       AMN238 = AMM238 - 92.D+00 * AMELCT + FERTHO * 92.D+00**EXPEBN
20232
20233       AMHEAV (1) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ZERZER )
20234       AMHEAV (2) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ONEONE )
20235       AMHEAV (3) = TWOTWO * AMUGEV
20236      &             + EMVGEV * DT_ENERGY( TWOTWO, ONEONE )
20237       AMHEAV (4) = THRTHR * AMUGEV
20238      &             + EMVGEV * DT_ENERGY( THRTHR, ONEONE )
20239       AMHEAV (5) = THRTHR * AMUGEV
20240      &             + EMVGEV * DT_ENERGY( THRTHR, TWOTWO )
20241       AMHEAV (6) = FOUFOU * AMUGEV
20242      &             + EMVGEV * DT_ENERGY( FOUFOU, TWOTWO )
20243       ELBNDE (0) = ZERZER
20244       ELBNDE (1) = 13.6D-09
20245       DO 2000 IZ = 2, 100
20246          ELBNDE ( IZ ) = FERTHO * DBLE ( IZ )**EXPEBN
20247 2000  CONTINUE
20248       AMNHEA (1) = AMHEAV (1) + ELBNDE (0)
20249       AMNHEA (2) = AMHEAV (2) - AMELCT + ELBNDE (1)
20250       AMNHEA (3) = AMHEAV (3) - AMELCT + ELBNDE (1)
20251       AMNHEA (4) = AMHEAV (4) - AMELCT + ELBNDE (1)
20252       AMNHEA (5) = AMHEAV (5) - TWOTWO * AMELCT + ELBNDE (2)
20253       AMNHEA (6) = AMHEAV (6) - TWOTWO * AMELCT + ELBNDE (2)
20254       IF ( LEVPRT ) THEN
20255          WRITE ( LUNOUT, * )' **** Evaporation from residual nucleus',
20256      &                      ' activated **** '
20257          IF ( LDEEXG ) WRITE ( LUNOUT, * )' **** Deexcitation gamma',
20258      &                      ' production activated **** '
20259 **sr 18.5.95
20260 * commented, since obsolete
20261 C        IF ( LHEAVY ) WRITE ( LUNOUT, * )' **** Evaporated "heavies"',
20262 C    &                      ' transport activated **** '
20263          IF ( IFISS .GT. 0 )
20264      &                 WRITE ( LUNOUT, * )' **** High Energy fission ',
20265      &                      ' requested & activated **** '
20266          IF ( LFRMBK )
20267      &                 WRITE ( LUNOUT, * )' **** Fermi Break Up ',
20268      &                      ' requested & activated **** '
20269          IF ( LFRMBK ) CALL DT_FRBKIN(.FALSE.,.FALSE.)
20270       ELSE
20271          LDEEXG = .FALSE.
20272          LHEAVY = .FALSE.
20273          LFRMBK = .FALSE.
20274          IFISS  = 0
20275       END IF
20276       RETURN
20277 *=== End of subroutine incini =========================================*
20278       END
20279
20280 *$ CREATE DT_STALIN.FOR
20281 *COPY DT_STALIN
20282 *                                                                      *
20283 *=== stalin ===========================================================*
20284 *                                                                      *
20285       SUBROUTINE DT_STALIN
20286
20287       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20288       SAVE
20289       PARAMETER ( ANGLGB = 5.0D-16 )
20290       PARAMETER ( ZERZER = 0.D+00 )
20291       PARAMETER ( ONEONE = 1.D+00 )
20292       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20293       PARAMETER ( AMUGEV = 0.93149432         D+00 )
20294       PARAMETER ( EMVGEV = 1.0                D-03 )
20295       PARAMETER ( NSTBIS = 304  )
20296       PARAMETER ( LUNIN  = 5  )
20297       PARAMETER ( LUNOUT = 6  )
20298 *
20299 *----------------------------------------------------------------------*
20300 *                                                                      *
20301 *     STAbility LINe calculation:                                      *
20302 *                                                                      *
20303 *     Created on 04 december 1992  by    Alfredo Ferrari & Paola Sala  *
20304 *                                                   Infn - Milan       *
20305 *                                                                      *
20306 *     Last change on 04-dec-92     by    Alfredo Ferrari               *
20307 *                                                                      *
20308 *                                                                      *
20309 *----------------------------------------------------------------------*
20310 *
20311 * (original name: ISOTOP)
20312       PARAMETER ( NAMSMX = 270 )
20313       PARAMETER ( NZGVAX =  15 )
20314       PARAMETER ( NISMMX = 574 )
20315       COMMON /FKISOT/ WAPS   (NAMSMX,NZGVAX),  T12NUC (NAMSMX,NZGVAX),
20316      &                WAPISM (NISMMX), T12ISM (NISMMX),
20317      &                ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
20318      &                AMSSST (100)  , ISOMNM (NSTBIS), ISONDX (2,100),
20319      &                JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
20320      &                INWAPS (NAMSMX), JSPISM (NISMMX),
20321      &                JPTISM (NISMMX), IZWISM (NISMMX),
20322      &                INWISM (0:NAMSMX)
20323 *
20324       DIMENSION ZNORM (260)
20325 *  +-------------------------------------------------------------------*
20326 *  |
20327       DO 1000 IZ=1,100
20328          DO 500 J=1,2
20329             ASTLIN (J,IZ) = ZERZER
20330   500    CONTINUE
20331  1000 CONTINUE
20332 *  |
20333 *  +-------------------------------------------------------------------*
20334 *  +-------------------------------------------------------------------*
20335 *  |
20336       DO 2000 IA=1,260
20337          ZNORM (IA) = ZERZER
20338          DO 1500 J=1,2
20339             ZSTLIN (J,IA) = ZERZER
20340  1500    CONTINUE
20341  2000 CONTINUE
20342 *  |
20343 *  +-------------------------------------------------------------------*
20344 *  +-------------------------------------------------------------------*
20345 *  |  Loop on the Atomic Number
20346       DO 3000 IZ=1,100
20347          AMSSST (IZ) = ZERZER
20348          ANORM       = ONEONE
20349          ZTAR        = IZ
20350 *  |  +----------------------------------------------------------------*
20351 *  |  |    Loop on the stable isotopes
20352          DO 2500 IS = ISONDX (1,IZ), ISONDX (2,IZ)
20353             IA = ISOMNM (IS)
20354             ASTLIN (1,IZ) = ASTLIN (1,IZ) + ABUISO (IS) * IA
20355             ASTLIN (2,IZ) = ASTLIN (2,IZ) + ABUISO (IS) * IA**2
20356             ZNORM    (IA) = ZNORM (IA) + ABUISO (IS)
20357             ZSTLIN (1,IA) = ZSTLIN (1,IA) + ABUISO (IS) * IZ
20358             ZSTLIN (2,IA) = ZSTLIN (2,IA) + ABUISO (IS) * IZ**2
20359             AHELP  = IA
20360             IF ( AHELP .LE. 1.00001D+00 ) THEN
20361                ANORM = ONEONE / ( ONEONE - ABUISO (IS) )
20362                GO TO 2500
20363             END IF
20364             AMSSST (IZ) = ABUISO (IS) * ( AHELP * AMUGEV
20365      &                  + EMVGEV * DT_ENERGY(AHELP,ZTAR) ) + AMSSST (IZ)
20366  2500    CONTINUE
20367 *  |  |
20368 *  |  +----------------------------------------------------------------*
20369          AMSSST (IZ) = ANORM * AMSSST (IZ) / AMUGEV
20370 *  |  Normalize and print A_stab versus Z data:
20371          ASTLIN (2,IZ) = MAX ( SQRT (ASTLIN(2,IZ)-ASTLIN(1,IZ)**2),
20372      &                         0.5D+00 )
20373 *        WRITE (LUNOUT,*)'  Z:',IZ,' A_stab:',SNGL(ASTLIN(1,IZ)),
20374 *    &                   '  Sigma_st',SNGL(ASTLIN(2,IZ))
20375  3000 CONTINUE
20376 *  |
20377 *  +-------------------------------------------------------------------*
20378 *  +-------------------------------------------------------------------*
20379 *  |  Normalize and print Z_stab versus A data:
20380       DO 4000 IA=1,260
20381          ZSTLIN (1,IA) = ZSTLIN (1,IA) / MAX ( ZNORM (IA), 1.D-10 )
20382          ZSTLIN (2,IA) = ZSTLIN (2,IA) / MAX ( ZNORM (IA), 1.D-10 )
20383          ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ZSTLIN (1,IA)**2 )
20384          IF ( ZNORM (IA) .GT. ANGLGB )
20385 **sr 2.11. avoid underflows at Pentium
20386      &      ZSTLIN (2,IA) =
20387      &               MAX ( SQRT ( ABS(ZSTLIN(2,IA)-ZSTLIN(1,IA)**2) ),
20388 C    &      ZSTLIN (2,IA) = MAX ( SQRT (ZSTLIN(2,IA)-ZSTLIN(1,IA)**2),
20389      &                            0.3D+00 )
20390  4000 CONTINUE
20391 *  |
20392 *  +-------------------------------------------------------------------*
20393 *  +-------------------------------------------------------------------*
20394 *  |  Normalize and print Z_stab versus A data:
20395       DO 5000 IA=1,260
20396          IF ( ZNORM (IA) .LE. ANGLGB ) THEN
20397             DO 4200 JA = IA-1,1,-1
20398                IF ( ZNORM (JA) .GT. ANGLGB ) THEN
20399                   IA1 = JA
20400                   GO TO 4300
20401                END IF
20402  4200       CONTINUE
20403  4300       CONTINUE
20404             DO 4400 JA = IA+1,260
20405                IF ( ZNORM (JA) .GT. ANGLGB ) THEN
20406                   IA2 = JA
20407                   GO TO 4500
20408                END IF
20409  4400       CONTINUE
20410             IA2 = IA1
20411             IA1 = IA1 - 1
20412  4500       CONTINUE
20413             ZSTLIN (1,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1)
20414      &                    * ( ZSTLIN (1,IA2) - ZSTLIN (1,IA1) )
20415      &                    + ZSTLIN (1,IA1)
20416             ZSTLIN (2,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1)
20417      &                    * ( ZSTLIN (2,IA2) - ZSTLIN (2,IA1) )
20418      &                    + ZSTLIN (2,IA1)
20419          END IF
20420          IZ = MIN ( 100, NINT (ZSTLIN(1,IA)) )
20421          ATOZ = IZ / ASTLIN (1,IZ)
20422          ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ATOZ * ASTLIN (2,IZ) )
20423 *        WRITE (LUNOUT,*)'  A:',IA,' Z_stab:',SNGL(ZSTLIN(1,IA)),
20424 *    &                   '  Sigma_st',SNGL(ZSTLIN(2,IA))
20425  5000 CONTINUE
20426 *  |
20427 *  +-------------------------------------------------------------------*
20428       RETURN
20429       END
20430
20431 *$ CREATE DT_BERTTP.FOR
20432 *COPY DT_BERTTP
20433 *
20434 *=== berttp ===========================================================*
20435 *                                                                      *
20436       SUBROUTINE DT_BERTTP
20437
20438       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20439       SAVE
20440
20441       PARAMETER ( CSNNRM = 2.0D-15 )
20442       PARAMETER ( ZERZER = 0.D+00 )
20443       PARAMETER ( ONEONE = 1.D+00 )
20444       PARAMETER ( THRTHR = 3.D+00 )
20445       PARAMETER ( SIXSIX = 6.D+00 )
20446       PARAMETER ( ONETHI = ONEONE / THRTHR )
20447       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20448       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
20449       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
20450       PARAMETER ( EMVGEV = 1.0                D-03 )
20451
20452       PARAMETER ( NSTBIS = 304  )
20453
20454       PARAMETER ( LUNIN  = 5  )
20455       PARAMETER ( LUNOUT = 6  )
20456 **sr 19.5. set error output-unit from 15 to 6
20457       PARAMETER ( LUNERR = 6  )
20458 C---------------------------------------------------------------------
20459 C SUBNAME = DT_BERTTP --- READ BERTINI DATA
20460 C---------------------------------------------------------------------
20461 C     ---------------------------------- I-N-C DATA
20462 C     COMMON R8(2127),R4(64),CRSC(600,4),R8B(336),CS(29849)
20463 C     REAL*8 R8,R8B,CRSC,CS
20464 C     REAL*4 R4
20465 C     --------------------------------- EVAPORATION DATA
20466 * (original name: COOKCM)
20467       PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 )
20468       LOGICAL LDEFOZ, LDEFON
20469       PARAMETER ( INCOOK = 150, IZCOOK = 98 )
20470       COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN,
20471      &                SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK),
20472      &                PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK)
20473 * (original name: EVA0)
20474       COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
20475      *                FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
20476      *                CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
20477      *                T (4,7), RMASS (297), ALPH (297), BET (297),
20478      *                APRIME (250), IA (6), IZ (6)
20479 * (original name: FRBKCM)
20480       PARAMETER ( MXFFBK =     6 )
20481       PARAMETER ( MXZFBK =     9 )
20482       PARAMETER ( MXNFBK =    10 )
20483       PARAMETER ( MXAFBK =    16 )
20484       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
20485       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
20486       PARAMETER ( NXAFBK = MXAFBK + 1 )
20487       PARAMETER ( MXPSST =   300 )
20488       PARAMETER ( MXPSFB = 41000 )
20489       LOGICAL LFRMBK, LNCMSS
20490       COMMON /FKFRBK/  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
20491      &          EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
20492      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
20493      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
20494      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
20495      &          IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
20496      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
20497      &          IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
20498      &          IFBFRB, NBUFBK, LFRMBK, LNCMSS
20499 * (original name: HETTP)
20500       COMMON /FKHETP/  NHSTP,NBERTP,IOSUB,INSRS
20501 * (original name: INPFLG)
20502       COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
20503 * (original name: ISOTOP)
20504       PARAMETER ( NAMSMX = 270 )
20505       PARAMETER ( NZGVAX =  15 )
20506       PARAMETER ( NISMMX = 574 )
20507       COMMON /FKISOT/ WAPS   (NAMSMX,NZGVAX),  T12NUC (NAMSMX,NZGVAX),
20508      &                WAPISM (NISMMX), T12ISM (NISMMX),
20509      &                ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
20510      &                AMSSST (100)  , ISOMNM (NSTBIS), ISONDX (2,100),
20511      &                JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
20512      &                INWAPS (NAMSMX), JSPISM (NISMMX),
20513      &                JPTISM (NISMMX), IZWISM (NISMMX),
20514      &                INWISM (0:NAMSMX)
20515 * (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII)
20516       PARAMETER ( PI     = PIPIPI )
20517       PARAMETER ( PISQ   = PIPISQ )
20518       PARAMETER ( SKTOHL = 0.5456645846610345D+00 )
20519       PARAMETER ( RZNUCL = 1.12        D+00 )
20520       PARAMETER ( RMSPRO = 0.8         D+00 )
20521       PARAMETER ( R0PROT = RMSPRO / SQRT12  )
20522       PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT
20523      &          / R0PROT )
20524       PARAMETER ( RLLE04 = RZNUCL )
20525       PARAMETER ( RLLE16 = RZNUCL )
20526       PARAMETER ( RLGT16 = RZNUCL )
20527       PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 )
20528       PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 )
20529       PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 )
20530       PARAMETER ( SKLE04 = 1.4D+00 )
20531       PARAMETER ( SKLE16 = 1.9D+00 )
20532       PARAMETER ( SKGT16 = 2.4D+00 )
20533       PARAMETER ( HLLE04 = SKTOHL * SKLE04 )
20534       PARAMETER ( HLLE16 = SKTOHL * SKLE16 )
20535       PARAMETER ( HLGT16 = SKTOHL * SKGT16 )
20536       PARAMETER ( ALPHA0 = 0.1D+00 )
20537       PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 )
20538       PARAMETER ( GAMSK0 = 0.9D+00 )
20539       PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 )
20540       PARAMETER ( POTME0 = 0.6666666666666667D+00 )
20541       PARAMETER ( POTBA0 = 1.D+00 )
20542       PARAMETER ( PNFRAT = 1.533D+00 )
20543       PARAMETER ( RADPIM = 0.035D+00 )
20544       PARAMETER ( RDPMHL = 14.D+00   )
20545       PARAMETER ( APMRST = 4.D+00 / 44.D+00 )
20546       PARAMETER ( APMPRO = 1.D+00 / 6.D+00 )
20547       PARAMETER ( APPPRO = 5.D+00 / 6.D+00 )
20548       PARAMETER ( AP0PFS = 0.5D+00 )
20549       PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 )
20550       PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 )
20551       PARAMETER ( XPAUCO = 1.88495407241652 D+00 )
20552       PARAMETER ( MXSCIN = 50     )
20553       LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY,
20554      &        LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC
20555       COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260),
20556      &                RADTAB (2:260), SKITAB (2:260), HALTAB (2:260),
20557      &                SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260),
20558      &                CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260),
20559      &                PFRTAB (2:260)
20560       COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP,
20561      &                ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO,
20562      &                RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR,
20563      &                YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN,
20564      &                RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM,
20565      &                PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2,
20566      &                PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT,
20567      &                BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2,
20568      &                YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3,
20569      &                XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC,
20570      &                SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ,
20571      &                R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE,
20572      &                PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY,
20573      &                EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ,
20574      &                PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM,
20575      &                EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3,
20576      &                PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM,
20577      &                BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN
20578       COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2),
20579      &                RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN,
20580      &                EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF,
20581      &                BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC,
20582      &                WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES,
20583      &                POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND,
20584      &                BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4),
20585      &                SIGPAB (3), SIGNAB (3), HHLP   (2), FORTOT (2),
20586      &                FPNBLC, DPNBLC, FFTFLG, IFTFLG,
20587      &                IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2,
20588      &                KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3,
20589      &                NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM,
20590      &                IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ,
20591      &                LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC
20592       COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT
20593       COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN),
20594      &                YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN),
20595      &                AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX,
20596      &                NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN),
20597      &                NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN),
20598      &                ISCTYP (0:MXSCIN), NUSCIN, NEXPEM,
20599      &                LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH,
20600      &                LNCDCY, LNUSCT
20601       DIMENSION AWSTAB (2:260), SIGMAB (3)
20602       EQUIVALENCE ( DEFPRO, DEFNUC (1) )
20603       EQUIVALENCE ( DEFNEU, DEFNUC (2) )
20604       EQUIVALENCE ( RHOIPP, RHONCP (1) )
20605       EQUIVALENCE ( RHOINP, RHONCP (2) )
20606       EQUIVALENCE ( RHOIP2, RHONC2 (1) )
20607       EQUIVALENCE ( RHOIN2, RHONC2 (2) )
20608       EQUIVALENCE ( RHOIP3, RHONC3 (1) )
20609       EQUIVALENCE ( RHOIN3, RHONC3 (2) )
20610       EQUIVALENCE ( RHOIPT, RHONCT (1) )
20611       EQUIVALENCE ( RHOINT, RHONCT (2) )
20612       EQUIVALENCE ( OMALHL, SK3PAR )
20613       EQUIVALENCE ( ALPHAL, HABPAR )
20614       EQUIVALENCE ( ALPTAB (2), AWSTAB (2) )
20615       EQUIVALENCE ( SIGMPE, SIGMPR (1) )
20616       EQUIVALENCE ( SIGMPC, SIGMPR (2) )
20617       EQUIVALENCE ( SIGMPI, SIGMPR (3) )
20618       EQUIVALENCE ( SIGMPA, SIGMPR (4) )
20619       EQUIVALENCE ( SIGMNE, SIGMNU (1) )
20620       EQUIVALENCE ( SIGMNC, SIGMNU (2) )
20621       EQUIVALENCE ( SIGMNI, SIGMNU (3) )
20622       EQUIVALENCE ( SIGMNA, SIGMNU (4) )
20623       EQUIVALENCE ( SIGMA2, SIGPAB (1) )
20624       EQUIVALENCE ( SIGMA3, SIGPAB (2) )
20625       EQUIVALENCE ( SIGMAS, SIGPAB (3) )
20626       EQUIVALENCE ( SIGPAB (1), SIGMAB (1) )
20627 * (original name: NUCLEV)
20628       LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL
20629       COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2),
20630      &                DEFMAG (2), ENNCLV (160,2), RANCLV (160,2),
20631      &                CUMRAD (0:160,2), RUSNUC (2),
20632      &                ENPLVL (114), ENNLVL(164), JUSNUC (160,2),
20633      &                NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2),
20634      &                NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2),
20635      &                JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8),
20636      &                MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2),
20637      &                NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL,
20638      &                LFLVSL, LRLVSL, LEQSBL
20639       DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8),
20640      &          MGSSPR (19) , MGSSNE (25)
20641       EQUIVALENCE ( RUSNUC (1), RUSPRO )
20642       EQUIVALENCE ( RUSNUC (2), RUSNEU )
20643       EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) )
20644       EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) )
20645       EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) )
20646       EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) )
20647       EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) )
20648       EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) )
20649       EQUIVALENCE ( NTANUC (1), NTAPRO )
20650       EQUIVALENCE ( NTANUC (2), NTANEU )
20651       EQUIVALENCE ( NAVNUC (1), NAVPRO )
20652       EQUIVALENCE ( NAVNUC (2), NAVNEU )
20653       EQUIVALENCE ( NLSNUC (1), NLSPRO )
20654       EQUIVALENCE ( NLSNUC (2), NLSNEU )
20655       EQUIVALENCE ( NCONUC (1), NCOPRO )
20656       EQUIVALENCE ( NCONUC (2), NCONEU )
20657       EQUIVALENCE ( NSKNUC (1), NSKPRO )
20658       EQUIVALENCE ( NSKNUC (2), NSKNEU )
20659       EQUIVALENCE ( NHANUC (1), NHAPRO )
20660       EQUIVALENCE ( NHANUC (2), NHANEU )
20661       EQUIVALENCE ( NUSNUC (1), NUSPRO )
20662       EQUIVALENCE ( NUSNUC (2), NUSNEU )
20663       EQUIVALENCE ( NACNUC (1), NACPRO )
20664       EQUIVALENCE ( NACNUC (2), NACNEU )
20665       EQUIVALENCE ( JMXNUC (1), JMXPRO )
20666       EQUIVALENCE ( JMXNUC (2), JMXNEU )
20667       EQUIVALENCE ( MAGNUC (1), MAGPRO )
20668       EQUIVALENCE ( MAGNUC (2), MAGNEU )
20669 * (original name: PAREVT)
20670       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
20671      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
20672       PARAMETER ( NALLWP = 39   )
20673       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
20674      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
20675      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
20676      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
20677 * (original name: XSEPAR)
20678       COMMON /FKXSEP/ AANXSE (100), BBNXSE (100), CCNXSE (100),
20679      &                DDNXSE (100), EENXSE (100), ZZNXSE (100),
20680      &                EMNXSE (100), XMNXSE (100),
20681      &                AAPXSE (100), BBPXSE (100), CCPXSE (100),
20682      &                DDPXSE (100), EEPXSE (100), FFPXSE (100),
20683      &                ZZPXSE (100), EMPXSE (100), XMPXSE (100)
20684
20685 C---------------------------------------------------------------------
20686 **sr 17.5.95
20687 * modified for use in DPMJET
20688 C     WRITE( LUNOUT,'(A,I2)')
20689 C    & ' *** Reading evaporation and nuclear data from unit: ', NBERTP
20690 C     REWIND NBERTP
20691       IF (LEVPRT) WRITE(LUNOUT,1000)
20692  1000 FORMAT(/,1X,'BERTTP:',4X,'Initialization of evaporation module',
20693      &       /,12X,'------------------------------------',/)
20694       NBERNW = 23
20695 CPH      OPEN (UNIT=NBERNW,FILE='dpmjet.dat',STATUS='UNKNOWN')
20696
20697 **sr 17.5.
20698 *!!!! changed to be able to read the ASCII !!!!
20699 **
20700 C A. Ferrari: first of all read isotopic data
20701       READ (NBERNW,*) ISONDX
20702       READ (NBERNW,*) ISOMNM
20703       READ (NBERNW,*) ABUISO
20704 C     READ (NBERTP) ISONDX
20705 C     READ (NBERTP) ISOMNM
20706 C     READ (NBERTP) ABUISO
20707       DO 1 I=1,4
20708 C        READ  (NBERTP) (CRSC(J,I),J=1,600)
20709 C A. Ferrari: commented also the dummy read to save disk space
20710 C        READ  (NBERTP)
20711     1 CONTINUE
20712 C     READ  (NBERTP) CS
20713 C A. Ferrari: commented also the dummy read to save disk space
20714 C     READ  (NBERTP)
20715 C---------------------------------------------------------------------
20716       READ (NBERNW,*) (P0(I),P1(I),P2(I),I=1,1001)
20717       READ (NBERNW,*) IA,IZ
20718       DO 2 I=1,6
20719          FLA(I)=IA(I)
20720          FLZ(I)=IZ(I)
20721     2 CONTINUE
20722       READ (NBERNW,*) RHO,OMEGA
20723       READ (NBERNW,*) EXMASS
20724       READ (NBERNW,*) CAM2
20725       READ (NBERNW,*) CAM3
20726       READ (NBERNW,*) CAM4
20727       READ (NBERNW,*) CAM5
20728       READ (NBERNW,*) ((T(I,J),J=1,7),I=1,3)
20729       DO 3 I=1,7
20730          T(4,I) = ZERZER
20731     3 CONTINUE
20732       READ (NBERNW,*) RMASS
20733       READ (NBERNW,*) ALPH
20734       READ (NBERNW,*) BET
20735       READ (NBERNW,*) INWAPS
20736       READ (NBERNW,*) WAPS
20737       READ (NBERNW,*) T12NUC
20738       READ (NBERNW,*) JSPNUC
20739       READ (NBERNW,*) JPTNUC
20740       READ (NBERNW,*) INWISM
20741       READ (NBERNW,*) IZWISM
20742       READ (NBERNW,*) WAPISM
20743       READ (NBERNW,*) T12ISM
20744       READ (NBERNW,*) JSPISM
20745       READ (NBERNW,*) JPTISM
20746       READ (NBERNW,*) APRIME
20747       IF (LEVPRT)
20748      &WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***'
20749       READ (NBERNW,*) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP
20750       IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR.
20751      &     ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN
20752          WRITE (LUNOUT,*)
20753      &         ' *** Inconsistent Nuclear Geometry data on file ***'
20754          STOP
20755       END IF
20756       READ (NBERNW,*) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB,
20757      &              EKATAB, PFATAB, PFRTAB
20758       READ (NBERNW,*) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE,
20759      &              EMNXSE, XMNXSE
20760       READ (NBERNW,*) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE,
20761      &              ZZPXSE, EMPXSE, XMPXSE
20762 *  Data about Fermi-breakup:
20763       READ (NBERNW,*) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF
20764       IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE.
20765      &     MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN
20766          WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data',
20767      &                   ' in the Nuclear Data file ***'
20768          STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA'
20769       END IF
20770       READ (NBERNW,*) IFRBKN
20771       READ (NBERNW,*) IFRBKZ
20772       READ (NBERNW,*) IFBKSP
20773       READ (NBERNW,*) IFBKST
20774       READ (NBERNW,*) EEXFBK
20775
20776       CLOSE (UNIT=NBERNW)
20777
20778 C     READ (NBERTP) (P0(I),P1(I),P2(I),I=1,1001)
20779 C     READ (NBERTP) IA,IZ
20780 C     DO 2 I=1,6
20781 C        FLA(I)=IA(I)
20782 C        FLZ(I)=IZ(I)
20783 C   2 CONTINUE
20784 C     READ (NBERTP) RHO,OMEGA
20785 C     READ (NBERTP) EXMASS
20786 C     READ (NBERTP) CAM2
20787 C     READ (NBERTP) CAM3
20788 C     READ (NBERTP) CAM4
20789 C     READ (NBERTP) CAM5
20790 C     READ (NBERTP) ((T(I,J),J=1,7),I=1,3)
20791 C     DO 3 I=1,7
20792 C        T(4,I) = ZERZER
20793 C   3 CONTINUE
20794 C     READ (NBERTP) RMASS
20795 C     READ (NBERTP) ALPH
20796 C     READ (NBERTP) BET
20797 C     READ (NBERTP) INWAPS
20798 C     READ (NBERTP) WAPS
20799 C     READ (NBERTP) T12NUC
20800 C     READ (NBERTP) JSPNUC
20801 C     READ (NBERTP) JPTNUC
20802 C     READ (NBERTP) INWISM
20803 C     READ (NBERTP) IZWISM
20804 C     READ (NBERTP) WAPISM
20805 C     READ (NBERTP) T12ISM
20806 C     READ (NBERTP) JSPISM
20807 C     READ (NBERTP) JPTISM
20808 C     READ (NBERTP) APRIME
20809 C     WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***'
20810 C     READ (NBERTP) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP
20811 C     IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR.
20812 C    &     ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN
20813 C        WRITE (LUNOUT,*)
20814 C    &         ' *** Inconsistent Nuclear Geometry data on file ***'
20815 C        STOP
20816 C     END IF
20817 C     READ (NBERTP) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB,
20818 C    &              EKATAB, PFATAB, PFRTAB
20819 C     READ (NBERTP) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE,
20820 C    &              EMNXSE, XMNXSE
20821 C     READ (NBERTP) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE,
20822 C    &              ZZPXSE, EMPXSE, XMPXSE
20823 *  Data about Fermi-breakup:
20824 C     READ (NBERTP) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF
20825 C     IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE.
20826 C    &     MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN
20827 C        WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data',
20828 C    &                   ' in the Nuclear Data file ***'
20829 C        STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA'
20830 C     END IF
20831 C     READ (NBERTP) IFRBKN
20832 C     READ (NBERTP) IFRBKZ
20833 C     READ (NBERTP) IFBKSP
20834 C     READ (NBERTP) IFBKST
20835 C     READ (NBERTP) EEXFBK
20836 C     CLOSE (UNIT=NBERTP)
20837       DO 100 JZ = 1, 130
20838          SHENUC ( JZ, 1 ) = EMVGEV * ( CAM2 (JZ) + CAM4 (JZ) )
20839   100 CONTINUE
20840       DO 200 JA = 1, 200
20841          SHENUC ( JA, 2 ) = EMVGEV * ( CAM3 (JA) + CAM5 (JA) )
20842   200 CONTINUE
20843       CALL DT_STALIN
20844       IF ( ILVMOD .LE. 0 ) THEN
20845          ILVMOD = IB0
20846       ELSE
20847          IB0 = ILVMOD
20848       END IF
20849       IF ( LLVMOD ) THEN
20850          DO 300 JZ = 1, IZCOOK
20851             CAM4 (JZ) = PZCOOK (JZ)
20852   300    CONTINUE
20853          DO 400 JN = 1, INCOOK
20854             CAM5 (JN) = PNCOOK (JZ)
20855   400    CONTINUE
20856       END IF
20857 **sr
20858       IF (LEVPRT) THEN
20859          WRITE (LUNOUT,*)
20860          IF ( ILVMOD .EQ. 1 ) THEN
20861             WRITE (LUNOUT,*)
20862      &   ' **** Standard EVAP T=0 level density used ****'
20863          ELSE IF ( ILVMOD .EQ. 2 ) THEN
20864             WRITE (LUNOUT,*)
20865      &   ' **** Gilbert & Cameron T=0 N,Z-dep. level density used ****'
20866          ELSE IF ( ILVMOD .EQ. 3 ) THEN
20867             WRITE (LUNOUT,*)
20868      &      ' **** Julich A-dependent level density used ****'
20869          ELSE IF ( ILVMOD .EQ. 4 ) THEN
20870             WRITE (LUNOUT,*)
20871      &   ' **** Brancazio & Cameron T=0 N,Z-dep. level density used',
20872      &                                                          ' ****'
20873          ELSE
20874             WRITE (LUNOUT,*)
20875      &   ' **** Unknown T=0 level density option requested ****'
20876             STOP 'BERTTP-ILVMOD'
20877          END IF
20878          IF ( JLVMOD .LE. 0 ) THEN
20879             GAMIGN = ZERZER
20880             WRITE (LUNOUT,*)
20881      &   ' **** No Excitation en. dependence for level densities ****'
20882          ELSE IF ( JLVMOD .EQ. 1 ) THEN
20883             WRITE (LUNOUT,*)
20884      &   ' **** Ignyatuk (1975, 1st) level density en. dep. used ****'
20885             WRITE (LUNOUT,*)
20886      &   ' **** with Ignyatuk (1975, 1st) set of parameters for T=oo',
20887      &                                                        ' ****'
20888             GAMIGN = 0.054D+00
20889             BETIGN = -6.3 D-05
20890             ALPIGN = 0.154D+00
20891             POWIGN = ZERZER
20892          ELSE IF ( JLVMOD .EQ. 2 ) THEN
20893             WRITE (LUNOUT,*)
20894      &   ' ****   Ignyatuk (1975, 1st) level density en. dep. used ****'
20895             WRITE (LUNOUT,*)
20896      &   ' **** with UNKNOWN set of parameters for T=oo ****'
20897             STOP 'BERTTP-JLVMOD'
20898          ELSE IF ( JLVMOD .EQ. 3 ) THEN
20899             WRITE (LUNOUT,*)
20900      &   ' ****   Ignyatuk (1975, 1st) level density en. dep. used ****'
20901             WRITE (LUNOUT,*)
20902      &   ' **** with UNKNOWN set of parameters for T=oo ****'
20903             STOP 'BERTTP-JLVMOD'
20904          ELSE IF ( JLVMOD .EQ. 4 ) THEN
20905             WRITE (LUNOUT,*)
20906      &   ' ****   Ignyatuk (1975, 2nd) level density en. dep. used ****'
20907             WRITE (LUNOUT,*)
20908      &   ' **** with Ignyatuk (1975, 2nd) set of parameters for T=oo',
20909      &                                                        ' ****'
20910             GAMIGN = 0.054D+00
20911             BETIGN = 0.162D+00
20912             ALPIGN = 0.114D+00
20913             POWIGN = -ONETHI
20914          ELSE IF ( JLVMOD .EQ. 5 ) THEN
20915             WRITE (LUNOUT,*)
20916      &   ' ****  Ignyatuk (1975, 2nd) level density en. dep. used  ****'
20917             WRITE (LUNOUT,*)
20918      &   ' **** with Iljinov & Mebel 1st set of parameters for T=oo****'
20919             GAMIGN = 0.051D+00
20920             BETIGN = 0.098D+00
20921             ALPIGN = 0.114D+00
20922             POWIGN = -ONETHI
20923          ELSE IF ( JLVMOD .EQ. 6 ) THEN
20924             WRITE (LUNOUT,*)
20925      &   ' ****   Ignyatuk (1975, 2nd) level density en. dep. used ****'
20926             WRITE (LUNOUT,*)
20927      &   ' **** with Iljinov & Mebel 2nd set of parameters for T=oo****'
20928             GAMIGN = -0.46D+00
20929             BETIGN = 0.107D+00
20930             ALPIGN = 0.111D+00
20931             POWIGN = -ONETHI
20932          ELSE IF ( JLVMOD .EQ. 7 ) THEN
20933             WRITE (LUNOUT,*)
20934      &   ' ****   Ignyatuk (1975, 2nd) level density en. dep. used ****'
20935             WRITE (LUNOUT,*)
20936      &   ' **** with Iljinov & Mebel 3rd set of parameters for T=oo****'
20937             GAMIGN = 0.059D+00
20938             BETIGN = 0.257D+00
20939             ALPIGN = 0.072D+00
20940             POWIGN = -ONETHI
20941          ELSE IF ( JLVMOD .EQ. 8 ) THEN
20942             WRITE (LUNOUT,*)
20943      &   ' ****   Ignyatuk (1975, 2nd) level density en. dep. used ****'
20944             WRITE (LUNOUT,*)
20945      &   ' **** with Iljinov & Mebel 4th set of parameters for T=oo****'
20946             GAMIGN = -0.37D+00
20947             BETIGN = 0.229D+00
20948             ALPIGN = 0.077D+00
20949             POWIGN = -ONETHI
20950          ELSE
20951             WRITE (LUNOUT,*)
20952      &   ' **** Unknown T=oo level density option requested ****'
20953             STOP 'BERTTP-JLVMOD'
20954          END IF
20955          IF ( LLVMOD ) THEN
20956             WRITE (LUNOUT,*)
20957      &      ' **** Cook''s modified pairing energy used ****'
20958          ELSE
20959             WRITE (LUNOUT,*)
20960      &      ' **** Original Gilbert/Cameron pairing energy used ****'
20961          END IF
20962       ENDIF
20963 **
20964
20965       ILVMOD = IB0
20966       DO 500 JZ = 1, 130
20967          PAENUC ( JZ, 1 ) = EMVGEV * CAM4 (JZ)
20968   500 CONTINUE
20969       DO 600 JA = 1, 200
20970          PAENUC ( JA, 2 ) = EMVGEV * CAM5 (JA)
20971   600 CONTINUE
20972       RETURN
20973       END
20974
20975 *$ CREATE DT_EVEVAP.FOR
20976 *COPY DT_EVEVAP
20977 *
20978 *====evevap============================================================*
20979 *
20980       SUBROUTINE DT_EVEVAP(WE)
20981
20982       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20983       SAVE
20984       PARAMETER ( LINP = 10 ,
20985      &            LOUT = 6 ,
20986      &            LDAT = 9 )
20987
20988 * flags for input different options
20989       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
20990       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
20991      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
20992
20993       LEVAPO = .FALSE.
20994
20995       RETURN
20996       END
20997
20998 *$ CREATE DT_FRBKIN.FOR
20999 *COPY DT_FRBKIN
21000 *
21001 *====frbkin============================================================*
21002 *
21003       SUBROUTINE DT_FRBKIN(LDUM1,LDUM2)
21004
21005       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21006       SAVE
21007       PARAMETER ( LINP = 10 ,
21008      &            LOUT = 6 ,
21009      &            LDAT = 9 )
21010
21011       LOGICAL LDUM1,LDUM2
21012
21013       RETURN
21014       END
21015
21016 *$ CREATE DT_EXPLOD.FOR
21017 *COPY DT_EXPLOD
21018 *
21019 *=== explod ===========================================================*
21020 *
21021       SUBROUTINE DT_EXPLOD( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
21022      &                    PYEXPL, PZEXPL )
21023
21024       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21025       SAVE
21026
21027       DIMENSION PXEXPL (NPEXPL), PYEXPL (NPEXPL), PZEXPL (NPEXPL),
21028      &          ETEXPL (NPEXPL), AMEXPL (NPEXPL)
21029
21030       RETURN
21031       END
21032
21033 ************************************************************************
21034 *                                                                      *
21035 *  DPMJET 3.0:   cross section routines                                *
21036 *                                                                      *
21037 ************************************************************************
21038 *
21039 *
21040 *     SUBROUTINE DT_SHNDIF
21041 *         diffractive cross sections (all energies)
21042 *     SUBROUTINE DT_PHOXS
21043 *         total and inel. cross sections from PHOJET interpol. tables
21044 *     SUBROUTINE DT_XSHN
21045 *         total and el. cross sections for all energies
21046 *     SUBROUTINE DT_SIHNAB
21047 *         pion 2-nucleon absorption cross sections
21048 *     SUBROUTINE DT_SIGEMU
21049 *         cross section for target "compounds"
21050 *     SUBROUTINE DT_SIGGA
21051 *         photon nucleus cross sections
21052 *     SUBROUTINE DT_SIGGAT
21053 *         photon nucleus cross sections from tables
21054 *     SUBROUTINE DT_SANO
21055 *         anomalous hard photon-nucleon cross sections from tables
21056 *     SUBROUTINE DT_SIGGP
21057 *         photon nucleon cross sections
21058 *     SUBROUTINE DT_SIGVEL
21059 *         quasi-elastic vector meson prod. cross sections
21060 *     DOUBLE PRECISION FUNCTION DT_SIGVP
21061 *         sigma_VN(tilde)
21062 *     DOUBLE PRECISION FUNCTION DT_RRM2
21063 *     DOUBLE PRECISION FUNCTION DT_RM2
21064 *     DOUBLE PRECISION FUNCTION DT_SAM2
21065 *     SUBROUTINE DT_CKMT
21066 *     SUBROUTINE DT_CKMTX
21067 *     SUBROUTINE DT_PDF0
21068 *     SUBROUTINE DT_CKMTQ0
21069 *     SUBROUTINE DT_CKMTDE
21070 *     SUBROUTINE DT_CKMTPR
21071 *     FUNCTION DT_CKMTFF
21072 *
21073 *     SUBROUTINE DT_FLUINI
21074 *         total nucleon cross section fluctuation treatment
21075 *
21076 *     SUBROUTINE DT_SIGTBL
21077 *         pre-tabulation of low-energy elastic x-sec. using SIHNEL
21078 *     SUBROUTINE DT_XSTABL
21079 *         service routines
21080 *
21081 *
21082 *$ CREATE DT_SHNDIF.FOR
21083 *COPY DT_SHNDIF
21084 *
21085 *===shndif===============================================================*
21086 *
21087       SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
21088
21089 **********************************************************************
21090 *   Single diffractive hadron-nucleon cross sections                 *
21091 *                                              S.Roesler 14/1/93     *
21092 *                                                                    *
21093 *   The cross sections are calculated from extrapolated single       *
21094 *   diffractive antiproton-proton cross sections (DTUJET92) using    *
21095 *   scaling relations between total and single diffractive cross     *
21096 *   sections.                                                        *
21097 **********************************************************************
21098
21099       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21100       SAVE
21101       PARAMETER (ZERO=0.0D0)
21102
21103 * particle properties (BAMJET index convention)
21104       CHARACTER*8  ANAME
21105       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21106      &                IICH(210),IIBAR(210),K1(210),K2(210)
21107 *
21108       CSD1   =   4.201483727D0
21109       CSD4   = -0.4763103556D-02
21110       CSD5   =  0.4324148297D0
21111 *
21112       CHMSD1 =  0.8519297242D0
21113       CHMSD4 = -0.1443076599D-01
21114       CHMSD5 =  0.4014954567D0
21115 *
21116       EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
21117       PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
21118 *
21119       SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
21120       SHMSD  = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
21121       FRAC   = SHMSD/SDIAPP
21122 *
21123       GOTO( 10, 20,999,999,999,999,999, 10, 20,999,
21124      &     999, 20, 20, 20, 20, 20, 10, 20, 20, 10,
21125      &      10, 10, 20, 20, 20) KPROJ
21126 *
21127    10 CONTINUE
21128 *---------------------------- p - p , n - p , sigma0+- - p ,
21129 *                             Lambda - p
21130       CSD1   =  6.004476070D0
21131       CSD4   = -0.1257784606D-03
21132       CSD5   =  0.2447335720D0
21133       SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
21134       SIGDIH = FRAC*SIGDIF
21135       RETURN
21136 *
21137    20 CONTINUE
21138 *
21139       KPSCAL = 2
21140       KTSCAL = 1
21141 C     F      = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
21142       DUMZER = ZERO
21143       CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
21144       F      = SDIAPP/SIGTO
21145       KT     = 1
21146 C     SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
21147       CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
21148       SIGDIF = SIGTO*F
21149       SIGDIH = FRAC*SIGDIF
21150       RETURN
21151 *
21152   999 CONTINUE
21153 *-------------------------- leptons..
21154       SIGDIF = 1.D-10
21155       SIGDIH = 1.D-10
21156       RETURN
21157       END
21158
21159 *$ CREATE DT_PHOXS.FOR
21160 *COPY DT_PHOXS
21161 *
21162 *===phoxs================================================================*
21163 *
21164       SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
21165
21166 ************************************************************************
21167 * Total/inelastic proton-nucleon cross sections taken from PHOJET-     *
21168 * interpolation tables.                                                *
21169 * This version dated 05.11.97 is written by S. Roesler                 *
21170 ************************************************************************
21171
21172       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21173       SAVE
21174
21175       PARAMETER ( LINP = 10 ,
21176      &            LOUT = 6 ,
21177      &            LDAT = 9 )
21178       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21179       PARAMETER (TWOPI  = 6.283185307179586454D+00,
21180      &           PI     = TWOPI/TWO,
21181      &           GEV2MB = 0.38938D0)
21182
21183       LOGICAL LFIRST
21184       DATA LFIRST /.TRUE./
21185
21186 * nucleon-nucleon event-generator
21187       CHARACTER*8 CMODEL
21188       LOGICAL LPHOIN
21189       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21190 * particle properties (BAMJET index convention)
21191       CHARACTER*8  ANAME
21192       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21193      &                IICH(210),IIBAR(210),K1(210),K2(210)
21194
21195 **PHOJET105a
21196 C     PARAMETER (IEETAB=10)
21197 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21198 **PHOJET110
21199 C  energy-interpolation table
21200       INTEGER IEETA2
21201       PARAMETER ( IEETA2 = 20 )
21202       INTEGER ISIMAX
21203       DOUBLE PRECISION SIGTAB,SIGECM
21204       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21205 **
21206
21207       IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
21208          WRITE(LOUT,*) MCGENE
21209  1000    FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
21210          STOP
21211       ENDIF
21212
21213       IF (ECM.LE.ZERO) THEN
21214          EPN = SQRT(AAM(KPROJ)**2+PLAB**2)
21215          ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG))
21216       ENDIF
21217
21218       IF (MODE.EQ.1) THEN
21219 * DL
21220          DELDL = 0.0808D0
21221          EPSDL = -0.4525D0
21222          S     = ECM*ECM
21223          STOT  = 21.7D0*S**DELDL+56.08D0*S**EPSDL
21224          ALPHAP= 0.25D0
21225          BEL   = 8.5D0+2.D0*ALPHAP*LOG(S)
21226          SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
21227          SINE  = STOT-SIGEL
21228          SDIF1 = ZERO
21229       ELSE
21230 * Phojet
21231          IP = 1
21232          IF(ECM.LE.SIGECM(IP,1)) THEN
21233            I1 = 1
21234            I2 = 1
21235          ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
21236            DO 1 I=2,ISIMAX
21237               IF (ECM.LE.SIGECM(IP,I)) GOTO 2
21238     1      CONTINUE
21239     2      CONTINUE
21240            I1 = I-1
21241            I2 = I
21242          ELSE
21243            IF (LFIRST) THEN
21244               WRITE(LOUT,'(/1X,A,2E12.3)')
21245      &          'PHOXS: warning! energy above initialization limit (',
21246      &          ECM,SIGECM(IP,ISIMAX)
21247              LFIRST = .FALSE.
21248            ENDIF
21249            I1 = ISIMAX
21250            I2 = ISIMAX
21251          ENDIF
21252          FAC2 = ZERO
21253          IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
21254      &                       /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
21255          FAC1  = ONE-FAC2
21256          STOT  = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
21257          SINE  = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
21258          SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+
21259      &           FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1))
21260          BEL   = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
21261       ENDIF
21262
21263       RETURN
21264       END
21265
21266 *$ CREATE DT_XSHN.FOR
21267 *COPY DT_XSHN
21268 *
21269 *===xshn===============================================================*
21270 *
21271       SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
21272
21273 ************************************************************************
21274 * Total and elastic hadron-nucleon cross section.                      *
21275 * Below 500GeV cross sections are based on the '98 data compilation    *
21276 * of the PDG. At higher energies PHOJET results are used (patched to   *
21277 * the low energy data at 500GeV).                                      *
21278 *     IP      projectile index (BAMJET numbering scheme)               *
21279 *             (should be in the range 1..25)                           *
21280 *     IT      target index (BAMJET numbering scheme)                   *
21281 *             (1 = proton, 8 = neutron)                                *
21282 *     PL      laboratory momentum                                      *
21283 *     ECM     cm. energy (ignored if PL>0)                             *
21284 *     STOT    total cross section                                      *
21285 *     SELA    elastic cross section                                    *
21286 * Last change: 24.4.99 by S. Roesler                                   *
21287 ************************************************************************
21288
21289       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21290       SAVE
21291
21292       PARAMETER ( LINP = 10 ,
21293      &            LOUT = 6 ,
21294      &            LDAT = 9 )
21295       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
21296
21297       PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
21298      &           PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
21299       PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
21300
21301       LOGICAL LFIRST
21302 * particle properties (BAMJET index convention)
21303       CHARACTER*8  ANAME
21304       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21305      &                IICH(210),IIBAR(210),K1(210),K2(210)
21306 * nucleon-nucleon event-generator
21307       CHARACTER*8 CMODEL
21308       LOGICAL LPHOIN
21309       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21310 **PHOJET105a
21311 C     PARAMETER (IEETAB=10)
21312 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21313 **PHOJET110
21314 C  energy-interpolation table
21315       INTEGER IEETA2
21316       PARAMETER ( IEETA2 = 20 )
21317       INTEGER ISIMAX
21318       DOUBLE PRECISION SIGTAB,SIGECM
21319       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21320
21321       DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
21322       DIMENSION IDXDAT(25,2)
21323 *
21324       DATA APL /
21325      &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748,
21326      &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465,
21327      &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182,
21328      &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101,
21329      & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384,
21330      & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668,
21331      & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/
21332 *
21333 * total cross sections:
21334 * p p
21335       DATA (ASIGTO(1,K),K=1,NPOINT) /
21336      & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21337      & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21338      & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352,
21339      & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596,
21340      & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664,
21341      & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617,
21342      & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/
21343 * pbar p
21344       DATA (ASIGTO(2,K),K=1,NPOINT) /
21345      & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598,
21346      & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329,
21347      & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151,
21348      & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024,
21349      & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921,
21350      & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802,
21351      & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/
21352 * n p
21353       DATA (ASIGTO(3,K),K=1,NPOINT) /
21354      & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21355      & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21356      & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21357      & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566,
21358      & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21359      & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21360      & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21361 * pi+ p
21362       DATA (ASIGTO(4,K),K=1,NPOINT) /
21363      & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21364      & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21365      & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195,
21366      & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473,
21367      & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492,
21368      & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428,
21369      & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/
21370 * pi- p
21371       DATA (ASIGTO(5,K),K=1,NPOINT) /
21372      & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226,
21373      & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679,
21374      & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547,
21375      & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543,
21376      & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535,
21377      & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468,
21378      & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/
21379 * K+ p
21380       DATA (ASIGTO(6,K),K=1,NPOINT) /
21381      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21382      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21383      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095,
21384      & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268,
21385      & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244,
21386      & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236,
21387      & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/
21388 * K- p
21389       DATA (ASIGTO(7,K),K=1,NPOINT) /
21390      & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997,
21391      & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847,
21392      & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543,
21393      & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508,
21394      & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463,
21395      & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396,
21396      & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/
21397 * K+ n
21398       DATA (ASIGTO(8,K),K=1,NPOINT) /
21399      & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21400      & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21401      & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147,
21402      & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301,
21403      & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261,
21404      & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240,
21405      & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/
21406 * K- n
21407       DATA (ASIGTO(9,K),K=1,NPOINT) /
21408      & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778,
21409      & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773,
21410      & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437,
21411      & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454,
21412      & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343,
21413      & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330,
21414      & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/
21415 * Lambda p
21416       DATA (ASIGTO(10,K),K=1,NPOINT) /
21417      & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21418      & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629,
21419      & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499,
21420      & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567,
21421      & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21422      & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21423      & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21424 *
21425 * elastic cross sections:
21426 * p p
21427       DATA (ASIGEL(1,K),K=1,NPOINT) /
21428      & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21429      & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21430      & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350,
21431      & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397,
21432      & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275,
21433      & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115,
21434      & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/
21435 * pbar p
21436       DATA (ASIGEL(2,K),K=1,NPOINT) /
21437      & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963,
21438      & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875,
21439      & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720,
21440      & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636,
21441      & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457,
21442      & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228,
21443      & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/
21444 * n p
21445       DATA (ASIGEL(3,K),K=1,NPOINT) /
21446      & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21447      & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21448      & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21449      & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454,
21450      & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21451      & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21452      & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21453 * pi+ p
21454       DATA (ASIGEL(4,K),K=1,NPOINT) /
21455      & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21456      & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21457      & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166,
21458      & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235,
21459      & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904,
21460      & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776,
21461      & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/
21462 * pi- p
21463       DATA (ASIGEL(5,K),K=1,NPOINT) /
21464      & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727,
21465      & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217,
21466      & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209,
21467      & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140,
21468      & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895,
21469      & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800,
21470      & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/
21471 * K+ p
21472       DATA (ASIGEL(6,K),K=1,NPOINT) /
21473      & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066,
21474      & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070,
21475      & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093,
21476      & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012,
21477      & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759,
21478      & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584,
21479      & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/
21480 * K- p
21481       DATA (ASIGEL(7,K),K=1,NPOINT) /
21482      & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878,
21483      & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561,
21484      & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188,
21485      & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077,
21486      & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800,
21487      & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618,
21488      & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/
21489 * K+ n
21490       DATA (ASIGEL(8,K),K=1,NPOINT) /
21491      & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21492      & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21493      & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148,
21494      & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111,
21495      & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785,
21496      & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635,
21497      & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/
21498 * K- n
21499       DATA (ASIGEL(9,K),K=1,NPOINT) /
21500      & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613,
21501      & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606,
21502      & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914,
21503      & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979,
21504      & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559,
21505      & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489,
21506      & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/
21507 * Lambda p
21508       DATA (ASIGEL(10,K),K=1,NPOINT) /
21509      & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21510      & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630,
21511      & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502,
21512      & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454,
21513      & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21514      & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21515      & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21516
21517       DATA (IDXDAT(K,1),K=1,25) /
21518      &  1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3,
21519      &  1, 3,45, 8, 9/
21520       DATA (IDXDAT(K,2),K=1,25) /
21521      &  3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1,
21522      &  3, 1,45, 6, 7/
21523
21524       DATA LFIRST /.TRUE./
21525
21526       IF (LFIRST) THEN
21527          APLABL = LOG10(PLABLO)
21528          APLABH = LOG10(PLABHI)
21529          APTHRE = LOG10(PTHRE)
21530          ADP1   = (APTHRE-APLABL)/DBLE(NPOIN1)
21531          ADP2   = (APLABH-APTHRE)/DBLE(NPOIN2)
21532          DUM0   = ZERO
21533          PHOPLA = PLABHI
21534          PHOELA = SQRT(AAM(1)**2+PHOPLA**2)
21535          ECMS   = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA)
21536          IF (MCGENE.EQ.2) THEN
21537             IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN
21538                CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0)
21539             ELSE
21540                CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21541             ENDIF
21542          ELSE
21543             CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21544          ENDIF
21545          PHOSEL = PHOSTO-PHOSIN
21546          APHOST = LOG10(PHOSTO)
21547          APHOSE = LOG10(PHOSEL)
21548          LFIRST = .FALSE.
21549       ENDIF
21550       STOT = ZERO
21551       SELA = ZERO
21552       PLAB = PL
21553       ECMS = ECM
21554       IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN
21555          WRITE(LOUT,1000) IP,IT
21556  1000    FORMAT(1X,'DT_XSHN: cross sections not implemented for ',
21557      &          'proj/target',2I4)
21558          STOP
21559       ENDIF
21560
21561       IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN
21562          ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT))
21563          PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP)))
21564       ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN
21565          WRITE(LOUT,1001) PLAB,ECMS
21566  1001    FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5)
21567          STOP
21568       ENDIF
21569
21570 * index of spectrum
21571       IDXP = IP
21572       IF (IP.GT.25) THEN
21573          IF (AAM(IP).GT.ZERO) THEN
21574             IF (ABS(IIBAR(IP)).GT.0) THEN
21575                IDXP = 1
21576             ELSE
21577                IDXP = 13
21578             ENDIF
21579          ELSE
21580             IDXP = 7
21581          ENDIF
21582       ENDIF
21583       IDXT = 1
21584       IF (IT.EQ.8) IDXT = 2
21585       IDXS = IDXDAT(IDXP,IDXT)
21586       IF (IDXS.EQ.0) RETURN
21587
21588 * compute momentum bin indices
21589       IF (PLAB.LT.PLABLO) THEN
21590          IDX0 = 1
21591          IDX1 = 1
21592       ELSEIF (PLAB.GE.PLABHI) THEN
21593          IDX0 = NPOINT
21594          IDX1 = NPOINT
21595       ELSE
21596          APLAB = LOG10(PLAB)
21597          IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN
21598             IDX0 = INT((APLAB-APLABL)/ADP1)+1
21599          ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN
21600             IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1
21601          ENDIF
21602          IDX1 = IDX0+1
21603       ENDIF
21604
21605 * interpolate cross section
21606       IF (IDXS.GT.10) THEN
21607          IDXS1 = IDXS/10
21608          IDXS2 = IDXS-10*IDXS1
21609          IF (IDX0.EQ.IDX1) THEN
21610             IF (IDX0.EQ.1) THEN
21611                ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0))
21612                ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0))
21613             ELSE
21614                DUM0   = ZERO
21615                CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21616                PHOSEL = PHOSTO-PHOSIN
21617                ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO)
21618                ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL)
21619                ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO)
21620                ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL)
21621                ASTOT  = 0.5D0*(ASTOT1+ASTOT2)
21622                ASELA  = 0.5D0*(ASELA1+ASELA2)
21623             ENDIF
21624          ELSE
21625             FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21626             ASTOT1 = ASIGTO(IDXS1,IDX0)+
21627      &               FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0))
21628             ASTOT2 = ASIGTO(IDXS2,IDX0)+
21629      &               FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0))
21630             ASTOT  = 0.5D0*(ASTOT1+ASTOT2)
21631             ASELA1 = ASIGEL(IDXS1,IDX0)+
21632      &               FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0))
21633             ASELA2 = ASIGEL(IDXS2,IDX0)+
21634      &               FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0))
21635             ASELA  = 0.5D0*(ASELA1+ASELA2)
21636          ENDIF
21637       ELSE
21638          IF (IDX0.EQ.IDX1) THEN
21639             IF (IDX0.EQ.1) THEN
21640                ASTOT = ASIGTO(IDXS,IDX0)
21641                ASELA = ASIGEL(IDXS,IDX0)
21642             ELSE
21643                DUM0   = ZERO
21644                CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21645                PHOSEL = PHOSTO-PHOSIN
21646                ASTOT  = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO)
21647                ASELA  = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL)
21648             ENDIF
21649          ELSE
21650             FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21651             ASTOT = ASIGTO(IDXS,IDX0)+
21652      &              FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0))
21653             ASELA = ASIGEL(IDXS,IDX0)+
21654      &              FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0))
21655          ENDIF
21656       ENDIF
21657       STOT = 10.0D0**ASTOT
21658       SELA = 10.0D0**ASELA
21659
21660       RETURN
21661       END
21662
21663 *$ CREATE DT_SIHNAB.FOR
21664 *COPY DT_SIHNAB
21665 *
21666 *===sihnab===============================================================*
21667 *
21668       SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
21669
21670 **********************************************************************
21671 * Pion 2-nucleon absorption cross sections.                          *
21672 * (sigma_tot for pi+ d --> p p, pi- d --> n n                        *
21673 *  taken from Ritchie PRC 28 (1983) 926 )                            *
21674 * This version dated 18.05.96 is written by S. Roesler               *
21675 **********************************************************************
21676
21677       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21678       SAVE
21679       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
21680       PARAMETER (AMPR = 938.0D0,
21681      &           AMPI = 140.0D0,
21682      &           AMDE = TWO*AMPR,
21683      &           A    = -1.2D0,
21684      &           B    = 3.5D0,
21685      &           C    = 7.4D0,
21686      &           D    = 5600.0D0,
21687      &           ER   = 2136.0D0)
21688
21689       SIGABS = ZERO
21690       IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
21691      &                   .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
21692       PTOT = PLAB*1.0D3
21693       EKIN = SQRT(AMPI**2+PTOT**2)-AMPI
21694       IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN
21695       ECM  = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE )
21696       SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D)
21697 * approximate 3N-abs., I=1-abs. etc.
21698       SIGABS = SIGABS/0.40D0
21699 * pi0-absorption (rough approximation!!)
21700       IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS
21701
21702       RETURN
21703       END
21704
21705 *$ CREATE DT_SIGEMU.FOR
21706 *COPY DT_SIGEMU
21707 *
21708 *===sigemu=============================================================*
21709 *
21710       SUBROUTINE DT_SIGEMU
21711
21712 ************************************************************************
21713 * Combined cross section for target compounds.                         *
21714 * This version dated 6.4.98   is written by S. Roesler                 *
21715 ************************************************************************
21716
21717       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21718       SAVE
21719       PARAMETER ( LINP = 10 ,
21720      &            LOUT = 6 ,
21721      &            LDAT = 9 )
21722       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21723      &           OHALF=0.5D0,ONE=1.0D0)
21724
21725       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21726 * Glauber formalism: cross sections
21727       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21728      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21729      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21730      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21731      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21732      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21733      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21734      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21735      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21736      &                BSLOPE,NEBINI,NQBINI
21737 * emulsion treatment
21738       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
21739      &                NCOMPO,IEMUL
21740 * nucleon-nucleon event-generator
21741       CHARACTER*8 CMODEL
21742       LOGICAL LPHOIN
21743       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21744
21745       IF (MCGENE.NE.4) THEN
21746          WRITE(LOUT,'(A)') ' DT_SIGEMU:    Combined cross sections'
21747          WRITE(LOUT,'(15X,A)') '-----------------------'
21748       ENDIF
21749       DO 1 IE=1,NEBINI
21750          DO 2 IQ=1,NQBINI
21751             SIGTOT = ZERO
21752             SIGELA = ZERO
21753             SIGQEP = ZERO
21754             SIGQET = ZERO
21755             SIGQE2 = ZERO
21756             SIGPRO = ZERO
21757             SIGDEL = ZERO
21758             SIGDQE = ZERO
21759             ERRTOT = ZERO
21760             ERRELA = ZERO
21761             ERRQEP = ZERO
21762             ERRQET = ZERO
21763             ERRQE2 = ZERO
21764             ERRPRO = ZERO
21765             ERRDEL = ZERO
21766             ERRDQE = ZERO
21767             IF (NCOMPO.GT.0) THEN
21768                DO 3 IC=1,NCOMPO
21769                   SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC)
21770                   SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC)
21771                   SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC)
21772                   SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC)
21773                   SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC)
21774                   SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC)
21775                   SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC)
21776                   SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC)
21777                   ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2
21778                   ERRELA = ERRELA+XEELA(IE,IQ,IC)**2
21779                   ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2
21780                   ERRQET = ERRQET+XEQET(IE,IQ,IC)**2
21781                   ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2
21782                   ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2
21783                   ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2
21784                   ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2
21785     3          CONTINUE
21786                ERRTOT = SQRT(ERRTOT)
21787                ERRELA = SQRT(ERRELA)
21788                ERRQEP = SQRT(ERRQEP)
21789                ERRQET = SQRT(ERRQET)
21790                ERRQE2 = SQRT(ERRQE2)
21791                ERRPRO = SQRT(ERRPRO)
21792                ERRDEL = SQRT(ERRDEL)
21793                ERRDQE = SQRT(ERRDQE)
21794             ELSE
21795                SIGTOT = XSTOT(IE,IQ,1)
21796                SIGELA = XSELA(IE,IQ,1)
21797                SIGQEP = XSQEP(IE,IQ,1)
21798                SIGQET = XSQET(IE,IQ,1)
21799                SIGQE2 = XSQE2(IE,IQ,1)
21800                SIGPRO = XSPRO(IE,IQ,1)
21801                SIGDEL = XSDEL(IE,IQ,1)
21802                SIGDQE = XSDQE(IE,IQ,1)
21803                ERRTOT = XETOT(IE,IQ,1)
21804                ERRELA = XEELA(IE,IQ,1)
21805                ERRQEP = XEQEP(IE,IQ,1)
21806                ERRQET = XEQET(IE,IQ,1)
21807                ERRQE2 = XEQE2(IE,IQ,1)
21808                ERRPRO = XEPRO(IE,IQ,1)
21809                ERRDEL = XEDEL(IE,IQ,1)
21810                ERRDQE = XEDQE(IE,IQ,1)
21811             ENDIF
21812             IF (MCGENE.NE.4) THEN
21813                WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ)
21814  1000         FORMAT(/,1X,'E_cm =',F9.1,' GeV  Q^2 =',F6.1,' GeV^2 :',/)
21815                WRITE(LOUT,1001) SIGTOT,ERRTOT
21816  1001          FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb')
21817                WRITE(LOUT,1002) SIGELA,ERRELA
21818  1002          FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb')
21819                WRITE(LOUT,1003) SIGQEP,ERRQEP
21820  1003          FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-',
21821      &                F11.5,' mb')
21822                WRITE(LOUT,1004) SIGQET,ERRQET
21823  1004          FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
21824      &                F11.5,' mb')
21825                WRITE(LOUT,1005) SIGQE2,ERRQE2
21826  1005          FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4,
21827      &                ' +-',F11.5,' mb')
21828                WRITE(LOUT,1006) SIGPRO,ERRPRO
21829  1006          FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb')
21830                WRITE(LOUT,1007) SIGDEL,ERRDEL
21831  1007          FORMAT(1X,'diff-el   ',27X,F10.4,' +-',F11.5,' mb')
21832                WRITE(LOUT,1008) SIGDQE,ERRDQE
21833  1008          FORMAT(1X,'diff-qel  ',27X,F10.4,' +-',F11.5,' mb')
21834             ENDIF
21835
21836     2    CONTINUE
21837     1 CONTINUE
21838
21839       RETURN
21840       END
21841
21842 *$ CREATE DT_SIGGA.FOR
21843 *COPY DT_SIGGA
21844 *
21845 *===sigga==============================================================*
21846 *
21847       SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
21848
21849 ************************************************************************
21850 * Total/inelastic photon-nucleus cross sections.                       *
21851 *     !!!! Overwrites SHMAKI-initialization. Do not use it during      *
21852 *          production runs !!!!                                        *
21853 * This version dated 27.03.96 is written by S. Roesler                 *
21854 ************************************************************************
21855
21856       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21857       SAVE
21858       PARAMETER ( LINP = 10 ,
21859      &            LOUT = 6 ,
21860      &            LDAT = 9 )
21861       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21862      &           OHALF=0.5D0,ONE=1.0D0)
21863       PARAMETER (AMPROT = 0.938D0)
21864
21865       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21866 * Glauber formalism: cross sections
21867       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21868      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21869      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21870      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21871      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21872      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21873      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21874      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21875      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21876      &                BSLOPE,NEBINI,NQBINI
21877
21878       NT  = NTI
21879       X   = XI
21880       Q2  = Q2I
21881       ECM = ECMI
21882       XNU = XNUI
21883       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21884      &   ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT)
21885       CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1)
21886       STOT  = XSTOT(1,1,1)
21887       ETOT  = XETOT(1,1,1)
21888       SIN   = XSPRO(1,1,1)
21889       EIN   = XEPRO(1,1,1)
21890
21891       RETURN
21892       END
21893
21894 *$ CREATE DT_SIGGAT.FOR
21895 *COPY DT_SIGGAT
21896 *
21897 *===siggat=============================================================*
21898 *
21899       SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
21900
21901 ************************************************************************
21902 * Total/inelastic photon-nucleus cross sections.                       *
21903 * Uses pre-tabulated cross section.                                    *
21904 * This version dated 29.07.96 is written by S. Roesler                 *
21905 ************************************************************************
21906
21907       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21908       SAVE
21909       PARAMETER ( LINP = 10 ,
21910      &            LOUT = 6 ,
21911      &            LDAT = 9 )
21912       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21913      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21914
21915       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21916 * Glauber formalism: cross sections
21917       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21918      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21919      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21920      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21921      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21922      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21923      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21924      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21925      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21926      &                BSLOPE,NEBINI,NQBINI
21927
21928       NTARG = ABS(NT)
21929       I1   = 1
21930       I2   = 1
21931       RATE = ONE
21932       IF (NEBINI.GT.1) THEN
21933          IF (ECMI.GE.ECMNN(NEBINI)) THEN
21934             I1   = NEBINI
21935             I2   = NEBINI
21936             RATE = ONE
21937          ELSEIF (ECMI.GT.ECMNN(1)) THEN
21938             DO 1 I=2,NEBINI
21939                IF (ECMI.LT.ECMNN(I)) THEN
21940                   I1   = I-1
21941                   I2   = I
21942                   RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
21943                   GOTO 2
21944                ENDIF
21945     1       CONTINUE
21946     2       CONTINUE
21947          ENDIF
21948       ENDIF
21949       J1   = 1
21950       J2   = 1
21951       RATQ = ONE
21952       IF (NQBINI.GT.1) THEN
21953          IF (Q2I.GE.Q2G(NQBINI)) THEN
21954             J1   = NQBINI
21955             J2   = NQBINI
21956             RATQ = ONE
21957          ELSEIF (Q2I.GT.Q2G(1)) THEN
21958             DO 3 I=2,NQBINI
21959                IF (Q2I.LT.Q2G(I)) THEN
21960                   J1   = I-1
21961                   J2   = I
21962                   RATQ = LOG10(    Q2I/MAX(Q2G(J1),TINY14))/
21963      &                   LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
21964 C                 RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
21965                   GOTO 4
21966                ENDIF
21967     3       CONTINUE
21968     4       CONTINUE
21969          ENDIF
21970       ENDIF
21971
21972       STOT = XSTOT(I1,J1,NTARG)+
21973      &   RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+
21974      &   RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+
21975      &   RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+
21976      &              XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG))
21977
21978       RETURN
21979       END
21980
21981 *$ CREATE DT_SANO.FOR
21982 *COPY DT_SANO
21983 *
21984 *===sigano=============================================================*
21985 *
21986       DOUBLE PRECISION FUNCTION DT_SANO(ECM)
21987
21988 ************************************************************************
21989 * This version dated 31.07.96 is written by S. Roesler                 *
21990 ************************************************************************
21991
21992       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21993       SAVE
21994       PARAMETER ( LINP = 10 ,
21995      &            LOUT = 6 ,
21996      &            LDAT = 9 )
21997       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21998      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21999       PARAMETER (NE = 8)
22000
22001 * VDM parameter for photon-nucleus interactions
22002       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22003 * properties of interacting particles
22004       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
22005
22006       DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
22007       DATA ECMANO /
22008      &             0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03,
22009      &             0.100D+04,0.200D+04,0.500D+04
22010      &            /
22011 * fixed cut (3 GeV/c)
22012       DATA FRAANO /
22013      &             0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00,
22014      &             0.062D+00,0.054D+00,0.042D+00
22015      &            /
22016       DATA SIGHRD /
22017      &           4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01,
22018      &           3.3086D-01,7.6255D-01,2.1319D+00
22019      &            /
22020 * running cut (based on obsolete Phojet-caluclations, bugs..)
22021 C     DATA FRAANO /
22022 C    &             0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
22023 C    &             0.167E+00,0.150E+00,0.131E+00
22024 C    &            /
22025 C     DATA SIGHRD /
22026 C    &           6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
22027 C    &           2.5736E-01,4.5593E-01,8.2550E-01
22028 C    &            /
22029
22030       DT_SANO = ZERO
22031       IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
22032       J1   = 0
22033       J2   = 0
22034       RATE = ONE
22035       IF (ECM.GE.ECMANO(NE)) THEN
22036          J1 = NE
22037          J2 = NE
22038       ELSEIF (ECM.GT.ECMANO(1)) THEN
22039          DO 1 IE=2,NE
22040             IF (ECM.LT.ECMANO(IE)) THEN
22041                J1   = IE-1
22042                J2   = IE
22043                RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
22044                GOTO 2
22045             ENDIF
22046     1    CONTINUE
22047     2    CONTINUE
22048       ENDIF
22049       IF ((J1.GT.0).AND.(J2.GT.0)) THEN
22050          AFRA1  = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14))
22051          AFRA2  = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14))
22052          DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1))
22053       ENDIF
22054
22055       RETURN
22056       END
22057
22058 *$ CREATE DT_SIGGP.FOR
22059 *COPY DT_SIGGP
22060 *
22061 *===siggp==============================================================*
22062 *
22063       SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
22064
22065 ************************************************************************
22066 * Total/inelastic photon-nucleon cross sections.                       *
22067 * This version dated 30.04.96 is written by S. Roesler                 *
22068 ************************************************************************
22069
22070       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22071       SAVE
22072       PARAMETER ( LINP = 10 ,
22073      &            LOUT = 6 ,
22074      &            LDAT = 9 )
22075       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22076       PARAMETER (TWOPI  = 6.283185307179586476925286766559D+00,
22077      &           PI     = TWOPI/TWO,
22078      &           GEV2MB = 0.38938D0,
22079      &           ALPHEM = ONE/137.0D0)
22080
22081 * particle properties (BAMJET index convention)
22082       CHARACTER*8  ANAME
22083       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22084      &                IICH(210),IIBAR(210),K1(210),K2(210)
22085 * VDM parameter for photon-nucleus interactions
22086       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22087
22088 **PHOJET105a
22089 C     CHARACTER*8 MDLNA
22090 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
22091 C     PARAMETER (IEETAB=10)
22092 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
22093 **PHOJET110
22094 C  model switches and parameters
22095       CHARACTER*8 MDLNA
22096       INTEGER ISWMDL,IPAMDL
22097       DOUBLE PRECISION PARMDL
22098       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
22099 C  energy-interpolation table
22100       INTEGER IEETA2
22101       PARAMETER ( IEETA2 = 20 )
22102       INTEGER ISIMAX
22103       DOUBLE PRECISION SIGTAB,SIGECM
22104       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
22105 **
22106
22107 C     PARAMETER (NPOINT=80)
22108       PARAMETER (NPOINT=16)
22109       DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22110
22111       STOT = ZERO
22112       SINE = ZERO
22113       SDIR = ZERO
22114
22115       W2 = ECMI**2
22116       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
22117      &   W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
22118       Q2 = Q2I
22119       X  = XI
22120 * photoprod.
22121       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22122          Q2 = 0.0001D0
22123          X  = Q2/(W2+Q2-AAM(1)**2)
22124 * DIS
22125       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
22126          X  = Q2/(W2+Q2-AAM(1)**2)
22127       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22128          Q2 = (W2-AAM(1)**2)*X/(ONE-X)
22129       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
22130          W2 = Q2*(ONE-X)/X+AAM(1)**2
22131       ELSE
22132          WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
22133          STOP
22134       ENDIF
22135       ECM = SQRT(W2)
22136
22137       IF (MODEGA.EQ.1) THEN
22138          SCALE = SQRT(Q2)
22139          CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
22140      &                                                       IDPDF)
22141 C        W = SQRT(W2)
22142 C        ALLMF2 = PHO_ALLM97(Q2,W)
22143 C        write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22144          STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22145          SINE = ZERO
22146          SDIR = ZERO
22147       ELSEIF (MODEGA.EQ.2) THEN
22148          IF (INTRGE(1).EQ.1) THEN
22149             AMLO2 = (3.0D0*AAM(13))**2
22150          ELSEIF (INTRGE(1).EQ.2) THEN
22151             AMLO2 = AAM(33)**2
22152          ELSE
22153             AMLO2 = AAM(96)**2
22154          ENDIF
22155          IF (INTRGE(2).EQ.1) THEN
22156             AMHI2 = W2/TWO
22157          ELSEIF (INTRGE(2).EQ.2) THEN
22158             AMHI2 = W2/4.0D0
22159          ELSE
22160             AMHI2 = W2
22161          ENDIF
22162          AMHI20 = (ECM-AAM(1))**2
22163          IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22164          XAMLO  = LOG( AMLO2+Q2 )
22165          XAMHI  = LOG( AMHI2+Q2 )
22166 **PHOJET105a
22167 C        CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
22168 **PHOJET112
22169          CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
22170 **
22171          SUM  = ZERO
22172          DO 1 J=1,NPOINT
22173             AM2 = EXP(ABSZX(J))-Q2
22174             IF (AM2.LT.16.0D0) THEN
22175                R = TWO
22176             ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
22177                R = 10.0D0/3.0D0
22178             ELSE
22179                R = 11.0D0/3.0D0
22180             ENDIF
22181 C           FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
22182             FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
22183      &            * (ONE+EPSPOL*Q2/AM2)
22184             SUM = SUM+WEIGHT(J)*FAC
22185     1    CONTINUE
22186          SINE = SUM
22187          SDIR = DT_SIGVP(X,Q2)
22188          STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
22189          SDIR = SDIR/(0.588D0+RL2+Q2)
22190 C        STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2)
22191       ELSEIF (MODEGA.EQ.3) THEN
22192          CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM)
22193       ELSEIF (MODEGA.EQ.4) THEN
22194 *  load cross sections from PHOJET interpolation table
22195          IP = 1
22196          IF(ECM.LE.SIGECM(IP,1)) THEN
22197            I1 = 1
22198            I2 = 1
22199          ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
22200            DO 2 I=2,ISIMAX
22201               IF (ECM.LE.SIGECM(IP,I)) GOTO 3
22202     2      CONTINUE
22203     3      CONTINUE
22204            I1 = I-1
22205            I2 = I
22206          ELSE
22207            WRITE(LOUT,'(/1X,A,2E12.3)')
22208      &       'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
22209            I1 = ISIMAX
22210            I2 = ISIMAX
22211          ENDIF
22212          FAC2 = ZERO
22213          IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
22214      &                       /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
22215          FAC1 = ONE-FAC2
22216 *  cross section dependence on photon virtuality
22217          FSUP1 = ZERO
22218          DO 4 I=1,3
22219             FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
22220      &                                /(1.D0+Q2/PARMDL(30+I))**2
22221     4    CONTINUE
22222          FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
22223          FAC1  = FAC1*FSUP1
22224          FAC2  = FAC2*FSUP1
22225          FSUP2 = 1.0D0
22226          STOT  = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
22227          SINE  = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
22228          SDIR  = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
22229 **re:
22230          STOT  = STOT-SDIR
22231 **
22232          SDIR  = SDIR/(FSUP1*FSUP2)
22233 **re:
22234          STOT  = STOT+SDIR
22235 **
22236       ENDIF
22237
22238       RETURN
22239       END
22240
22241 *$ CREATE DT_SIGVEL.FOR
22242 *COPY DT_SIGVEL
22243 *
22244 *===sigvel=============================================================*
22245 *
22246       SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
22247
22248 ************************************************************************
22249 * Cross section for elastic vector meson production                    *
22250 * This version dated 10.05.96 is written by S. Roesler                 *
22251 ************************************************************************
22252
22253       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22254       SAVE
22255       PARAMETER ( LINP = 10 ,
22256      &            LOUT = 6 ,
22257      &            LDAT = 9 )
22258       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22259       PARAMETER (TWOPI  = 6.283185307179586476925286766559D+00,
22260      &           PI     = TWOPI/TWO,
22261      &           GEV2MB = 0.38938D0,
22262      &           ALPHEM = ONE/137.0D0)
22263
22264 * particle properties (BAMJET index convention)
22265       CHARACTER*8  ANAME
22266       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22267      &                IICH(210),IIBAR(210),K1(210),K2(210)
22268 * VDM parameter for photon-nucleus interactions
22269       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22270
22271       W2 = ECMI**2
22272       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
22273      &   W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
22274       Q2 = Q2I
22275       X  = XI
22276 * photoprod.
22277       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22278          Q2 = 0.0001D0
22279          X  = Q2/(W2+Q2-AAM(1)**2)
22280 * DIS
22281       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
22282          X  = Q2/(W2+Q2-AAM(1)**2)
22283       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22284          Q2 = (W2-AAM(1)**2)*X/(ONE-X)
22285       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
22286          W2 = Q2*(ONE-X)/X+AAM(1)**2
22287       ELSE
22288          WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
22289          STOP
22290       ENDIF
22291       ECM = SQRT(W2)
22292
22293       AMV  = AAM(IDXV)
22294       AMV2 = AMV**2
22295
22296       BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
22297      &        +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
22298       ROSH   = 0.1D0
22299       STOVP  = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
22300       SELVP  = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
22301
22302       IF (IDXV.EQ.33) THEN
22303          COUPL = 0.00365D0
22304       ELSE
22305          STOP
22306       ENDIF
22307       SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
22308       SIG2 = SELVP
22309       SVEL  = COUPL * (AMV2/(AMV2+Q2))**2
22310      &              * (ONE+EPSPOL*Q2/AMV2) * SELVP
22311
22312       RETURN
22313       END
22314
22315 *$ CREATE DT_SIGVP.FOR
22316 *COPY DT_SIGVP
22317 *
22318 *===sigvp==============================================================*
22319 *
22320       DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
22321
22322 ************************************************************************
22323 * sigma_Vp                                                             *
22324 ************************************************************************
22325
22326       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22327       SAVE
22328
22329       PARAMETER ( LINP = 10 ,
22330      &            LOUT = 6 ,
22331      &            LDAT = 9 )
22332       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22333       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22334      &           PI    = TWOPI/TWO,
22335      &           GEV2MB = 0.38938D0,
22336      &           AMPROT = 0.938D0,
22337      &           ALPHEM = ONE/137.0D0)
22338 * VDM parameter for photon-nucleus interactions
22339       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22340
22341       X  = XI
22342       Q2 = Q2I
22343       IF (XI.LE.ZERO)  X  = 0.0001D0
22344       IF (Q2I.LE.ZERO) Q2 = 0.0001D0
22345
22346       ECM    = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
22347
22348       SCALE = SQRT(Q2)
22349       IF (MODEGA.EQ.1) THEN
22350          CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
22351      &                                                       IDPDF)
22352 C        W = ECM
22353 C        ALLMF2 = PHO_ALLM97(Q2,W)
22354 C        write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22355 C        STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22356 C        DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
22357          DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB
22358       ELSEIF (MODEGA.EQ.4) THEN
22359          CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3)
22360 C        F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
22361          DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
22362       ELSE
22363          STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
22364       ENDIF
22365
22366       RETURN
22367
22368       END
22369
22370 *$ CREATE DT_RRM2.FOR
22371 *COPY DT_RRM2
22372 *
22373 *===RRM2===============================================================*
22374 *
22375       DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
22376
22377       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22378       SAVE
22379       PARAMETER ( LINP = 10 ,
22380      &            LOUT = 6 ,
22381      &            LDAT = 9 )
22382       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22383       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22384      &           PI    = TWOPI/TWO,
22385      &           GEV2MB = 0.38938D0)
22386
22387 * particle properties (BAMJET index convention)
22388       CHARACTER*8  ANAME
22389       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22390      &                IICH(210),IIBAR(210),K1(210),K2(210)
22391 * VDM parameter for photon-nucleus interactions
22392       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22393
22394       S   = Q2*(ONE-X)/X+AAM(1)**2
22395       ECM = SQRT(S)
22396
22397       IF (INTRGE(1).EQ.1) THEN
22398          AMLO2 = (3.0D0*AAM(13))**2
22399       ELSEIF (INTRGE(1).EQ.2) THEN
22400          AMLO2 = AAM(33)**2
22401       ELSE
22402          AMLO2 = AAM(96)**2
22403       ENDIF
22404       IF (INTRGE(2).EQ.1) THEN
22405          AMHI2 = S/TWO
22406       ELSEIF (INTRGE(2).EQ.2) THEN
22407          AMHI2 = S/4.0D0
22408       ELSE
22409          AMHI2 = S
22410       ENDIF
22411       AMHI20 = (ECM-AAM(1))**2
22412       IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22413
22414       AM1C2 = 16.0D0
22415       AM2C2 = 121.0D0
22416       IF (AMHI2.LE.AM1C2) THEN
22417          DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2)
22418       ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22419          DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22420      &          10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2)
22421       ELSE
22422          DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22423      &          10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+
22424      &          11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2)
22425       ENDIF
22426
22427       RETURN
22428       END
22429
22430 *$ CREATE DT_RM2.FOR
22431 *COPY DT_RM2
22432 *
22433 *===RM2================================================================*
22434 *
22435       DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
22436
22437       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22438       SAVE
22439       PARAMETER ( LINP = 10 ,
22440      &            LOUT = 6 ,
22441      &            LDAT = 9 )
22442       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22443       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22444      &           PI    = TWOPI/TWO,
22445      &           GEV2MB = 0.38938D0)
22446 * VDM parameter for photon-nucleus interactions
22447       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22448
22449       IF (RL2.LE.ZERO) THEN
22450          DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) -
22451      &        (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2))
22452      &         +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2))
22453       ELSE
22454          TMPMLO = LOG(ONE+RL2/(AMLO2+Q2))
22455          TMPMHI = LOG(ONE+RL2/(AMHI2+Q2))
22456          DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI
22457      &       -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO)
22458      &       +EPSPOL*(
22459      &         -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
22460      &       -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
22461       ENDIF
22462
22463       RETURN
22464       END
22465
22466 *$ CREATE DT_SAM2.FOR
22467 *COPY DT_SAM2
22468 *
22469 *===SAM2===============================================================*
22470 *
22471       DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
22472
22473       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22474       SAVE
22475       PARAMETER ( LINP = 10 ,
22476      &            LOUT = 6 ,
22477      &            LDAT = 9 )
22478       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
22479      &           TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0)
22480       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22481      &           PI    = TWOPI/TWO,
22482      &           GEV2MB = 0.38938D0)
22483
22484 * particle properties (BAMJET index convention)
22485       CHARACTER*8  ANAME
22486       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22487      &                IICH(210),IIBAR(210),K1(210),K2(210)
22488 * VDM parameter for photon-nucleus interactions
22489       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22490
22491       S = ECM**2
22492       IF (INTRGE(1).EQ.1) THEN
22493          AMLO2 = (3.0D0*AAM(13))**2
22494       ELSEIF (INTRGE(1).EQ.2) THEN
22495          AMLO2 = AAM(33)**2
22496       ELSE
22497          AMLO2 = AAM(96)**2
22498       ENDIF
22499       IF (INTRGE(2).EQ.1) THEN
22500          AMHI2 = S/TWO
22501       ELSEIF (INTRGE(2).EQ.2) THEN
22502          AMHI2 = S/4.0D0
22503       ELSE
22504          AMHI2 = S
22505       ENDIF
22506       AMHI20 = (ECM-AAM(1))**2
22507       IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22508
22509       AM1C2 = 16.0D0
22510       AM2C2 = 121.0D0
22511       YLO   = LOG(AMLO2+Q2)
22512       YC1   = LOG(AM1C2+Q2)
22513       YC2   = LOG(AM2C2+Q2)
22514       YHI   = LOG(AMHI2+Q2)
22515       IF (AMHI2.LE.AM1C2) THEN
22516          FACHI = TWO
22517       ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22518          FACHI = TENTRD
22519       ELSE
22520          FACHI = ELVTRD
22521       ENDIF
22522
22523     1 CONTINUE
22524       YSAM2  = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
22525       IF (YSAM2.LE.YC1) THEN
22526          FAC = TWO
22527       ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
22528          FAC = TENTRD
22529       ELSE
22530          FAC = ELVTRD
22531       ENDIF
22532       WEIGMX = FACHI*(ONE-Q2*EXP(  -YHI))
22533       XSAM2  = FAC  *(ONE-Q2*EXP(-YSAM2))
22534       IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
22535
22536       DT_SAM2   = EXP(YSAM2)-Q2
22537
22538       RETURN
22539       END
22540
22541 *$ CREATE DT_CKMT.FOR
22542 *COPY DT_CKMT
22543 *
22544 *===ckmt===============================================================*
22545 *
22546       SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
22547      &                F2,IPAR)
22548
22549 ************************************************************************
22550 * This version dated 31.01.96 is written by S. Roesler                 *
22551 ************************************************************************
22552
22553       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22554       SAVE
22555       PARAMETER ( LINP = 10 ,
22556      &            LOUT = 6 ,
22557      &            LDAT = 9 )
22558       PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
22559
22560       PARAMETER (Q02 = 2.0D0,
22561      &           DQ2 = 10.05D0,
22562      &           Q12 = Q02+DQ2)
22563
22564       DIMENSION PD(-6:6),SEA(3),VAL(2)
22565
22566       CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR)
22567       CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR)
22568       ADQ2 = LOG10(Q12)-LOG10(Q02)
22569       F2P  = (F2Q1-F2Q0)/ADQ2
22570       CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0)
22571       CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1)
22572       F2PP = (F2PQ1-F2PQ0)/ADQ2
22573       FX   = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02
22574
22575       Q2     = MAX(SCALE**2.0D0,TINY10)
22576       SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2
22577       IF (Q2.LT.Q02) THEN
22578          CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22579          UPV  = VAL(1)
22580          DNV  = VAL(2)
22581          USEA = SEA(1)
22582          DSEA = SEA(2)
22583          STR  = SEA(3)
22584          CHM  = 0.0D0
22585          BOT  = 0.0D0
22586          TOP  = 0.0D0
22587          GL   = GLU
22588       ELSE
22589          CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
22590          F2 = F2*SMOOTH
22591          UPV  = PD(2)-PD(3)
22592          DNV  = PD(1)-PD(3)
22593          USEA = PD(3)
22594          DSEA = PD(3)
22595          STR  = PD(3)
22596          CHM  = PD(4)
22597          BOT  = PD(5)
22598          TOP  = PD(6)
22599          GL   = PD(0)
22600 C        UPV  = UPV*SMOOTH
22601 C        DNV  = DNV*SMOOTH
22602 C        USEA = USEA*SMOOTH
22603 C        DSEA = DSEA*SMOOTH
22604 C        STR  = STR*SMOOTH
22605 C        CHM  = CHM*SMOOTH
22606 C        GL   = GL*SMOOTH
22607       ENDIF
22608
22609       RETURN
22610       END
22611 C
22612
22613 *$ CREATE DT_CKMTX.FOR
22614 *COPY DT_CKMTX
22615       SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
22616 C**********************************************************************
22617 C
22618 C     PDF based on Regge theory, evolved with .... by ....
22619 C
22620 C     input: IPAR     2212   proton (not installed)
22621 C                       45   Pomeron
22622 C                      100   Deuteron
22623 C
22624 C     output: PD(-6:6) x*f(x)  parton distribution functions
22625 C            (PDFLIB convention: d = PD(1), u = PD(2) )
22626 C
22627 C**********************************************************************
22628
22629       SAVE
22630       DOUBLE PRECISION  X,SCALE2,PD(-6:6),CDN,CUP,F2
22631       PARAMETER ( LINP = 10 ,
22632      &            LOUT = 6 ,
22633      &            LDAT = 9 )
22634       DIMENSION QQ(7)
22635 C
22636       Q2=SNGL(SCALE2)
22637       Q1S=Q2
22638       XX=SNGL(X)
22639 C  QCD lambda for evolution
22640       OWLAM = 0.23D0
22641       OWLAM2=OWLAM**2
22642 C  Q0**2 for evolution
22643       Q02 = 2.D0
22644 C
22645 C
22646 C  the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
22647 C                        q(6)=x*charm, q(7)=x*gluon
22648 C
22649       SB=0.
22650       IF(Q2-Q02) 1,1,2
22651     2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
22652     1 CONTINUE
22653       IF(IPAR.EQ.2212) THEN
22654         CALL DT_CKMTPR(1,0,XX,SB,QQ(1))
22655         CALL DT_CKMTPR(2,0,XX,SB,QQ(2))
22656         CALL DT_CKMTPR(3,0,XX,SB,QQ(3))
22657         CALL DT_CKMTPR(4,0,XX,SB,QQ(4))
22658         CALL DT_CKMTPR(5,0,XX,SB,QQ(5))
22659         CALL DT_CKMTPR(8,0,XX,SB,QQ(6))
22660         CALL DT_CKMTPR(7,0,XX,SB,QQ(7))
22661 C     ELSEIF (IPAR.EQ.45) THEN
22662 C       CALL CKMTPO(1,0,XX,SB,QQ(1))
22663 C       CALL CKMTPO(2,0,XX,SB,QQ(2))
22664 C       CALL CKMTPO(3,0,XX,SB,QQ(3))
22665 C       CALL CKMTPO(4,0,XX,SB,QQ(4))
22666 C       CALL CKMTPO(5,0,XX,SB,QQ(5))
22667 C       CALL CKMTPO(8,0,XX,SB,QQ(6))
22668 C       CALL CKMTPO(7,0,XX,SB,QQ(7))
22669       ELSEIF (IPAR.EQ.100) THEN
22670         CALL DT_CKMTDE(1,0,XX,SB,QQ(1))
22671         CALL DT_CKMTDE(2,0,XX,SB,QQ(2))
22672         CALL DT_CKMTDE(3,0,XX,SB,QQ(3))
22673         CALL DT_CKMTDE(4,0,XX,SB,QQ(4))
22674         CALL DT_CKMTDE(5,0,XX,SB,QQ(5))
22675         CALL DT_CKMTDE(8,0,XX,SB,QQ(6))
22676         CALL DT_CKMTDE(7,0,XX,SB,QQ(7))
22677       ELSE
22678         WRITE(LOUT,'(1X,A,I4,A)')
22679      &     'CKMTX:   IPAR =',IPAR,' not implemented!'
22680         STOP
22681       ENDIF
22682 C
22683       PD(-6) = 0.D0
22684       PD(-5) = 0.D0
22685       PD(-4) = DBLE(QQ(6))
22686       PD(-3) = DBLE(QQ(3))
22687       PD(-2) = DBLE(QQ(4))
22688       PD(-1) = DBLE(QQ(5))
22689       PD(0)  = DBLE(QQ(7))
22690       PD(1)  = DBLE(QQ(2))
22691       PD(2)  = DBLE(QQ(1))
22692       PD(3)  = DBLE(QQ(3))
22693       PD(4)  = DBLE(QQ(6))
22694       PD(5)  = 0.D0
22695       PD(6)  = 0.D0
22696       IF(IPAR.EQ.45) THEN
22697         CDN = (PD(1)-PD(-1))/2.D0
22698         CUP = (PD(2)-PD(-2))/2.D0
22699         PD(-1) = PD(-1) + CDN
22700         PD(-2) = PD(-2) + CUP
22701         PD(1) = PD(-1)
22702         PD(2) = PD(-2)
22703       ENDIF
22704       F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+
22705      &     1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+
22706      &     1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4))
22707       END
22708 C
22709
22710 *$ CREATE DT_PDF0.FOR
22711 *COPY DT_PDF0
22712 *
22713 *===pdf0===============================================================*
22714 *
22715       SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22716
22717 ************************************************************************
22718 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2       *
22719 * an F_2-ansatz given in Capella et al. PLB 337(1994)358.              *
22720 *                   IPAR  = 2212   proton                              *
22721 *                         =  100   deuteron                            *
22722 * This version dated 31.01.96 is written by S. Roesler                 *
22723 ************************************************************************
22724
22725       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22726       SAVE
22727       PARAMETER ( LINP = 10 ,
22728      &            LOUT = 6 ,
22729      &            LDAT = 9 )
22730       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22731
22732       PARAMETER (
22733      &              AA     = 0.1502D0,
22734      &              BBDEU  = 1.2D0,
22735      &              BUD    = 0.754D0,
22736      &              BDD    = 0.4495D0,
22737      &              BUP    = 1.2064D0,
22738      &              BDP    = 0.1798D0,
22739      &              DELTA0 = 0.07684D0,
22740      &              D      = 1.117D0,
22741      &              C      = 3.5489D0,
22742      &              A      = 0.2631D0,
22743      &              B      = 0.6452D0,
22744      &              ALPHAR = 0.415D0,
22745      &              E      = 0.1D0
22746      &          )
22747
22748       PARAMETER (NPOINT=16)
22749 C     DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22750       DIMENSION SEA(3),VAL(2)
22751
22752       DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22753       AN    = 1.5D0*(1.0D0+Q2/(Q2+C))
22754 * proton, deuteron
22755       IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22756          CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22757          SEA(1) = 0.75D0*SEA0
22758          SEA(2) = SEA(1)
22759          SEA(3) = SEA(1)
22760          VAL(1) = 9.0D0/4.0D0*VALU0
22761          VAL(2) = 9.0D0*VALD0
22762          GLU0   = SEA(1)/(1.0D0-X)
22763          F2     = SEA0+VALU0+VALD0
22764          F2PDF  = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+
22765      &            1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+
22766      &            1.0D0/9.0D0*(2.0D0*SEA(3))
22767          IF (ABS(F2-F2PDF).GT.TINY9) THEN
22768             WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF
22769             STOP
22770          ENDIF
22771 **PHOJET105a
22772 C        CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22773 **PHOJET112
22774 C        CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22775 **
22776 C        SUMQ = ZERO
22777 C        SUMG = ZERO
22778 C        DO 1 J=1,NPOINT
22779 C           CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
22780 C           VALU0 = 9.0D0/4.0D0*VALU0
22781 C           VALD0 = 9.0D0*VALD0
22782 C           SEA0  = 0.75D0*SEA0
22783 C           SUMQ  = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
22784 C           SUMG  = SUMG+ (SEA0/(1.0D0-ABSZX(J)))  *WEIGHT(J)
22785 C   1    CONTINUE
22786 C        GLU = GLU0*(1.0D0-SUMQ)/SUMG
22787       ELSE
22788          WRITE(LOUT,'(1X,A,I4,A)')
22789      &      'PDF0:   IPAR =',IPAR,' not implemented!'
22790          STOP
22791       ENDIF
22792
22793       RETURN
22794       END
22795
22796 *$ CREATE DT_CKMTQ0.FOR
22797 *COPY DT_CKMTQ0
22798 *
22799 *===ckmtq0=============================================================*
22800 *
22801       SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22802
22803 ************************************************************************
22804 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2       *
22805 * an F_2-ansatz given in Capella et al. PLB 337(1994)358.              *
22806 *                   IPAR  = 2212   proton                              *
22807 *                         =  100   deuteron                            *
22808 * This version dated 31.01.96 is written by S. Roesler                 *
22809 ************************************************************************
22810
22811       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22812       SAVE
22813       PARAMETER ( LINP = 10 ,
22814      &            LOUT = 6 ,
22815      &            LDAT = 9 )
22816       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22817
22818       PARAMETER (
22819      &              AA     = 0.1502D0,
22820      &              BBDEU  = 1.2D0,
22821      &              BUD    = 0.754D0,
22822      &              BDD    = 0.4495D0,
22823      &              BUP    = 1.2064D0,
22824      &              BDP    = 0.1798D0,
22825      &              DELTA0 = 0.07684D0,
22826      &              D      = 1.117D0,
22827      &              C      = 3.5489D0,
22828      &              A      = 0.2631D0,
22829      &              B      = 0.6452D0,
22830      &              ALPHAR = 0.415D0,
22831      &              E      = 0.1D0
22832      &          )
22833
22834       DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22835       AN    = 1.5D0*(1.0D0+Q2/(Q2+C))
22836 * proton, deuteron
22837       IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22838          IF (IPAR.EQ.2212) THEN
22839             BU = BUP
22840             BD = BDP
22841          ELSE
22842             BU = BUD
22843             BD = BDD
22844          ENDIF
22845          SEA0  = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)*
22846      &          (Q2/(Q2+A))**(1.0D0+DELTA)
22847          VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN*
22848      &           (Q2/(Q2+B))**(ALPHAR)
22849          VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)*
22850      &           (Q2/(Q2+B))**(ALPHAR)
22851       ELSE
22852          WRITE(LOUT,'(1X,A,I4,A)')
22853      &      'CKMTQ0: IPAR =',IPAR,' not implemented!'
22854          STOP
22855       ENDIF
22856       RETURN
22857       END
22858 C
22859 C
22860
22861 *$ CREATE DT_CKMTDE.FOR
22862 *COPY DT_CKMTDE
22863       SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
22864 C
22865 C**********************************************************************
22866 C    Deuteron - PDFs
22867 C    I   = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
22868 C    ANS = PDF(I)
22869 C    This version by S. Roesler, 30.01.96
22870 C**********************************************************************
22871
22872       SAVE
22873       DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
22874       EQUIVALENCE (GF(1,1,1),DL(1))
22875       DATA DELTA/.13/
22876 C
22877       DATA (DL(K),K=    1,   85) /
22878      &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00,
22879      &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00,
22880      &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01,
22881      &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00,
22882      &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00,
22883      &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00,
22884      &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00,
22885      &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00,
22886      &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00,
22887      &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00,
22888      &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02,
22889      &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01,
22890      &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01,
22891      &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01,
22892      &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01,
22893      &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01,
22894      &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/
22895       DATA (DL(K),K=   86,  170) /
22896      &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01,
22897      &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02,
22898      &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01,
22899      &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01,
22900      &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01,
22901      &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01,
22902      &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01,
22903      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22904      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22905      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22906      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22907      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22908      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22909      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22910      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22911      &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00,
22912      &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/
22913       DATA (DL(K),K=  171,  255) /
22914      &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01,
22915      &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00,
22916      &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00,
22917      &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00,
22918      &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00,
22919      &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00,
22920      &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00,
22921      &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00,
22922      &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02,
22923      &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00,
22924      &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00,
22925      &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00,
22926      &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00,
22927      &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00,
22928      &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01,
22929      &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01,
22930      &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/
22931       DATA (DL(K),K=  256,  340) /
22932      &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01,
22933      &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01,
22934      &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01,
22935      &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01,
22936      &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01,
22937      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22938      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22939      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22940      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22941      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22942      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22943      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22944      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22945      &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00,
22946      &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00,
22947      &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01,
22948      &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/
22949       DATA (DL(K),K=  341,  425) /
22950      &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00,
22951      &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00,
22952      &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00,
22953      &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00,
22954      &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00,
22955      &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00,
22956      &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02,
22957      &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00,
22958      &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00,
22959      &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00,
22960      &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00,
22961      &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00,
22962      &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00,
22963      &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01,
22964      &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02,
22965      &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00,
22966      &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/
22967       DATA (DL(K),K=  426,  510) /
22968      &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00,
22969      &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01,
22970      &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00,
22971      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22972      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22973      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22974      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22975      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22976      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22977      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22978      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22979      &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00,
22980      &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00,
22981      &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01,
22982      &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00,
22983      &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00,
22984      &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/
22985       DATA (DL(K),K=  511,  595) /
22986      &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00,
22987      &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00,
22988      &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00,
22989      &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00,
22990      &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01,
22991      &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00,
22992      &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00,
22993      &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00,
22994      &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00,
22995      &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00,
22996      &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00,
22997      &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00,
22998      &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01,
22999      &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00,
23000      &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00,
23001      &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00,
23002      &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/
23003       DATA (DL(K),K=  596,  680) /
23004      &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00,
23005      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23006      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23007      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23008      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23009      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23010      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23011      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23012      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23013      &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23014      &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00,
23015      &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01,
23016      &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00,
23017      &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00,
23018      &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00,
23019      &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00,
23020      &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/
23021       DATA (DL(K),K=  681,  765) /
23022      &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00,
23023      &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00,
23024      &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01,
23025      &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00,
23026      &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00,
23027      &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00,
23028      &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00,
23029      &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00,
23030      &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00,
23031      &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00,
23032      &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01,
23033      &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00,
23034      &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00,
23035      &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00,
23036      &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00,
23037      &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00,
23038      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23039       DATA (DL(K),K=  766,  850) /
23040      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23041      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23042      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23043      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23044      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23045      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23046      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23047      &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23048      &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00,
23049      &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01,
23050      &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00,
23051      &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00,
23052      &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00,
23053      &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00,
23054      &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01,
23055      &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00,
23056      &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/
23057       DATA (DL(K),K=  851,  935) /
23058      &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01,
23059      &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00,
23060      &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00,
23061      &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00,
23062      &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00,
23063      &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00,
23064      &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00,
23065      &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00,
23066      &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01,
23067      &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00,
23068      &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00,
23069      &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00,
23070      &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00,
23071      &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00,
23072      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23073      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23074      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23075       DATA (DL(K),K=  936, 1020) /
23076      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23077      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23078      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23079      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23080      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23081      &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23082      &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00,
23083      &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01,
23084      &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00,
23085      &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00,
23086      &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00,
23087      &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00,
23088      &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01,
23089      &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00,
23090      &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00,
23091      &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01,
23092      &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/
23093       DATA (DL(K),K= 1021, 1105) /
23094      &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00,
23095      &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00,
23096      &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00,
23097      &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01,
23098      &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00,
23099      &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00,
23100      &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01,
23101      &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00,
23102      &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00,
23103      &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00,
23104      &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00,
23105      &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01,
23106      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23107      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23108      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23109      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23110      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23111       DATA (DL(K),K= 1106, 1190) /
23112      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23113      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23114      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23115      &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01,
23116      &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00,
23117      &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01,
23118      &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01,
23119      &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00,
23120      &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01,
23121      &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01,
23122      &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01,
23123      &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01,
23124      &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00,
23125      &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01,
23126      &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01,
23127      &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00,
23128      &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/
23129       DATA (DL(K),K= 1191, 1275) /
23130      &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01,
23131      &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01,
23132      &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01,
23133      &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00,
23134      &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00,
23135      &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01,
23136      &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00,
23137      &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01,
23138      &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01,
23139      &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01,
23140      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23141      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23142      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23143      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23144      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23145      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23146      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23147       DATA (DL(K),K= 1276, 1360) /
23148      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23149      &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01,
23150      &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00,
23151      &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00,
23152      &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01,
23153      &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00,
23154      &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01,
23155      &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01,
23156      &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02,
23157      &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01,
23158      &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00,
23159      &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00,
23160      &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01,
23161      &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00,
23162      &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01,
23163      &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01,
23164      &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/
23165       DATA (DL(K),K= 1361, 1445) /
23166      &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01,
23167      &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00,
23168      &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00,
23169      &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01,
23170      &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00,
23171      &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01,
23172      &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01,
23173      &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01,
23174      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23175      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23176      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23177      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23178      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23179      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23180      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23181      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23182      &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/
23183       DATA (DL(K),K= 1446, 1530) /
23184      &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00,
23185      &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00,
23186      &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01,
23187      &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00,
23188      &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01,
23189      &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01,
23190      &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02,
23191      &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01,
23192      &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00,
23193      &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00,
23194      &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01,
23195      &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00,
23196      &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01,
23197      &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01,
23198      &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02,
23199      &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01,
23200      &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/
23201       DATA (DL(K),K= 1531, 1615) /
23202      &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00,
23203      &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01,
23204      &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00,
23205      &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01,
23206      &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01,
23207      &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02,
23208      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23209      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23210      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23211      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23212      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23213      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23214      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23215      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23216      &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01,
23217      &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00,
23218      &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/
23219       DATA (DL(K),K= 1616, 1700) /
23220      &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01,
23221      &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00,
23222      &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01,
23223      &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01,
23224      &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02,
23225      &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01,
23226      &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00,
23227      &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00,
23228      &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01,
23229      &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00,
23230      &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01,
23231      &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01,
23232      &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02,
23233      &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01,
23234      &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00,
23235      &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00,
23236      &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/
23237       DATA (DL(K),K= 1701, 1785) /
23238      &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00,
23239      &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02,
23240      &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02,
23241      &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02,
23242      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23243      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23244      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23245      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23246      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23247      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23248      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23249      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23250      &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01,
23251      &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00,
23252      &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00,
23253      &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01,
23254      &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/
23255       DATA (DL(K),K= 1786, 1870) /
23256      &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01,
23257      &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01,
23258      &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02,
23259      &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02,
23260      &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00,
23261      &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00,
23262      &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02,
23263      &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00,
23264      &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02,
23265      &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02,
23266      &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02,
23267      &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02,
23268      &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00,
23269      &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01,
23270      &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02,
23271      &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00,
23272      &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/
23273       DATA (DL(K),K= 1871, 1955) /
23274      &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02,
23275      &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02,
23276      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23277      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23278      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23279      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23280      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23281      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23282      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23283      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23284      &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02,
23285      &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00,
23286      &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00,
23287      &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02,
23288      &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00,
23289      &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02,
23290      &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/
23291       DATA (DL(K),K= 1956, 2040) /
23292      &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03,
23293      &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02,
23294      &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00,
23295      &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01,
23296      &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02,
23297      &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00,
23298      &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02,
23299      &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02,
23300      &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03,
23301      &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02,
23302      &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00,
23303      &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01,
23304      &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02,
23305      &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00,
23306      &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02,
23307      &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02,
23308      &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/
23309       DATA (DL(K),K= 2041, 2125) /
23310      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23311      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23312      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23313      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23314      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23315      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23316      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23317      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23318      &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02,
23319      &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00,
23320      &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00,
23321      &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02,
23322      &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00,
23323      &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02,
23324      &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02,
23325      &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03,
23326      &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/
23327       DATA (DL(K),K= 2126, 2210) /
23328      &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00,
23329      &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01,
23330      &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02,
23331      &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00,
23332      &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02,
23333      &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02,
23334      &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03,
23335      &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02,
23336      &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00,
23337      &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01,
23338      &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02,
23339      &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00,
23340      &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02,
23341      &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02,
23342      &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03,
23343      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23344      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23345       DATA (DL(K),K= 2211, 2295) /
23346      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23347      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23348      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23349      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23350      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23351      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23352      &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23353      &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00,
23354      &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01,
23355      &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02,
23356      &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00,
23357      &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02,
23358      &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02,
23359      &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03,
23360      &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02,
23361      &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00,
23362      &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/
23363       DATA (DL(K),K= 2296, 2380) /
23364      &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02,
23365      &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00,
23366      &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02,
23367      &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02,
23368      &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03,
23369      &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03,
23370      &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00,
23371      &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01,
23372      &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03,
23373      &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01,
23374      &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03,
23375      &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03,
23376      &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03,
23377      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23378      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23379      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23380      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23381       DATA (DL(K),K= 2381, 2465) /
23382      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23383      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23384      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23385      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23386      &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23387      &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00,
23388      &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01,
23389      &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02,
23390      &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00,
23391      &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02,
23392      &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02,
23393      &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04,
23394      &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03,
23395      &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00,
23396      &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01,
23397      &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03,
23398      &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/
23399       DATA (DL(K),K= 2466, 2550) /
23400      &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03,
23401      &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03,
23402      &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03,
23403      &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03,
23404      &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01,
23405      &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02,
23406      &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03,
23407      &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01,
23408      &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03,
23409      &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03,
23410      &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04,
23411      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23412      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23413      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23414      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23415      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23416      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23417       DATA (DL(K),K= 2551, 2635) /
23418      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23419      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23420      &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03,
23421      &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00,
23422      &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01,
23423      &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03,
23424      &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00,
23425      &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03,
23426      &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03,
23427      &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04,
23428      &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03,
23429      &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00,
23430      &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01,
23431      &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03,
23432      &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01,
23433      &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03,
23434      &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/
23435       DATA (DL(K),K= 2636, 2720) /
23436      &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04,
23437      &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03,
23438      &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01,
23439      &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02,
23440      &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03,
23441      &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01,
23442      &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03,
23443      &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03,
23444      &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04,
23445      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23446      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23447      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23448      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23449      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23450      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23451      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23452      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23453       DATA (DL(K),K= 2721, 2805) /
23454      &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03,
23455      &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00,
23456      &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01,
23457      &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03,
23458      &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00,
23459      &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03,
23460      &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03,
23461      &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04,
23462      &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03,
23463      &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01,
23464      &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02,
23465      &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03,
23466      &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01,
23467      &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03,
23468      &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03,
23469      &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04,
23470      &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/
23471       DATA (DL(K),K= 2806, 2890) /
23472      &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01,
23473      &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02,
23474      &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04,
23475      &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01,
23476      &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04,
23477      &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04,
23478      &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04,
23479      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23480      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23481      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23482      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23483      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23484      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23485      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23486      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23487      &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03,
23488      &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/
23489       DATA (DL(K),K= 2891, 2975) /
23490      &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02,
23491      &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03,
23492      &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01,
23493      &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03,
23494      &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04,
23495      &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05,
23496      &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04,
23497      &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01,
23498      &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02,
23499      &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04,
23500      &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01,
23501      &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04,
23502      &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04,
23503      &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05,
23504      &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04,
23505      &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01,
23506      &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/
23507       DATA (DL(K),K= 2976, 3060) /
23508      &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04,
23509      &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01,
23510      &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04,
23511      &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04,
23512      &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05,
23513      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23514      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23515      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23516      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23517      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23518      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23519      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23520      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23521      &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04,
23522      &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01,
23523      &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02,
23524      &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/
23525       DATA (DL(K),K= 3061, 3145) /
23526      &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01,
23527      &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04,
23528      &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04,
23529      &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06,
23530      &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04,
23531      &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01,
23532      &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02,
23533      &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04,
23534      &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01,
23535      &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04,
23536      &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04,
23537      &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05,
23538      &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04,
23539      &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01,
23540      &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03,
23541      &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04,
23542      &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/
23543       DATA (DL(K),K= 3146, 3230) /
23544      &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05,
23545      &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05,
23546      &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05,
23547      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23548      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23549      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23550      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23551      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23552      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23553      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23554      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23555      &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04,
23556      &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01,
23557      &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02,
23558      &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04,
23559      &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01,
23560      &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/
23561       DATA (DL(K),K= 3231, 3315) /
23562      &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05,
23563      &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06,
23564      &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05,
23565      &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01,
23566      &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03,
23567      &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05,
23568      &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01,
23569      &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05,
23570      &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05,
23571      &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06,
23572      &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05,
23573      &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02,
23574      &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03,
23575      &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05,
23576      &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02,
23577      &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05,
23578      &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/
23579       DATA (DL(K),K= 3316, 3400) /
23580      &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07,
23581      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23582      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23583      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23584      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23585      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23586      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23587      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23588      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23589      &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05,
23590      &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01,
23591      &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03,
23592      &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05,
23593      &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01,
23594      &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05,
23595      &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05,
23596      &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/
23597       DATA (DL(K),K= 3401, 3485) /
23598      &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05,
23599      &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02,
23600      &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03,
23601      &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05,
23602      &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01,
23603      &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06,
23604      &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06,
23605      &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06,
23606      &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06,
23607      &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02,
23608      &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04,
23609      &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05,
23610      &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02,
23611      &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07,
23612      &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07,
23613      &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06,
23614      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23615       DATA (DL(K),K= 3486, 3570) /
23616      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23617      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23618      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23619      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23620      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23621      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23622      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23623      &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05,
23624      &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02,
23625      &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03,
23626      &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05,
23627      &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01,
23628      &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07,
23629      &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07,
23630      &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06,
23631      &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07,
23632      &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/
23633       DATA (DL(K),K= 3571, 3655) /
23634      &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04,
23635      &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05,
23636      &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02,
23637      &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07,
23638      &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07,
23639      &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06,
23640      &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07,
23641      &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03,
23642      &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04,
23643      &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06,
23644      &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02,
23645      &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07,
23646      &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07,
23647      &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07,
23648      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23649      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23650      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23651       DATA (DL(K),K= 3656, 3740) /
23652      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23653      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23654      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23655      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23656      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23657      &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07,
23658      &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02,
23659      &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04,
23660      &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06,
23661      &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02,
23662      &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06,
23663      &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06,
23664      &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06,
23665      &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06,
23666      &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03,
23667      &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04,
23668      &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/
23669       DATA (DL(K),K= 3741, 3825) /
23670      &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02,
23671      &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07,
23672      &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07,
23673      &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07,
23674      &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07,
23675      &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03,
23676      &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05,
23677      &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07,
23678      &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03,
23679      &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07,
23680      &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08,
23681      &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08,
23682      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23683      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23684      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23685      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23686      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23687       DATA (DL(K),K= 3826, 3910) /
23688      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23689      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23690      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23691      &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08,
23692      &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03,
23693      &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05,
23694      &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06,
23695      &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02,
23696      &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06,
23697      &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06,
23698      &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06,
23699      &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06,
23700      &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04,
23701      &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05,
23702      &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06,
23703      &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03,
23704      &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/
23705       DATA (DL(K),K= 3911, 3995) /
23706      &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07,
23707      &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07,
23708      &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07,
23709      &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04,
23710      &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06,
23711      &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06,
23712      &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04,
23713      &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07,
23714      &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07,
23715      &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07,
23716      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23717      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23718      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23719      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23720      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23721      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23722      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23723       DATA (DL(K),K= 3996, 4000) /
23724      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23725 C
23726       ANS = 0.
23727       IF (X.GT.0.9985) RETURN
23728       IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
23729 C
23730       IS  = S/DELTA+1
23731       IS1 = IS+1
23732       DO 1 L=1,25
23733          KL    = L+NDRV*25
23734          F1(L) = GF(I,IS,KL)
23735          F2(L) = GF(I,IS1,KL)
23736     1 CONTINUE
23737       A1 = DT_CKMTFF(X,F1)
23738       A2 = DT_CKMTFF(X,F2)
23739 C      A1=ALOG(A1)
23740 C      A2=ALOG(A2)
23741       S1  = (IS-1)*DELTA
23742       S2  = S1+DELTA
23743       ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
23744 C      ANS=EXP(ANS)
23745       RETURN
23746       END
23747 C
23748 C
23749
23750 *$ CREATE DT_CKMTPR.FOR
23751 *COPY DT_CKMTPR
23752       SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
23753 C
23754 C**********************************************************************
23755 C    Proton   - PDFs
23756 C    I   = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
23757 C    ANS = PDF(I)
23758 C    This version by S. Roesler, 31.01.96
23759 C**********************************************************************
23760
23761       SAVE
23762       DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
23763       EQUIVALENCE (GF(1,1,1),DL(1))
23764       DATA DELTA/.10/
23765 C
23766       DATA (DL(K),K=    1,   85) /
23767      &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00,
23768      &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00,
23769      &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01,
23770      &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00,
23771      &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00,
23772      &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00,
23773      &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00,
23774      &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00,
23775      &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00,
23776      &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00,
23777      &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02,
23778      &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00,
23779      &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01,
23780      &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00,
23781      &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01,
23782      &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00,
23783      &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/
23784       DATA (DL(K),K=   86,  170) /
23785      &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01,
23786      &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02,
23787      &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01,
23788      &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01,
23789      &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01,
23790      &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01,
23791      &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01,
23792      &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01,
23793      &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01,
23794      &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02,
23795      &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01,
23796      &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01,
23797      &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01,
23798      &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23799      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23800      &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00,
23801      &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/
23802       DATA (DL(K),K=  171,  255) /
23803      &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01,
23804      &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00,
23805      &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00,
23806      &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00,
23807      &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00,
23808      &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00,
23809      &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00,
23810      &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00,
23811      &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02,
23812      &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00,
23813      &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00,
23814      &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00,
23815      &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00,
23816      &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00,
23817      &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00,
23818      &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01,
23819      &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/
23820       DATA (DL(K),K=  256,  340) /
23821      &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01,
23822      &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01,
23823      &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01,
23824      &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01,
23825      &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01,
23826      &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01,
23827      &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01,
23828      &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02,
23829      &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01,
23830      &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01,
23831      &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01,
23832      &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23833      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23834      &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00,
23835      &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00,
23836      &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01,
23837      &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/
23838       DATA (DL(K),K=  341,  425) /
23839      &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00,
23840      &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00,
23841      &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00,
23842      &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00,
23843      &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00,
23844      &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00,
23845      &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01,
23846      &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00,
23847      &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00,
23848      &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00,
23849      &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00,
23850      &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00,
23851      &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00,
23852      &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00,
23853      &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02,
23854      &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00,
23855      &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/
23856       DATA (DL(K),K=  426,  510) /
23857      &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00,
23858      &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00,
23859      &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00,
23860      &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00,
23861      &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01,
23862      &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02,
23863      &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01,
23864      &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01,
23865      &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01,
23866      &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23867      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23868      &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00,
23869      &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00,
23870      &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01,
23871      &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00,
23872      &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00,
23873      &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/
23874       DATA (DL(K),K=  511,  595) /
23875      &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00,
23876      &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00,
23877      &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00,
23878      &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00,
23879      &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01,
23880      &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00,
23881      &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00,
23882      &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00,
23883      &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00,
23884      &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00,
23885      &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00,
23886      &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00,
23887      &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01,
23888      &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00,
23889      &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00,
23890      &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00,
23891      &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/
23892       DATA (DL(K),K=  596,  680) /
23893      &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00,
23894      &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00,
23895      &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00,
23896      &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02,
23897      &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00,
23898      &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00,
23899      &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00,
23900      &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23901      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23902      &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23903      &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00,
23904      &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01,
23905      &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00,
23906      &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00,
23907      &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00,
23908      &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00,
23909      &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/
23910       DATA (DL(K),K=  681,  765) /
23911      &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00,
23912      &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00,
23913      &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01,
23914      &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00,
23915      &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00,
23916      &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00,
23917      &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00,
23918      &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00,
23919      &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00,
23920      &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00,
23921      &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01,
23922      &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00,
23923      &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00,
23924      &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00,
23925      &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00,
23926      &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00,
23927      &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/
23928       DATA (DL(K),K=  766,  850) /
23929      &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00,
23930      &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01,
23931      &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00,
23932      &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00,
23933      &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00,
23934      &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23935      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23936      &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23937      &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00,
23938      &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01,
23939      &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00,
23940      &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00,
23941      &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00,
23942      &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00,
23943      &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01,
23944      &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00,
23945      &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/
23946       DATA (DL(K),K=  851,  935) /
23947      &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01,
23948      &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00,
23949      &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00,
23950      &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00,
23951      &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00,
23952      &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00,
23953      &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00,
23954      &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00,
23955      &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01,
23956      &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00,
23957      &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00,
23958      &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00,
23959      &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00,
23960      &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00,
23961      &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00,
23962      &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00,
23963      &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/
23964       DATA (DL(K),K=  936, 1020) /
23965      &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00,
23966      &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00,
23967      &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00,
23968      &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23969      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23970      &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23971      &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00,
23972      &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01,
23973      &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00,
23974      &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00,
23975      &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00,
23976      &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00,
23977      &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01,
23978      &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00,
23979      &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00,
23980      &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01,
23981      &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/
23982       DATA (DL(K),K= 1021, 1105) /
23983      &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00,
23984      &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00,
23985      &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00,
23986      &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01,
23987      &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00,
23988      &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00,
23989      &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01,
23990      &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00,
23991      &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00,
23992      &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00,
23993      &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00,
23994      &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01,
23995      &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00,
23996      &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00,
23997      &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01,
23998      &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00,
23999      &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/
24000       DATA (DL(K),K= 1106, 1190) /
24001      &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00,
24002      &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00,
24003      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24004      &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01,
24005      &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00,
24006      &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01,
24007      &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01,
24008      &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00,
24009      &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01,
24010      &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01,
24011      &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01,
24012      &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01,
24013      &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00,
24014      &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01,
24015      &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01,
24016      &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00,
24017      &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/
24018       DATA (DL(K),K= 1191, 1275) /
24019      &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01,
24020      &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01,
24021      &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01,
24022      &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00,
24023      &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00,
24024      &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01,
24025      &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00,
24026      &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01,
24027      &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01,
24028      &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01,
24029      &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01,
24030      &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00,
24031      &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00,
24032      &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01,
24033      &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00,
24034      &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01,
24035      &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/
24036       DATA (DL(K),K= 1276, 1360) /
24037      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24038      &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01,
24039      &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00,
24040      &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00,
24041      &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01,
24042      &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00,
24043      &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01,
24044      &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01,
24045      &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02,
24046      &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01,
24047      &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00,
24048      &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00,
24049      &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01,
24050      &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00,
24051      &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01,
24052      &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01,
24053      &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/
24054       DATA (DL(K),K= 1361, 1445) /
24055      &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01,
24056      &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00,
24057      &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00,
24058      &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01,
24059      &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00,
24060      &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01,
24061      &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01,
24062      &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01,
24063      &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01,
24064      &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00,
24065      &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00,
24066      &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01,
24067      &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00,
24068      &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01,
24069      &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00,
24070      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24071      &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/
24072       DATA (DL(K),K= 1446, 1530) /
24073      &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00,
24074      &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00,
24075      &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01,
24076      &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00,
24077      &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01,
24078      &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01,
24079      &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02,
24080      &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01,
24081      &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00,
24082      &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00,
24083      &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01,
24084      &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00,
24085      &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01,
24086      &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01,
24087      &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02,
24088      &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01,
24089      &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/
24090       DATA (DL(K),K= 1531, 1615) /
24091      &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00,
24092      &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01,
24093      &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00,
24094      &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01,
24095      &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01,
24096      &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02,
24097      &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01,
24098      &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00,
24099      &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00,
24100      &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01,
24101      &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00,
24102      &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01,
24103      &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24104      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24105      &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01,
24106      &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00,
24107      &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/
24108       DATA (DL(K),K= 1616, 1700) /
24109      &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01,
24110      &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00,
24111      &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01,
24112      &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01,
24113      &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02,
24114      &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01,
24115      &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00,
24116      &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00,
24117      &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01,
24118      &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00,
24119      &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01,
24120      &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01,
24121      &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02,
24122      &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01,
24123      &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00,
24124      &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00,
24125      &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/
24126       DATA (DL(K),K= 1701, 1785) /
24127      &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00,
24128      &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01,
24129      &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01,
24130      &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02,
24131      &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01,
24132      &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00,
24133      &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00,
24134      &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02,
24135      &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00,
24136      &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02,
24137      &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24138      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24139      &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01,
24140      &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00,
24141      &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00,
24142      &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01,
24143      &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/
24144       DATA (DL(K),K= 1786, 1870) /
24145      &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01,
24146      &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01,
24147      &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02,
24148      &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01,
24149      &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00,
24150      &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00,
24151      &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02,
24152      &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00,
24153      &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02,
24154      &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02,
24155      &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02,
24156      &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02,
24157      &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00,
24158      &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00,
24159      &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02,
24160      &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00,
24161      &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/
24162       DATA (DL(K),K= 1871, 1955) /
24163      &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02,
24164      &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02,
24165      &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02,
24166      &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00,
24167      &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01,
24168      &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02,
24169      &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00,
24170      &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02,
24171      &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24172      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24173      &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02,
24174      &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00,
24175      &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00,
24176      &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02,
24177      &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00,
24178      &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02,
24179      &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/
24180       DATA (DL(K),K= 1956, 2040) /
24181      &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03,
24182      &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02,
24183      &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00,
24184      &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00,
24185      &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02,
24186      &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00,
24187      &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02,
24188      &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02,
24189      &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03,
24190      &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02,
24191      &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00,
24192      &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01,
24193      &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02,
24194      &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00,
24195      &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02,
24196      &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02,
24197      &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/
24198       DATA (DL(K),K= 2041, 2125) /
24199      &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02,
24200      &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01,
24201      &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01,
24202      &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02,
24203      &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00,
24204      &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02,
24205      &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24206      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24207      &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02,
24208      &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00,
24209      &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00,
24210      &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02,
24211      &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00,
24212      &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02,
24213      &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02,
24214      &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03,
24215      &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/
24216       DATA (DL(K),K= 2126, 2210) /
24217      &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00,
24218      &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01,
24219      &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02,
24220      &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00,
24221      &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02,
24222      &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02,
24223      &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03,
24224      &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02,
24225      &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01,
24226      &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01,
24227      &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02,
24228      &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00,
24229      &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02,
24230      &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02,
24231      &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03,
24232      &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02,
24233      &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/
24234       DATA (DL(K),K= 2211, 2295) /
24235      &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01,
24236      &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02,
24237      &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00,
24238      &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02,
24239      &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24240      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24241      &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02,
24242      &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00,
24243      &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01,
24244      &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02,
24245      &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00,
24246      &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02,
24247      &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02,
24248      &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03,
24249      &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02,
24250      &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01,
24251      &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/
24252       DATA (DL(K),K= 2296, 2380) /
24253      &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02,
24254      &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00,
24255      &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02,
24256      &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02,
24257      &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03,
24258      &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02,
24259      &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01,
24260      &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01,
24261      &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02,
24262      &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00,
24263      &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03,
24264      &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03,
24265      &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03,
24266      &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03,
24267      &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01,
24268      &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01,
24269      &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/
24270       DATA (DL(K),K= 2381, 2465) /
24271      &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00,
24272      &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03,
24273      &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24274      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24275      &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02,
24276      &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00,
24277      &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01,
24278      &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02,
24279      &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00,
24280      &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02,
24281      &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02,
24282      &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04,
24283      &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02,
24284      &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01,
24285      &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01,
24286      &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03,
24287      &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/
24288       DATA (DL(K),K= 2466, 2550) /
24289      &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03,
24290      &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03,
24291      &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03,
24292      &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03,
24293      &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01,
24294      &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01,
24295      &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03,
24296      &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00,
24297      &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03,
24298      &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03,
24299      &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03,
24300      &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03,
24301      &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01,
24302      &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02,
24303      &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03,
24304      &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00,
24305      &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/
24306       DATA (DL(K),K= 2551, 2635) /
24307      &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24308      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24309      &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03,
24310      &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01,
24311      &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01,
24312      &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03,
24313      &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00,
24314      &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03,
24315      &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03,
24316      &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04,
24317      &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03,
24318      &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01,
24319      &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01,
24320      &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03,
24321      &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00,
24322      &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03,
24323      &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/
24324       DATA (DL(K),K= 2636, 2720) /
24325      &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04,
24326      &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03,
24327      &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01,
24328      &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02,
24329      &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03,
24330      &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00,
24331      &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03,
24332      &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03,
24333      &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04,
24334      &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03,
24335      &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01,
24336      &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02,
24337      &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03,
24338      &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01,
24339      &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03,
24340      &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24341      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24342       DATA (DL(K),K= 2721, 2805) /
24343      &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03,
24344      &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01,
24345      &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01,
24346      &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03,
24347      &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00,
24348      &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03,
24349      &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03,
24350      &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04,
24351      &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03,
24352      &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01,
24353      &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02,
24354      &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03,
24355      &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00,
24356      &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03,
24357      &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03,
24358      &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04,
24359      &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/
24360       DATA (DL(K),K= 2806, 2890) /
24361      &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01,
24362      &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02,
24363      &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03,
24364      &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01,
24365      &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04,
24366      &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04,
24367      &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04,
24368      &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04,
24369      &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01,
24370      &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02,
24371      &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04,
24372      &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01,
24373      &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04,
24374      &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24375      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24376      &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03,
24377      &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/
24378       DATA (DL(K),K= 2891, 2975) /
24379      &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02,
24380      &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03,
24381      &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00,
24382      &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03,
24383      &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03,
24384      &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05,
24385      &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04,
24386      &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01,
24387      &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02,
24388      &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04,
24389      &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00,
24390      &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04,
24391      &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04,
24392      &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05,
24393      &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04,
24394      &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01,
24395      &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/
24396       DATA (DL(K),K= 2976, 3060) /
24397      &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04,
24398      &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01,
24399      &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04,
24400      &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04,
24401      &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05,
24402      &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04,
24403      &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02,
24404      &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02,
24405      &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04,
24406      &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01,
24407      &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04,
24408      &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24409      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24410      &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04,
24411      &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01,
24412      &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02,
24413      &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/
24414       DATA (DL(K),K= 3061, 3145) /
24415      &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00,
24416      &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04,
24417      &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04,
24418      &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05,
24419      &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04,
24420      &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01,
24421      &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02,
24422      &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04,
24423      &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01,
24424      &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04,
24425      &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04,
24426      &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05,
24427      &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04,
24428      &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02,
24429      &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02,
24430      &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04,
24431      &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/
24432       DATA (DL(K),K= 3146, 3230) /
24433      &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04,
24434      &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04,
24435      &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05,
24436      &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05,
24437      &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02,
24438      &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03,
24439      &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05,
24440      &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01,
24441      &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05,
24442      &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24443      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24444      &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04,
24445      &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01,
24446      &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02,
24447      &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04,
24448      &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01,
24449      &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/
24450       DATA (DL(K),K= 3231, 3315) /
24451      &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04,
24452      &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06,
24453      &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04,
24454      &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02,
24455      &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03,
24456      &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05,
24457      &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01,
24458      &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05,
24459      &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05,
24460      &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06,
24461      &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05,
24462      &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02,
24463      &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03,
24464      &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05,
24465      &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01,
24466      &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05,
24467      &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/
24468       DATA (DL(K),K= 3316, 3400) /
24469      &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06,
24470      &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05,
24471      &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02,
24472      &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03,
24473      &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05,
24474      &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01,
24475      &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05,
24476      &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24477      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24478      &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05,
24479      &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02,
24480      &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03,
24481      &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05,
24482      &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01,
24483      &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05,
24484      &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05,
24485      &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/
24486       DATA (DL(K),K= 3401, 3485) /
24487      &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05,
24488      &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02,
24489      &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03,
24490      &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05,
24491      &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01,
24492      &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05,
24493      &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05,
24494      &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07,
24495      &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05,
24496      &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02,
24497      &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03,
24498      &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05,
24499      &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01,
24500      &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06,
24501      &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06,
24502      &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06,
24503      &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/
24504       DATA (DL(K),K= 3486, 3570) /
24505      &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03,
24506      &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04,
24507      &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06,
24508      &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02,
24509      &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06,
24510      &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24511      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24512      &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05,
24513      &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02,
24514      &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03,
24515      &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06,
24516      &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01,
24517      &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06,
24518      &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06,
24519      &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07,
24520      &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06,
24521      &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/
24522       DATA (DL(K),K= 3571, 3655) /
24523      &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03,
24524      &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06,
24525      &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01,
24526      &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06,
24527      &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06,
24528      &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07,
24529      &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06,
24530      &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03,
24531      &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04,
24532      &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06,
24533      &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02,
24534      &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07,
24535      &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07,
24536      &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07,
24537      &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07,
24538      &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03,
24539      &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/
24540       DATA (DL(K),K= 3656, 3740) /
24541      &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06,
24542      &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02,
24543      &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07,
24544      &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00,
24545      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24546      &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07,
24547      &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02,
24548      &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04,
24549      &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07,
24550      &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01,
24551      &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07,
24552      &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07,
24553      &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07,
24554      &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07,
24555      &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03,
24556      &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04,
24557      &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/
24558       DATA (DL(K),K= 3741, 3825) /
24559      &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02,
24560      &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07,
24561      &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07,
24562      &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07,
24563      &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07,
24564      &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03,
24565      &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04,
24566      &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07,
24567      &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02,
24568      &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07,
24569      &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07,
24570      &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08,
24571      &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07,
24572      &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04,
24573      &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05,
24574      &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09,
24575      &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/
24576       DATA (DL(K),K= 3826, 3910) /
24577      &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08,
24578      &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00,
24579      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24580      &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08,
24581      &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03,
24582      &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05,
24583      &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06,
24584      &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02,
24585      &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07,
24586      &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07,
24587      &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07,
24588      &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07,
24589      &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04,
24590      &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05,
24591      &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06,
24592      &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03,
24593      &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/
24594       DATA (DL(K),K= 3911, 3995) /
24595      &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07,
24596      &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07,
24597      &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07,
24598      &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04,
24599      &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06,
24600      &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07,
24601      &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03,
24602      &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07,
24603      &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07,
24604      &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07,
24605      &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07,
24606      &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05,
24607      &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06,
24608      &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07,
24609      &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04,
24610      &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08,
24611      &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/
24612       DATA (DL(K),K= 3996, 4000) /
24613      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24614 C
24615       ANS = 0.
24616       IF (X.GT.0.9985) RETURN
24617       IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
24618 C
24619       IS  = S/DELTA+1
24620       IS1 = IS+1
24621       DO 1 L=1,25
24622          KL    = L+NDRV*25
24623          F1(L) = GF(I,IS,KL)
24624          F2(L) = GF(I,IS1,KL)
24625     1 CONTINUE
24626       A1 = DT_CKMTFF(X,F1)
24627       A2 = DT_CKMTFF(X,F2)
24628 C      A1=ALOG(A1)
24629 C      A2=ALOG(A2)
24630       S1  = (IS-1)*DELTA
24631       S2  = S1+DELTA
24632       ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
24633 C      ANS=EXP(ANS)
24634       RETURN
24635       END
24636 C
24637
24638 *$ CREATE DT_CKMTFF.FOR
24639 *COPY DT_CKMTFF
24640       FUNCTION DT_CKMTFF(X,FVL)
24641 C**********************************************************************
24642 C
24643 C     LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
24644 C     FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
24645 C     NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
24646 C     IN MAIN ROUTINE.
24647 C
24648 C**********************************************************************
24649
24650       SAVE
24651       DIMENSION FVL(25),XGRID(25)
24652       DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
24653      *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
24654 C
24655       DT_CKMTFF=0.
24656       DO 1 I=1,NX
24657       IF(X.LT.XGRID(I)) GO TO 2
24658     1 CONTINUE
24659     2 I=I-1
24660       IF(I.EQ.0) THEN
24661          I=I+1
24662       ELSE IF(I.GT.23) THEN
24663          I=23
24664       ENDIF
24665       J=I+1
24666       K=J+1
24667       AXI=LOG(XGRID(I))
24668       BXI=LOG(1.-XGRID(I))
24669       AXJ=LOG(XGRID(J))
24670       BXJ=LOG(1.-XGRID(J))
24671       AXK=LOG(XGRID(K))
24672       BXK=LOG(1.-XGRID(K))
24673       FI=LOG(ABS(FVL(I)) +1.E-15)
24674       FJ=LOG(ABS(FVL(J)) +1.E-16)
24675       FK=LOG(ABS(FVL(K)) +1.E-17)
24676       DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
24677       ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
24678      $ BXI))/DET
24679       ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
24680       BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
24681       IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
24682      1RETURN
24683 C      IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
24684 C         WRITE(6,2001) X,FVL
24685 C 2001    FORMAT(8E12.4)
24686 C         WRITE(6,2001) ALPHA,BETA,ALOGA,DET
24687 C      ENDIF
24688       DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
24689       RETURN
24690       END
24691
24692 *$ CREATE DT_FLUINI.FOR
24693 *COPY DT_FLUINI
24694 *
24695 *===fluini=============================================================*
24696 *
24697       SUBROUTINE DT_FLUINI
24698
24699 ************************************************************************
24700 * Initialisation of the nucleon-nucleon cross section fluctuation      *
24701 * treatment. The original version by J. Ranft.                         *
24702 * This version dated 21.04.95 is revised by S. Roesler.                *
24703 ************************************************************************
24704
24705       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24706       SAVE
24707       PARAMETER ( LINP = 10 ,
24708      &            LOUT = 6 ,
24709      &            LDAT = 9 )
24710       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
24711
24712       PARAMETER ( A     = 0.1D0,
24713      &            B     = 0.893D0,
24714      &            OM    = 1.1D0,
24715      &            N     = 6,
24716      &            DX    = 0.003D0)
24717
24718 * n-n cross section fluctuations
24719       PARAMETER (NBINS = 1000)
24720       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
24721       DIMENSION FLUSI(NBINS),FLUIX(NBINS)
24722
24723       WRITE(LOUT,1000)
24724  1000 FORMAT(/,1X,'FLUINI:  hadronic cross section fluctuations ',
24725      &       'treated')
24726
24727       FLUSU  = ZERO
24728       FLUSUU = ZERO
24729
24730       DO 1 I=1,NBINS
24731          X        = DBLE(I)*DX
24732          FLUIX(I) = X
24733          FLUS     = ((X-B)/(OM*B))**N
24734          IF (FLUS.LE.20.0D0) THEN
24735             FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
24736          ELSE
24737             FLUSI(I) = ZERO
24738          ENDIF
24739          FLUSU = FLUSU+FLUSI(I)
24740     1 CONTINUE
24741       DO 2 I=1,NBINS
24742          FLUSUU   = FLUSUU+FLUSI(I)/FLUSU
24743          FLUSI(I) = FLUSUU
24744     2 CONTINUE
24745
24746 C     WRITE(LOUT,1001)
24747 C1001 FORMAT(1X,'FLUCTUATIONS')
24748 C     CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
24749
24750       DO 3 I=1,NBINS
24751          AF = DBLE(I)*0.001D0
24752          DO 4 J=1,NBINS
24753             IF (AF.LE.FLUSI(J)) THEN
24754                FLUIXX(I) = FLUIX(J)
24755                GOTO 5
24756             ENDIF
24757     4    CONTINUE
24758     5    CONTINUE
24759     3 CONTINUE
24760       FLUIXX(1)     = FLUIX(1)
24761       FLUIXX(NBINS) = FLUIX(NBINS)
24762
24763       RETURN
24764       END
24765
24766 *$ CREATE DT_SIGTBL.FOR
24767 *COPY DT_SIGTBL
24768 *
24769 *===sigtab=============================================================*
24770 *
24771       SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
24772
24773 ************************************************************************
24774 * This version dated 18.11.95 is written by S. Roesler                 *
24775 ************************************************************************
24776
24777       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24778       SAVE
24779       PARAMETER ( LINP = 10 ,
24780      &            LOUT = 6 ,
24781      &            LDAT = 9 )
24782
24783       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24784      &           OHALF=0.5D0,ONE=1.0D0)
24785       PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150)
24786
24787       LOGICAL LINIT
24788
24789 * particle properties (BAMJET index convention)
24790       CHARACTER*8  ANAME
24791       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24792      &                IICH(210),IIBAR(210),K1(210),K2(210)
24793
24794       DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23)
24795       DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0,
24796      &             0, 0, 3, 4, 0, 0, 0, 0, 0, 0,
24797      &             0, 0, 5/
24798       DATA LINIT /.FALSE./
24799
24800 * precalculation and tabulation of elastic cross sections
24801       IF (ABS(MODE).EQ.1) THEN
24802          IF (MODE.EQ.1)
24803      &      OPEN(LDAT,FILE='outdata0/sigtab.out',STATUS='UNKNOWN')
24804          PLABLX = LOG10(PLO)
24805          PLABHX = LOG10(PHI)
24806          DPLAB  = (PLABHX-PLABLX)/DBLE(NBINS)
24807          DO 1 I=1,NBINS+1
24808             PLAB = PLABLX+DBLE(I-1)*DPLAB
24809             PLAB = 10**PLAB
24810             DO 2 IPROJ=1,23
24811                IDX = IDSIG(IPROJ)
24812                IF (IDX.GT.0) THEN
24813 C                 CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
24814 C                 CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
24815                   DUMZER = ZERO
24816                   CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
24817                   CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
24818                ENDIF
24819     2       CONTINUE
24820             IF (MODE.EQ.1) THEN
24821                WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5),
24822      &                                (SIGEN(IDX,I),IDX=1,5)
24823  1000          FORMAT(F5.1,10F7.2)
24824             ENDIF
24825     1    CONTINUE
24826          IF (MODE.EQ.1) CLOSE(LDAT)
24827          LINIT = .TRUE.
24828       ELSE
24829          SIGE = -ONE
24830          IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
24831      &                           .AND.(PTOT.LE.PHI) ) THEN
24832             IDX = IDSIG(JP)
24833             IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
24834                PLABX = LOG10(PTOT)
24835                IF (PLABX.LE.PLABLX) THEN
24836                   I1 = 1
24837                   I2 = 1
24838                ELSEIF (PLABX.GE.PLABHX) THEN
24839                   I1 = NBINS+1
24840                   I2 = NBINS+1
24841                ELSE
24842                   I1 = INT((PLABX-PLABLX)/DPLAB)+1
24843                   I2 = I1+1
24844                ENDIF
24845                PLAB1X = PLABLX+DBLE(I1-1)*DPLAB
24846                PLAB2X = PLABLX+DBLE(I2-1)*DPLAB
24847                PBIN   = PLAB2X-PLAB1X
24848                IF (PBIN.GT.TINY10) THEN
24849                   RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X)
24850                ELSE
24851                   RATX = ZERO
24852                ENDIF
24853                IF (JT.EQ.1) THEN
24854                   SIG1 = SIGEP(IDX,I1)
24855                   SIG2 = SIGEP(IDX,I2)
24856                ELSE
24857                   SIG1 = SIGEN(IDX,I1)
24858                   SIG2 = SIGEN(IDX,I2)
24859                ENDIF
24860                SIGE = SIG1+RATX*(SIG2-SIG1)
24861             ENDIF
24862          ENDIF
24863       ENDIF
24864
24865       RETURN
24866       END
24867
24868 *$ CREATE DT_XSTABL.FOR
24869 *COPY DT_XSTABL
24870 *
24871 *===xstabl=============================================================*
24872 *
24873       SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
24874
24875       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24876       SAVE
24877       PARAMETER ( LINP = 10 ,
24878      &            LOUT = 6 ,
24879      &            LDAT = 9 )
24880       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24881      &           OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
24882       LOGICAL LLAB,LELOG,LQLOG
24883
24884 * particle properties (BAMJET index convention)
24885       CHARACTER*8  ANAME
24886       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24887      &                IICH(210),IIBAR(210),K1(210),K2(210)
24888 * properties of interacting particles
24889       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
24890       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
24891 * Glauber formalism: cross sections
24892       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
24893      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
24894      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
24895      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
24896      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
24897      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
24898      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
24899      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
24900      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
24901      &                BSLOPE,NEBINI,NQBINI
24902 * emulsion treatment
24903       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
24904      &                NCOMPO,IEMUL
24905
24906       DIMENSION WHAT(6)
24907
24908       LLAB   = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
24909       ELO    = ABS(WHAT(1))
24910       EHI    = ABS(WHAT(2))
24911       IF (ELO.GT.EHI) ELO = EHI
24912       LELOG  = WHAT(3).LT.ZERO
24913       NEBINS = MAX(INT(ABS(WHAT(3))),1)
24914       DEBINS = (EHI-ELO)/DBLE(NEBINS)
24915       IF (LELOG) THEN
24916          AELO   = LOG10(ELO)
24917          AEHI   = LOG10(EHI)
24918          ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
24919       ENDIF
24920       Q2LO   = WHAT(4)
24921       Q2HI   = WHAT(5)
24922       IF (Q2LO.GT.Q2HI) Q2LO = Q2HI
24923       LQLOG  = WHAT(6).LT.ZERO
24924       NQBINS = MAX(INT(ABS(WHAT(6))),1)
24925       DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS)
24926       IF (LQLOG) THEN
24927          AQ2LO  = LOG10(Q2LO)
24928          AQ2HI  = LOG10(Q2HI)
24929          ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
24930       ENDIF
24931
24932       IF ( ELO.EQ. EHI) NEBINS = 0
24933       IF (Q2LO.EQ.Q2HI) NQBINS = 0
24934
24935       WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT
24936  1000 FORMAT(/,1X,'XSTABL:  E_lo  =',E10.3,' GeV  E_hi  =',E10.3,
24937      &       ' GeV     Lab = ',L1,'  qel: ',I2,/,10X,'Q2_lo =',F10.5,
24938      &       ' GeV^2  Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2,
24939      &       '   A_p = ',I3,'   A_t = ',I3,/)
24940
24941 C     IF (IJPROJ.NE.7) THEN
24942          WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)'
24943 * normalize fractions of emulsion components
24944          IF (NCOMPO.GT.0) THEN
24945             SUMFRA = ZERO
24946             DO 10 I=1,NCOMPO
24947                SUMFRA = SUMFRA+EMUFRA(I)
24948    10       CONTINUE
24949             IF (SUMFRA.GT.ZERO) THEN
24950                DO 11 I=1,NCOMPO
24951                   EMUFRA(I) = EMUFRA(I)/SUMFRA
24952    11          CONTINUE
24953             ENDIF
24954          ENDIF
24955 C     ELSE
24956 C        WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
24957 C     ENDIF
24958       DO 1 I=1,NEBINS+1
24959          IF (LELOG) THEN
24960             E = 10**(AELO+DBLE(I-1)*ADEBIN)
24961          ELSE
24962             E = ELO+DBLE(I-1)*DEBINS
24963          ENDIF
24964          DO 2 J=1,NQBINS+1
24965             IF (LQLOG) THEN
24966                Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
24967             ELSE
24968                Q2 = Q2LO+DBLE(J-1)*DQBINS
24969             ENDIF
24970 c            IF (IJPROJ.NE.7) THEN
24971                IF (LLAB) THEN
24972                   PLAB = ZERO
24973                   ECM  = ZERO
24974                   CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
24975                ELSE
24976                   ECM = E
24977                ENDIF
24978                XI  = ZERO
24979                Q2I = ZERO
24980                IF (IJPROJ.EQ.7) Q2I = Q2
24981                IF (NCOMPO.GT.0) THEN
24982                   DO 20 IC=1,NCOMPO
24983                      IIT = IEMUMA(IC)
24984                      CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
24985    20             CONTINUE
24986                ELSE
24987                   CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
24988 C                 CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
24989                ENDIF
24990                IF (NCOMPO.GT.0) THEN
24991                   XTOT = ZERO
24992                   ETOT = ZERO
24993                   XELA = ZERO
24994                   EELA = ZERO
24995                   XQEP = ZERO
24996                   EQEP = ZERO
24997                   XQET = ZERO
24998                   EQET = ZERO
24999                   XQE2 = ZERO
25000                   EQE2 = ZERO
25001                   XPRO = ZERO
25002                   EPRO = ZERO
25003                   XPRO1= ZERO
25004                   XDEL = ZERO
25005                   EDEL = ZERO
25006                   XDQE = ZERO
25007                   EDQE = ZERO
25008                   DO 21 IC=1,NCOMPO
25009                      XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC)
25010                      ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2
25011                      XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC)
25012                      EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2
25013                      XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC)
25014                      EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2
25015                      XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC)
25016                      EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2
25017                      XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC)
25018                      EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2
25019                      XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC)
25020                      EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2
25021                      XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC)
25022                      EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2
25023                      XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC)
25024                      EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2
25025                      YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC)
25026      &                     -XSQEP(1,1,IC)-XSQET(1,1,IC)
25027      &                     -XSQE2(1,1,IC)
25028                      XPRO1= XPRO1+EMUFRA(IC)*YPRO
25029    21             CONTINUE
25030                   ETOT = SQRT(ETOT)
25031                   EELA = SQRT(EELA)
25032                   EQEP = SQRT(EQEP)
25033                   EQET = SQRT(EQET)
25034                   EQE2 = SQRT(EQE2)
25035                   EPRO = SQRT(EPRO)
25036                   EDEL = SQRT(EDEL)
25037                   EDQE = SQRT(EDQE)
25038                   WRITE(LOUT,'(8E9.3)')
25039      &               E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
25040 C                 WRITE(LOUT,'(4E9.3)')
25041 C    &               E,XDEL,XDQE,XDEL+XDQE
25042                ELSE
25043                   WRITE(LOUT,'(11E10.3)')
25044      &              E,
25045      &              XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1),
25046      &              XSQE2(1,1,1),XSPRO(1,1,1),
25047      &              XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1)
25048      &             -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1),
25049      &              XSDEL(1,1,1)+XSDQE(1,1,1)
25050 C                 WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
25051 C    &                                    XSDEL(1,1,1)+XSDQE(1,1,1)
25052                ENDIF
25053 c            ELSE
25054 c               IF (LLAB) THEN
25055 c                  IF (IT.GT.1) THEN
25056 c                     IF (IXSQEL.EQ.0) THEN
25057 cC                       CALL DT_SIGGA(IT,  Q2, E,ZERO,ZERO,
25058 cC                       CALL DT_SIGGA(IT,   E,Q2,ZERO,ZERO,
25059 c                        CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
25060 c     &                             STOT,ETOT,SIN,EIN,STOT0)
25061 c                        IF (IRATIO.EQ.1) THEN
25062 c                           CALL DT_SIGGP(  Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
25063 cC                          CALL DT_SIGGP(   E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
25064 cC                          CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
25065 c*!! save cross sections
25066 c                           STOTA = STOT
25067 c                           ETOTA = ETOT
25068 c                           STOTP = STGP
25069 c*!!
25070 c                           STOT  = STOT/(DBLE(IT)*STGP)
25071 c                           SIN   =  SIN/(DBLE(IT)*SIGP)
25072 c                           STOT0 = STGP
25073 c                           ETOT  = ZERO
25074 c                           EIN   = ZERO
25075 c                        ENDIF
25076 c                     ELSE
25077 c                        WRITE(LOUT,*)
25078 c     &                  ' XSTABL:  qel. xs. not implemented for nuclei'
25079 c                        STOP
25080 c                     ENDIF
25081 c                  ELSE
25082 c                     ETOT = ZERO
25083 c                     EIN  = ZERO
25084 c                     STOT0= ZERO
25085 c                     IF (IXSQEL.EQ.0) THEN
25086 c                        CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
25087 c                     ELSE
25088 c                       SIN = ZERO
25089 c                       CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
25090 c                     ENDIF
25091 c                  ENDIF
25092 c               ELSE
25093 c                  IF (IT.GT.1) THEN
25094 c                     IF (IXSQEL.EQ.0) THEN
25095 c                        CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
25096 c     &                             STOT,ETOT,SIN,EIN,STOT0)
25097 c                        IF (IRATIO.EQ.1) THEN
25098 c                           CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
25099 c*!! save cross sections
25100 c                           STOTA = STOT
25101 c                           ETOTA = ETOT
25102 c                           STOTP = STGP
25103 c*!!
25104 c                           STOT  = STOT/(DBLE(IT)*STGP)
25105 c                           SIN   =  SIN/(DBLE(IT)*SIGP)
25106 c                           STOT0 = STGP
25107 c                           ETOT  = ZERO
25108 c                           EIN   = ZERO
25109 c                        ENDIF
25110 c                     ELSE
25111 c                        WRITE(LOUT,*)
25112 c     &                  ' XSTABL:  qel. xs. not implemented for nuclei'
25113 c                        STOP
25114 c                     ENDIF
25115 c                  ELSE
25116 c                     ETOT = ZERO
25117 c                     EIN  = ZERO
25118 c                     STOT0= ZERO
25119 c                     IF (IXSQEL.EQ.0) THEN
25120 c                        CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
25121 c                     ELSE
25122 c                       SIN = ZERO
25123 c                       CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
25124 c                     ENDIF
25125 c                  ENDIF
25126 c               ENDIF
25127 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
25128 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
25129 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
25130 c               WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
25131 c            ENDIF
25132     2    CONTINUE
25133     1 CONTINUE
25134
25135       RETURN
25136       END
25137
25138 *$ CREATE DT_TESTXS.FOR
25139 *COPY DT_TESTXS
25140 *
25141 *===testxs=============================================================*
25142 *
25143       SUBROUTINE DT_TESTXS
25144
25145       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25146       SAVE
25147
25148       DIMENSION XSTOT(26,2),XSELA(26,2)
25149
25150       OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN')
25151       OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN')
25152       OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN')
25153       OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN')
25154       DUMECM = 0.0D0
25155       PLABL = 0.01D0
25156       PLABH = 10000.0D0
25157       NBINS = 120
25158       APLABL = LOG10(PLABL)
25159       APLABH = LOG10(PLABH)
25160       ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
25161       DO 1 I=1,NBINS+1
25162          ADP = APLABL+DBLE(I-1)*ADPLAB
25163          P = 10.0D0**ADP
25164          DO 2 J=1,26
25165             CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1))
25166             CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2))
25167     2    CONTINUE
25168          WRITE(10,1000) P,(XSTOT(K,1),K=1,26)
25169          WRITE(11,1000) P,(XSELA(K,1),K=1,26)
25170          WRITE(12,1000) P,(XSTOT(K,2),K=1,26)
25171          WRITE(13,1000) P,(XSELA(K,2),K=1,26)
25172     1 CONTINUE
25173  1000 FORMAT(F8.3,26F9.3)
25174
25175       RETURN
25176       END
25177
25178 ************************************************************************
25179 *                                                                      *
25180 *  DTUNUC 2.0:   library routines                                      *
25181 *                                   processed by S. Roesler, 6.5.95    *
25182 *                                                                      *
25183 ************************************************************************
25184 *
25185 *     1) Handling of parton momenta
25186 *          SUBROUTINE MASHEL
25187 *          SUBROUTINE DFERMI
25188 *
25189 *     2) Handling of parton flavors and particle indices
25190 *          INTEGER FUNCTION IPDG2B
25191 *          INTEGER FUNCTION IB2PDG
25192 *          INTEGER FUNCTION IQUARK
25193 *          INTEGER FUNCTION IBJQUA
25194 *          INTEGER FUNCTION ICIHAD
25195 *          INTEGER FUNCTION IPDGHA
25196 *          INTEGER FUNCTION MCHAD
25197 *          SUBROUTINE FLAHAD
25198 *
25199 *     3) Energy-momentum and quantum number conservation check routines
25200 *          SUBROUTINE EMC1
25201 *          SUBROUTINE EMC2
25202 *          SUBROUTINE EVTEMC
25203 *          SUBROUTINE EVTFLC
25204 *          SUBROUTINE EVTCHG
25205 *
25206 *     4) Transformations
25207 *          SUBROUTINE LTINI
25208 *          SUBROUTINE LTRANS
25209 *          SUBROUTINE LTNUC
25210 *          SUBROUTINE DALTRA
25211 *          SUBROUTINE DTRAFO
25212 *          SUBROUTINE STTRAN
25213 *          SUBROUTINE MYTRAN
25214 *          SUBROUTINE LT2LAO
25215 *          SUBROUTINE LT2LAB
25216 *
25217 *     5) Sampling from distributions
25218 *          INTEGER FUNCTION NPOISS
25219 *          DOUBLE PRECISION FUNCTION SAMPXB
25220 *          DOUBLE PRECISION FUNCTION SAMPEX
25221 *          DOUBLE PRECISION FUNCTION SAMSQX
25222 *          DOUBLE PRECISION FUNCTION BETREJ
25223 *          DOUBLE PRECISION FUNCTION DGAMRN
25224 *          DOUBLE PRECISION FUNCTION DBETAR
25225 *          SUBROUTINE RANNOR
25226 *          SUBROUTINE DPOLI
25227 *          SUBROUTINE DSFECF
25228 *          SUBROUTINE RACO
25229 *
25230 *     6) Special functions, algorithms and service routines
25231 *          DOUBLE PRECISION FUNCTION YLAMB
25232 *          SUBROUTINE SORT
25233 *          SUBROUTINE SORT1
25234 *          SUBROUTINE DT_XTIME
25235 *
25236 *     7) Random number generator package
25237 *          DOUBLE PRECISION FUNCTION DT_RNDM
25238 *          SUBROUTINE DT_RNDMST
25239 *          SUBROUTINE DT_RNDMIN
25240 *          SUBROUTINE DT_RNDMOU
25241 *          SUBROUTINE DT_RNDMTE
25242 *
25243 ************************************************************************
25244 *                                                                      *
25245 *                 1) Handling of parton momenta                        *
25246 *                                                                      *
25247 ************************************************************************
25248 *$ CREATE DT_MASHEL.FOR
25249 *COPY DT_MASHEL
25250 *
25251 *===mashel=============================================================*
25252 *
25253       SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
25254
25255 ************************************************************************
25256 *                                                                      *
25257 *    rescaling of momenta of two partons to put both                   *
25258 *                                       on mass shell                  *
25259 *                                                                      *
25260 *    input:       PA1,PA2   input momentum vectors                     *
25261 *                 XM1,2     desired masses of particles afterwards     *
25262 *                 P1,P2     changed momentum vectors                   *
25263 *                                                                      *
25264 * The original version is written by R. Engel.                         *
25265 * This version dated 12.12.94 is modified by S. Roesler.               *
25266 ************************************************************************
25267
25268       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25269       SAVE
25270       PARAMETER ( LINP = 10 ,
25271      &            LOUT = 6 ,
25272      &            LDAT = 9 )
25273       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
25274
25275       DIMENSION PA1(4),PA2(4),P1(4),P2(4)
25276
25277       IREJ = 0
25278
25279 * Lorentz transformation into system CMS
25280       PX  = PA1(1)+PA2(1)
25281       PY  = PA1(2)+PA2(2)
25282       PZ  = PA1(3)+PA2(3)
25283       EE  = PA1(4)+PA2(4)
25284       XPTOT = SQRT(PX**2+PY**2+PZ**2)
25285       XMS   = (EE-XPTOT)*(EE+XPTOT)
25286       IF(XMS.LT.(XM1+XM2)**2) THEN
25287 C        WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
25288          GOTO 9999
25289       ENDIF
25290       XMS = SQRT(XMS)
25291       BGX = PX/XMS
25292       BGY = PY/XMS
25293       BGZ = PZ/XMS
25294       GAM = EE/XMS
25295       CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
25296      &           PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
25297 * rotation angles
25298       COD = P1(3)/PTOT1
25299 C     SID = SQRT((ONE-COD)*(ONE+COD))
25300       PPT = SQRT(P1(1)**2+P1(2)**2)
25301       SID = PPT/PTOT1
25302       COF = ONE
25303       SIF = ZERO
25304       IF(PTOT1*SID.GT.TINY10) THEN
25305          COF   = P1(1)/(SID*PTOT1)
25306          SIF   = P1(2)/(SID*PTOT1)
25307          ANORF = SQRT(COF*COF+SIF*SIF)
25308          COF   = COF/ANORF
25309          SIF   = SIF/ANORF
25310       ENDIF
25311 * new CM momentum and energies (for masses XM1,XM2)
25312       XM12 = SIGN(XM1**2,XM1)
25313       XM22 = SIGN(XM2**2,XM2)
25314       SS   = XMS**2
25315       PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
25316       EE1  = SQRT(XM12+PCMP**2)
25317       EE2  = XMS-EE1
25318 * back rotation
25319       MODE = 1
25320       CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
25321       CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
25322      &            PTOT1,P1(1),P1(2),P1(3),P1(4))
25323       CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
25324      &            PTOT2,P2(1),P2(2),P2(3),P2(4))
25325 * check consistency
25326       DEL = XMS*0.0001D0
25327       IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
25328         IDEV = 1
25329       ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
25330         IDEV = 2
25331       ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
25332         IDEV = 3
25333       ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
25334         IDEV = 4
25335       ELSE
25336         IDEV = 0
25337       ENDIF
25338       IF (IDEV.NE.0) THEN
25339          WRITE(LOUT,'(/1X,A,I3)')
25340      &      'MASHEL: inconsistent transformation',IDEV
25341          WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:'
25342          WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1
25343          WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2
25344          WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:'
25345          WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4)
25346          WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4)
25347       ENDIF
25348       RETURN
25349
25350  9999 CONTINUE
25351       IREJ = 1
25352       RETURN
25353       END
25354
25355 *$ CREATE DT_DFERMI.FOR
25356 *COPY DT_DFERMI
25357 *
25358 *===dfermi=============================================================*
25359 *
25360       SUBROUTINE DT_DFERMI(GPART)
25361
25362 ************************************************************************
25363 * Find largest of three random numbers.                                *
25364 ************************************************************************
25365
25366       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25367       SAVE
25368
25369       DIMENSION G(3)
25370
25371       DO 10 I=1,3
25372         G(I)=DT_RNDM(GPART)
25373    10 CONTINUE
25374       IF (G(3).LT.G(2)) GOTO 40
25375       IF (G(3).LT.G(1)) GOTO 30
25376       GPART = G(3)
25377    20 RETURN
25378    30 GPART = G(1)
25379       GOTO 20
25380    40 IF (G(2).LT.G(1)) GOTO 30
25381       GPART = G(2)
25382       GOTO 20
25383
25384       END
25385
25386 ************************************************************************
25387 *                                                                      *
25388 *         2) Handling of parton flavors and particle indices           *
25389 *                                                                      *
25390 ************************************************************************
25391 *$ CREATE IDT_IPDG2B.FOR
25392 *COPY IDT_IPDG2B
25393 *
25394 *===ipdg2b=============================================================*
25395 *
25396       INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
25397
25398 ************************************************************************
25399 *                                                                      *
25400 *     conversion of quark numbering scheme                             *
25401 *                                                                      *
25402 *     input:   PDG parton numbering                                    *
25403 *              for diquarks:  NN number of the constituent quark       *
25404 *                             (e.g. ID=2301,NN=1 -> ICONV2=1)          *
25405 *                                                                      *
25406 *     output:  BAMJET particle codes                                   *
25407 *              1 u     7 a-u   (MODE=1)  -1 a-u   (MODE=2)             *
25408 *              2 d     8 a-d             -2 a-d                        *
25409 *              3 s     9 a-s             -3 a-s                        *
25410 *              4 c    10 a-c             -4 a-c                        *
25411 *                                                                      *
25412 * This is a modified version of ICONV2 written by R. Engel.            *
25413 * This version dated 13.12.94 is written by S. Roesler.                *
25414 ************************************************************************
25415
25416       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25417       SAVE
25418       PARAMETER ( LINP = 10 ,
25419      &            LOUT = 6 ,
25420      &            LDAT = 9 )
25421
25422       IDA = ABS(ID)
25423 * diquarks
25424       IF (IDA.GT.6) THEN
25425         KF  = 3
25426         IF (IDA.GE.1000) KF = 4
25427         IDA = IDA/(10**(KF-NN))
25428         IDA = MOD(IDA,10)
25429       ENDIF
25430 * exchange up and dn quarks
25431       IF (IDA.EQ.1) THEN
25432         IDA = 2
25433       ELSEIF (IDA.EQ.2) THEN
25434         IDA = 1
25435       ENDIF
25436 * antiquarks
25437       IF (ID.LT.0) THEN
25438          IF (MODE.EQ.1) THEN
25439             IDA = IDA+6
25440          ELSE
25441             IDA = -IDA
25442          ENDIF
25443       ENDIF
25444       IDT_IPDG2B = IDA
25445
25446       RETURN
25447       END
25448
25449 *$ CREATE IDT_IB2PDG.FOR
25450 *COPY IDT_IB2PDG
25451 *
25452 *===ib2pdg=============================================================*
25453 *
25454       INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
25455
25456 ************************************************************************
25457 *                                                                      *
25458 *     conversion of quark numbering scheme                             *
25459 *                                                                      *
25460 *     input:   BAMJET particle codes                                   *
25461 *              1 u     7 a-u   (MODE=1)  -1 a-u   (MODE=2)             *
25462 *              2 d     8 a-d             -2 a-d                        *
25463 *              3 s     9 a-s             -3 a-s                        *
25464 *              4 c    10 a-c             -4 a-c                        *
25465 *                                                                      *
25466 *     output:  PDG parton numbering                                    *
25467 *                                                                      *
25468 * This version dated 13.12.94 is written by S. Roesler.                *
25469 ************************************************************************
25470
25471       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25472       SAVE
25473       PARAMETER ( LINP = 10 ,
25474      &            LOUT = 6 ,
25475      &            LDAT = 9 )
25476
25477       DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
25478       DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
25479       DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
25480      &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
25481      &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
25482
25483       IDA = ID1
25484       IDB = ID2
25485       IF (MODE.EQ.1) THEN
25486          IF (ID1.GT.6) IDA = -(ID1-6)
25487          IF (ID2.GT.6) IDB = -(ID2-6)
25488       ENDIF
25489       IF (ID2.EQ.0) THEN
25490          IDT_IB2PDG = IHKKQ(IDA)
25491       ELSE
25492          IDT_IB2PDG = IHKKQQ(IDA,IDB)
25493       ENDIF
25494
25495       RETURN
25496       END
25497
25498 *$ CREATE IDT_IQUARK.FOR
25499 *COPY IDT_IQUARK
25500 *
25501 *===ipdgqu=============================================================*
25502 *
25503       INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
25504
25505 ************************************************************************
25506 *                                                                      *
25507 *     quark contents according to PDG conventions                      *
25508 *     (random selection in case of quark mixing)                       *
25509 *                                                                      *
25510 *     input:   IDBAMJ BAMJET particle code                             *
25511 *              K      1..3   quark number                              *
25512 *                                                                      *
25513 *     output:  1   d  (anti --> neg.)                                  *
25514 *              2   u                                                   *
25515 *              3   s                                                   *
25516 *              4   c                                                   *
25517 *                                                                      *
25518 * This version written by R. Engel.                                    *
25519 ************************************************************************
25520
25521       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25522       SAVE
25523
25524       IQ = IDT_IBJQUA(K,IDBAMJ)
25525 * quark-antiquark
25526       IF (IQ.GT.6) THEN
25527          IQ = 6-IQ
25528       ENDIF
25529 * exchange of up and down
25530       IF (ABS(IQ).EQ.1) THEN
25531          IQ = SIGN(2,IQ)
25532       ELSEIF (ABS(IQ).EQ.2) THEN
25533          IQ = SIGN(1,IQ)
25534       ENDIF
25535       IDT_IQUARK = IQ
25536
25537       RETURN
25538       END
25539
25540 *$ CREATE IDT_IBJQUA.FOR
25541 *COPY IDT_IBJQUA
25542 *
25543 *===ibamq==============================================================*
25544 *
25545       INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
25546
25547 ************************************************************************
25548 *                                                                      *
25549 *     quark contents according to BAMJET conventions                   *
25550 *     (random selection in case of quark mixing)                       *
25551 *                                                                      *
25552 *     input:   IDBAMJ BAMJET particle code                             *
25553 *              K      1..3   quark number                              *
25554 *                                                                      *
25555 *     output:  1   u      7   u bar                                    *
25556 *              2   d      8   d bar                                    *
25557 *              3   s      9   s bar                                    *
25558 *              4   c     10   c bar                                    *
25559 *                                                                      *
25560 * This version written by R. Engel.                                    *
25561 ************************************************************************
25562
25563       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25564       SAVE
25565
25566       DIMENSION ITAB(3,210)
25567       DATA ((ITAB(I,K),I=1,3),K=1,30) /
25568      &    1,  1,  2,   7,  7,  8,   0,  0,  0,
25569      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25570      &    0,  0,  0,   1,  2,  2,   7,  8,  8,
25571 *sr 10.1.94
25572 C    &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25573      &    0,  0,  0,   0,  0,  0,   3,  8,  0,
25574 *
25575      &    1,  8,  0,   2,  7,  0,   1,  9,  0,
25576 *sr 10.1.94
25577 C    &    3,  7,  0,   0,  0,  0,   0,  0,  0,
25578      &    3,  7,  0,   3,  1,  2,   9,  7,  8,
25579 *sr 10.1.94
25580 C    &    0,  0,  0,   2,  2,  3,   1,  1,  3,
25581      &    2,  9,  0,   2,  2,  3,   1,  1,  3,
25582 *
25583      &    1,  2,  3, 201,202,  0,   2,  9,  0,
25584      &    3,  8,  0,   0,  0,  0,   0,  0,  0,
25585      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25586       DATA ((ITAB(I,K),I=1,3),K=31,60) /
25587      &    3,  9,  0,   1,  8,  0, 203,204,  0,
25588      &    2,  7,  0,   0,  0,  0,   1,  9,  0,
25589      &    2,  9,  0,   3,  7,  0,   3,  8,  0,
25590      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25591      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25592      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25593      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25594      &    0,  0,  0,   1,  1,  1,   1,  1,  2,
25595      &    1,  2,  2,   2,  2,  2,   0,  0,  0,
25596      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25597       DATA ((ITAB(I,K),I=1,3),K=61,90) /
25598      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25599      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25600      &    7,  7,  7,   7,  7,  8,   7,  8,  8,
25601      &    8,  8,  8,   0,  0,  0,   0,  0,  0,
25602      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25603      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25604      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25605      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25606      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25607      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25608       DATA ((ITAB(I,K),I=1,3),K=91,120) /
25609      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25610      &    0,  0,  0,   0,  0,  0,   3,  9,  0,
25611      &    1,  3,  3,   2,  3,  3,   7,  7,  9,
25612      &    7,  8,  9,   8,  8,  9,   7,  9,  9,
25613      &    8,  9,  9,   1,  1,  3,   1,  2,  3,
25614      &    2,  2,  3,   1,  3,  3,   2,  3,  3,
25615      &    3,  3,  3,   7,  7,  9,   7,  8,  9,
25616      &    8,  8,  9,   7,  9,  9,   8,  9,  9,
25617      &    9,  9,  9,   4,  7,  0,   4,  8,  0,
25618      &    2, 10,  0,   1, 10,  0,   4,  9,  0 /
25619       DATA ((ITAB(I,K),I=1,3),K=121,150) /
25620      &    3, 10,  0,   4, 10,  0,   4,  7,  0,
25621      &    4,  8,  0,   2, 10,  0,   1, 10,  0,
25622      &    4,  9,  0,   3, 10,  0,   4, 10,  0,
25623      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25624      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25625      &    0,  0,  0,   1,  2,  4,   1,  3,  4,
25626      &    2,  3,  4,   1,  1,  4,   0,  0,  0,
25627      &    2,  2,  4,   0,  0,  0,   0,  0,  0,
25628      &    3,  3,  4,   1,  4,  4,   2,  4,  4,
25629      &    3,  4,  4,   7,  8, 10,   7,  9, 10 /
25630       DATA ((ITAB(I,K),I=1,3),K=151,180) /
25631      &    8,  9, 10,   7,  7, 10,   0,  0,  0,
25632      &    8,  8, 10,   0,  0,  0,   0,  0,  0,
25633      &    9,  9, 10,   7, 10, 10,   8, 10, 10,
25634      &    9, 10, 10,   1,  1,  4,   1,  2,  4,
25635      &    2,  2,  4,   1,  3,  4,   2,  3,  4,
25636      &    3,  3,  4,   1,  4,  4,   2,  4,  4,
25637      &    3,  4,  4,   4,  4,  4,   7,  7, 10,
25638      &    7,  8, 10,   8,  8, 10,   7,  9, 10,
25639      &    8,  9, 10,   9,  9, 10,   7, 10, 10,
25640      &    8, 10, 10,   9, 10, 10,  10, 10, 10 /
25641       DATA ((ITAB(I,K),I=1,3),K=181,210) /
25642      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25643      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25644      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25645      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25646      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25647      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25648      &    0,  0,  0,   0,  0,  0,   1,  7,  0,
25649      &    2,  8,  0,   1,  7,  0,   2,  8,  0,
25650      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25651      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25652       DATA IDOLD /0/
25653
25654       ONE = 1.0D0
25655       IF (ITAB(1,IDBAMJ).LE.200) THEN
25656          ID = ITAB(K,IDBAMJ)
25657       ELSE
25658          IF(IDOLD.NE.IDBAMJ) THEN
25659             IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
25660      &           DT_RNDM(ONE)+ITAB(1,IDBAMJ))
25661         ELSE
25662            IDOLD = 0
25663         ENDIF
25664         ID = ITAB(K,IT)
25665       ENDIF
25666       IDOLD  = IDBAMJ
25667       IDT_IBJQUA = ID
25668
25669       RETURN
25670       END
25671
25672 *$ CREATE IDT_ICIHAD.FOR
25673 *COPY IDT_ICIHAD
25674 *
25675 *===icihad=============================================================*
25676 *
25677       INTEGER FUNCTION IDT_ICIHAD(MCIND)
25678
25679 ************************************************************************
25680 * Conversion of particle index PDG proposal --> BAMJET-index scheme    *
25681 * This is a completely new version dated 25.10.95.                     *
25682 * Renamed to be not in conflict with the modified PHOJET-version       *
25683 ************************************************************************
25684
25685       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25686       SAVE
25687
25688 * hadron index conversion (BAMJET <--> PDG)
25689       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25690      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25691      &                IAMCIN(210)
25692
25693       IDT_ICIHAD = 0
25694       KPDG   = ABS(MCIND)
25695       IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
25696       IF (MCIND.LT.0) THEN
25697          JSIGN = 1
25698       ELSE
25699          JSIGN = 2
25700       ENDIF
25701       IF (KPDG.GE.10000) THEN
25702          DO 1 I=1,19
25703             IDT_ICIHAD = IBAM5(JSIGN,I)
25704             IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
25705             IDT_ICIHAD = 0
25706     1    CONTINUE
25707       ELSEIF (KPDG.GE.1000) THEN
25708          DO 2 I=1,29
25709             IDT_ICIHAD = IBAM4(JSIGN,I)
25710             IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
25711             IDT_ICIHAD = 0
25712     2    CONTINUE
25713       ELSEIF (KPDG.GE.100) THEN
25714          DO 3 I=1,22
25715             IDT_ICIHAD = IBAM3(JSIGN,I)
25716             IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
25717             IDT_ICIHAD = 0
25718     3    CONTINUE
25719       ELSEIF (KPDG.GE.10) THEN
25720          DO 4 I=1,7
25721             IDT_ICIHAD = IBAM2(JSIGN,I)
25722             IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
25723             IDT_ICIHAD = 0
25724     4    CONTINUE
25725       ENDIF
25726     5 CONTINUE
25727
25728       RETURN
25729       END
25730
25731 *$ CREATE IDT_IPDGHA.FOR
25732 *COPY IDT_IPDGHA
25733 *
25734 *===ipdgha=============================================================*
25735 *
25736       INTEGER FUNCTION IDT_IPDGHA(MCIND)
25737
25738 ************************************************************************
25739 * Conversion of particle index BAMJET-index scheme --> PDG proposal    *
25740 * Adopted from the original by S. Roesler. This version dated 12.5.95  *
25741 * Renamed to be not in conflict with the modified PHOJET-version       *
25742 ************************************************************************
25743
25744       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25745       SAVE
25746
25747 * hadron index conversion (BAMJET <--> PDG)
25748       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25749      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25750      &                IAMCIN(210)
25751
25752       IDT_IPDGHA = IAMCIN(MCIND)
25753
25754       RETURN
25755       END
25756
25757 *$ CREATE DT_FLAHAD.FOR
25758 *COPY DT_FLAHAD
25759 *
25760 *===flahad=============================================================*
25761 *
25762       SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
25763
25764 ************************************************************************
25765 * sampling of FLAvor composition for HADrons/photons                   *
25766 *              ID         BAMJET-id of hadron                          *
25767 *              IF1,2,3    flavor content                               *
25768 *                         (u,d,s: 1,2,3;  au,ad,as: -1,-1,-3)          *
25769 * Note:  -  u,d numbering as in BAMJET                                 *
25770 *        -  ID .le. 30 !!                                              *
25771 * This version dated 12.03.96 is written by S. Roesler                 *
25772 ************************************************************************
25773
25774       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25775       SAVE
25776
25777 * auxiliary common for reggeon exchange (DTUNUC 1.x)
25778       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
25779      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
25780      &                IQTCHR(-6:6),MQUARK(3,39)
25781
25782       DIMENSION JSEL(3,6)
25783       DATA JSEL/ 1,2,3,  2,3,1,  3,1,2,  1,3,2,   2,1,3,   3,2,1/
25784
25785       ONE = 1.0D0
25786       IF (ID.EQ.7) THEN
25787 * photon (charge dependent flavour sampling)
25788          K = INT(DT_RNDM(ONE)*6.D0+1.D0)
25789          IF (K.LE.4) THEN
25790             IF1 = 2
25791             IF2 = -2
25792          ELSE IF(K.EQ.5) THEN
25793             IF1 = 1
25794             IF2 = -1
25795          ELSE
25796             IF1 = 3
25797             IF2 = -3
25798          ENDIF
25799          IF(DT_RNDM(ONE).LT.0.5D0) THEN
25800             K   = IF1
25801             IF1 = IF2
25802             IF2 = K
25803          ENDIF
25804          IF3 = 0
25805       ELSE
25806 * hadron
25807          IX  = INT(1.0D0+5.99999D0*DT_RNDM(ONE))
25808          IF1 = MQUARK(JSEL(1,IX),ID)
25809          IF2 = MQUARK(JSEL(2,IX),ID)
25810          IF3 = MQUARK(JSEL(3,IX),ID)
25811          IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN
25812             IF1 = IF3
25813             IF3 = 0
25814          ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
25815             IF2 = IF3
25816             IF3 = 0
25817          ENDIF
25818       ENDIF
25819
25820       RETURN
25821       END
25822
25823 *$ CREATE IDT_MCHAD.FOR
25824 *COPY IDT_MCHAD
25825 *
25826 *===mchad==============================================================*
25827 *
25828       INTEGER FUNCTION IDT_MCHAD(ITDTU)
25829
25830 ************************************************************************
25831 * Conversion of particle index BAMJET-index scheme --> HADRIN index s. *
25832 * Adopted from the original by S. Roesler. This version dated 6.5.95   *
25833 *                                                                      *
25834 * Last change 28.12.2006 by S. Roesler.                                *
25835 ************************************************************************
25836
25837       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25838       SAVE
25839
25840       DIMENSION ITRANS(210)
25841       DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14,
25842      &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13,
25843      &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8,
25844      &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2,
25845      &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1,
25846      &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9,
25847      &9, 9, 9, 85*- 1,7*-1,1,8,-1/
25848
25849       IF ( ITDTU .GT. 0 ) THEN
25850          IDT_MCHAD = ITRANS(ITDTU)
25851       ELSE
25852          IDT_MCHAD = -1
25853       END IF
25854
25855       RETURN
25856       END
25857
25858 ************************************************************************
25859 *                                                                      *
25860 *   3) Energy-momentum and quantum number conservation check routines  *
25861 *                                                                      *
25862 ************************************************************************
25863 *$ CREATE DT_EMC1.FOR
25864 *COPY DT_EMC1
25865 *
25866 *===emc1===============================================================*
25867 *
25868       SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
25869
25870 ************************************************************************
25871 * This version dated 15.12.94 is written by S. Roesler                 *
25872 ************************************************************************
25873
25874       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25875       SAVE
25876       PARAMETER ( LINP = 10 ,
25877      &            LOUT = 6 ,
25878      &            LDAT = 9 )
25879       PARAMETER (TINY10=1.0D-10)
25880
25881       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
25882
25883       IREJ = 0
25884
25885       IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
25886      &   WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
25887
25888       IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN
25889          IF (MODE.EQ.1) THEN
25890             CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM)
25891          ELSEIF (MODE.EQ.2) THEN
25892             CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM)
25893          ENDIF
25894          CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM)
25895          CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM)
25896          CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM)
25897       ELSEIF (MODE.LT.0) THEN
25898          IF (MODE.EQ.-1) THEN
25899             CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM)
25900          ELSEIF (MODE.EQ.-2) THEN
25901             CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM)
25902          ENDIF
25903          CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM)
25904          CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM)
25905          CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM)
25906       ENDIF
25907
25908       IF (ABS(MODE).EQ.3) THEN
25909          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1)
25910          IF (IREJ1.NE.0) GOTO 9999
25911       ENDIF
25912       RETURN
25913
25914  9999 CONTINUE
25915       IREJ = 1
25916       RETURN
25917       END
25918
25919 *$ CREATE DT_EMC2.FOR
25920 *COPY DT_EMC2
25921 *
25922 *===emc2===============================================================*
25923 *
25924       SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
25925      &                                                MODE,IPOS,IREJ)
25926
25927 ************************************************************************
25928 *             MODE = 1   energy-momentum cons. check                   *
25929 *                  = 2   flavor-cons. check                            *
25930 *                  = 3   energy-momentum & flavor cons. check          *
25931 *                  = 4   energy-momentum & charge cons. check          *
25932 *                  = 5   energy-momentum & flavor & charge cons. check *
25933 * This version dated 16.01.95 is written by S. Roesler                 *
25934 ************************************************************************
25935
25936       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25937       SAVE
25938       PARAMETER ( LINP = 10 ,
25939      &            LOUT = 6 ,
25940      &            LDAT = 9 )
25941       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
25942
25943 * event history
25944       PARAMETER (NMXHKK=200000)
25945       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25946      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25947      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25948 * extended event history
25949       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25950      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25951      &                IHIST(2,NMXHKK)
25952
25953       IREJ  = 0
25954       IREJ1 = 0
25955       IREJ2 = 0
25956       IREJ3 = 0
25957
25958       IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25959      &                CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM)
25960       IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25961      &                                CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM)
25962       IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM)
25963       DO 1 I=1,NHKK
25964          IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR.
25965      &       (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR.
25966      &       (ISTHKK(I).EQ.IP5))                          THEN
25967             IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25968      &                                    .OR.(MODE.EQ.5))
25969      &      CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
25970      &                                               2,IDUM,IDUM)
25971             IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25972      &         CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM)
25973             IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25974      &                            CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM)
25975          ENDIF
25976          IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR.
25977      &       (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR.
25978      &       (ISTHKK(I).EQ.IN5))                          THEN
25979             IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25980      &                                    .OR.(MODE.EQ.5))
25981      &      CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
25982      &                                                   2,IDUM,IDUM)
25983             IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25984      &         CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM)
25985             IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25986      &                            CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM)
25987          ENDIF
25988     1 CONTINUE
25989       IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25990      &   CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1)
25991       IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25992      &   CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2)
25993       IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3)
25994       IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999
25995
25996       RETURN
25997
25998  9999 CONTINUE
25999       IREJ = 1
26000       RETURN
26001       END
26002
26003 *$ CREATE DT_EVTEMC.FOR
26004 *COPY DT_EVTEMC
26005 *
26006 *===evtemc=============================================================*
26007 *
26008       SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
26009
26010 ************************************************************************
26011 * This version dated 13.12.94 is written by S. Roesler                 *
26012 ************************************************************************
26013
26014       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26015       SAVE
26016       PARAMETER ( LINP = 10 ,
26017      &            LOUT = 6 ,
26018      &            LDAT = 9 )
26019       PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10,
26020      &           ZERO=0.0D0)
26021
26022 * event history
26023       PARAMETER (NMXHKK=200000)
26024       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26025      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26026      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26027 * flags for input different options
26028       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
26029       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
26030      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
26031
26032       IREJ = 0
26033
26034       MODE = IMODE
26035       CHKLEV = TINY10
26036       IF (MODE.EQ.4) THEN
26037          CHKLEV = TINY2
26038          MODE   = 3
26039       ELSEIF (MODE.EQ.5) THEN
26040          CHKLEV = TINY1
26041          MODE   = 3
26042       ELSEIF (MODE.EQ.-1) THEN
26043          CHKLEV = EIO
26044          MODE   = 3
26045       ENDIF
26046
26047       IF (ABS(MODE).EQ.3) THEN
26048          PXDEV = PX
26049          PYDEV = PY
26050          PZDEV = PZ
26051          EDEV  = E
26052          IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4
26053          IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR.
26054      &       (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN
26055             IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)')
26056      &         'EVTEMC: energy-momentum cons. failure at pos. ',IPOS,
26057      &         '  event  ',NEVHKK,
26058      &         ' ! ',PXDEV,PYDEV,PZDEV,EDEV
26059             PX   = 0.0D0
26060             PY   = 0.0D0
26061             PZ   = 0.0D0
26062             E    = 0.0D0
26063             GOTO 9999
26064          ENDIF
26065          PX   = 0.0D0
26066          PY   = 0.0D0
26067          PZ   = 0.0D0
26068          E    = 0.0D0
26069          RETURN
26070       ENDIF
26071
26072       IF (MODE.EQ.1) THEN
26073          PX = 0.0D0
26074          PY = 0.0D0
26075          PZ = 0.0D0
26076          E  = 0.0D0
26077       ENDIF
26078
26079       PX = PX+PXIO
26080       PY = PY+PYIO
26081       PZ = PZ+PZIO
26082       E  = E+EIO
26083
26084       RETURN
26085
26086  9999 CONTINUE
26087       IREJ = 1
26088       RETURN
26089       END
26090
26091 *$ CREATE DT_EVTFLC.FOR
26092 *COPY DT_EVTFLC
26093 *
26094 *===evtflc=============================================================*
26095 *
26096       SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
26097
26098 ************************************************************************
26099 * Flavor conservation check.                                           *
26100 *        ID       identity of particle                                 *
26101 *        ID1 = 1  ID for q,aq,qq,aqaq in PDG-numbering scheme          *
26102 *            = 2  ID for particle/resonance in BAMJET numbering scheme *
26103 *            = 3  ID for particle/resonance in PDG    numbering scheme *
26104 *        MODE = 1 initialization and add ID                            *
26105 *             =-1 initialization and subtract ID                       *
26106 *             = 2 add ID                                               *
26107 *             =-2 subtract ID                                          *
26108 *             = 3 check flavor cons.                                   *
26109 *        IPOS     flag to give position of call of EVTFLC to output    *
26110 *                 unit in case of violation                            *
26111 * This version dated 10.01.95 is written by S. Roesler                 *
26112 ************************************************************************
26113
26114       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26115       SAVE
26116       PARAMETER ( LINP = 10 ,
26117      &            LOUT = 6 ,
26118      &            LDAT = 9 )
26119       PARAMETER (TINY10=1.0D-10)
26120
26121       IREJ = 0
26122
26123       IF (MODE.EQ.3) THEN
26124          IF (IFL.NE.0) THEN
26125             WRITE(LOUT,'(1X,A,I3,A,I3)')
26126      &         'EVTFLC: flavor-conservation failure at pos. ',IPOS,
26127      &         ' !  IFL = ',IFL
26128             IFL = 0
26129             GOTO 9999
26130          ENDIF
26131          IFL = 0
26132          RETURN
26133       ENDIF
26134
26135       IF (MODE.EQ.1) IFL = 0
26136       IF (ID.EQ.0)   RETURN
26137
26138       IF (ID1.EQ.1) THEN
26139          IDD = ABS(ID)
26140          NQ  = 1
26141          IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
26142          IF (IDD.GE.1000) NQ = 3
26143          DO 1 I=1,NQ
26144             IFBAM = IDT_IPDG2B(ID,I,2)
26145             IF (ABS(IFBAM).EQ.1) THEN
26146                IFBAM = SIGN(2,IFBAM)
26147             ELSEIF (ABS(IFBAM).EQ.2) THEN
26148                IFBAM = SIGN(1,IFBAM)
26149             ENDIF
26150             IF (MODE.GT.0) THEN
26151                IFL = IFL+IFBAM
26152             ELSE
26153                IFL = IFL-IFBAM
26154             ENDIF
26155     1    CONTINUE
26156          RETURN
26157       ENDIF
26158
26159       IDD = ID
26160       IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
26161       IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
26162          DO 2 I=1,3
26163             IF (MODE.GT.0) THEN
26164                IFL = IFL+IDT_IQUARK(I,IDD)
26165             ELSE
26166                IFL = IFL-IDT_IQUARK(I,IDD)
26167             ENDIF
26168     2    CONTINUE
26169       ENDIF
26170       RETURN
26171
26172  9999 CONTINUE
26173       IREJ = 1
26174       RETURN
26175       END
26176
26177 *$ CREATE DT_EVTCHG.FOR
26178 *COPY DT_EVTCHG
26179 *
26180 *===evtchg=============================================================*
26181 *
26182       SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
26183
26184 ************************************************************************
26185 * Charge conservation check.                                           *
26186 *        ID       identity of particle (PDG-numbering scheme)          *
26187 *        MODE = 1 initialization                                       *
26188 *             =-2 subtract ID-charge                                   *
26189 *             = 2 add ID-charge                                        *
26190 *             = 3 check charge cons.                                   *
26191 *        IPOS     flag to give position of call of EVTCHG to output    *
26192 *                 unit in case of violation                            *
26193 * This version dated 10.01.95 is written by S. Roesler                 *
26194 * Last change: s.r. 21.01.01                                           *
26195 ************************************************************************
26196
26197       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26198       SAVE
26199       PARAMETER ( LINP = 10 ,
26200      &            LOUT = 6 ,
26201      &            LDAT = 9 )
26202
26203 * event history
26204       PARAMETER (NMXHKK=200000)
26205       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26206      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26207      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26208 * particle properties (BAMJET index convention)
26209       CHARACTER*8  ANAME
26210       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26211      &                IICH(210),IIBAR(210),K1(210),K2(210)
26212
26213       IREJ = 0
26214
26215       IF (MODE.EQ.1) THEN
26216          ICH  = 0
26217          IBAR = 0
26218          RETURN
26219       ENDIF
26220
26221       IF (MODE.EQ.3) THEN
26222          IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN
26223             WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)')
26224      &         'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS,
26225      &         '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK
26226             ICH  = 0
26227             IBAR = 0
26228             GOTO 9999
26229          ENDIF
26230          ICH  = 0
26231          IBAR = 0
26232          RETURN
26233       ENDIF
26234
26235       IF (ID.EQ.0)   RETURN
26236
26237       IDD = IDT_ICIHAD(ID)
26238 * modification 21.1.01: use intrinsic phojet-functions to determine charge
26239 * and baryon number
26240 C     IF (IDD.GT.0) THEN
26241 C        IF (MODE.EQ.2) THEN
26242 C           ICH  = ICH+IICH(IDD)
26243 C           IBAR = IBAR+IIBAR(IDD)
26244 C        ELSEIF (MODE.EQ.-2) THEN
26245 C           ICH  = ICH-IICH(IDD)
26246 C           IBAR = IBAR-IIBAR(IDD)
26247 C        ENDIF
26248 C     ELSE
26249 C        WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
26250 C        CALL DT_EVTOUT(4)
26251 C        STOP
26252 C     ENDIF
26253       IF (MODE.EQ.2) THEN
26254          ICH  = ICH+IPHO_CHR3(ID,1)/3
26255          IBAR = IBAR+IPHO_BAR3(ID,1)/3
26256       ELSEIF (MODE.EQ.-2) THEN
26257          ICH  = ICH-IPHO_CHR3(ID,1)/3
26258          IBAR = IBAR-IPHO_BAR3(ID,1)/3
26259       ENDIF
26260
26261       RETURN
26262
26263  9999 CONTINUE
26264       IREJ = 1
26265       RETURN
26266       END
26267
26268 ************************************************************************
26269 *                                                                      *
26270 *                 4) Transformations                                   *
26271 *                                                                      *
26272 ************************************************************************
26273 *$ CREATE DT_LTINI.FOR
26274 *COPY DT_LTINI
26275 *
26276 *===ltini==============================================================*
26277 *
26278       SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
26279
26280 ************************************************************************
26281 * Initializations of Lorentz-transformations, calculation of Lorentz-  *
26282 * parameters.                                                          *
26283 * This version dated 13.11.95 is written by  S. Roesler.               *
26284 ************************************************************************
26285
26286       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26287       SAVE
26288       PARAMETER ( LINP = 10 ,
26289      &            LOUT = 6 ,
26290      &            LDAT = 9 )
26291       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,
26292      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
26293
26294 * Lorentz-parameters of the current interaction
26295       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26296      &                UMO,PPCM,EPROJ,PPROJ
26297 * properties of photon/lepton projectiles
26298       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
26299 * particle properties (BAMJET index convention)
26300       CHARACTER*8  ANAME
26301       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26302      &                IICH(210),IIBAR(210),K1(210),K2(210)
26303 * nucleon-nucleon event-generator
26304       CHARACTER*8 CMODEL
26305       LOGICAL LPHOIN
26306       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
26307
26308       Q2   = VIRT
26309       IDP  = IDPR
26310       IF (MCGENE.NE.3) THEN
26311 * lepton-projectiles and PHOJET: initialize real photon instead
26312          IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26313      &       (IDPR.EQ.10).OR.(IDPR.EQ.11).OR.
26314      &       (IDPR.EQ. 5).OR.(IDPR.EQ. 6))   THEN
26315             IDP = 7
26316             Q2  = ZERO
26317          ENDIF
26318       ENDIF
26319       IDT  = IDTA
26320       EPN  = EPN0
26321       PPN  = PPN0
26322       ECM  = ECM0
26323       AMP  = AAM(IDP)-SQRT(ABS(Q2))
26324       AMT  = AAM(IDT)
26325       AMP2 = SIGN(AMP**2,AMP)
26326       AMT2 = AMT**2
26327       IF (ECM0.GT.ZERO) THEN
26328          EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT)
26329          IF (AMP2.GT.ZERO) THEN
26330             PPN = SQRT((EPN+AMP)*(EPN-AMP))
26331          ELSE
26332             PPN = SQRT(EPN**2-AMP2)
26333          ENDIF
26334       ELSE
26335          IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26336             IF (IDP.EQ.7) EPN = ABS(EPN)
26337             IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP
26338             IF (AMP2.GT.ZERO) THEN
26339                PPN = SQRT((EPN+AMP)*(EPN-AMP))
26340             ELSE
26341                PPN = SQRT(EPN**2-AMP2)
26342             ENDIF
26343          ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26344             IF (AMP2.GT.ZERO) THEN
26345                EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
26346             ELSE
26347                EPN = SQRT(PPN**2+AMP2)
26348             ENDIF
26349          ENDIF
26350          ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
26351       ENDIF
26352       UMO   = ECM
26353       EPROJ = EPN
26354       PPROJ = PPN
26355       IF (AMP2.GT.ZERO) THEN
26356          ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
26357          PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
26358       ELSE
26359          ETARG = TINY10
26360          PTARG = TINY10
26361       ENDIF
26362 * photon-projectiles (get momentum in cm-frame for virtuality Q^2)
26363       IF (IDP.EQ.7) THEN
26364          PGAMM(1) = ZERO
26365          PGAMM(2) = ZERO
26366          AMGAM  = AMP
26367          AMGAM2 = AMP2
26368          IF (ECM0.GT.ZERO) THEN
26369             S = ECM0**2
26370          ELSE
26371             IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26372                S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0)
26373             ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26374                S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2)
26375             ENDIF
26376          ENDIF
26377          PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2
26378      &                     +AMGAM2**2+AMT2**2)/(4.0D0*S) )
26379          PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2)
26380          IF (MODE.EQ.1) THEN
26381             PNUCL(1) = ZERO
26382             PNUCL(2) = ZERO
26383             PNUCL(3) = -PGAMM(3)
26384             PNUCL(4) = SQRT(S)-PGAMM(4)
26385          ENDIF
26386       ENDIF
26387       IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26388      &    (IDPR.EQ.10).OR.(IDPR.EQ.11))   THEN
26389          PLEPT0(1) = ZERO
26390          PLEPT0(2) = ZERO
26391 * neglect lepton masses
26392 C        AMLPT2   = AAM(IDPR)**2
26393          AMLPT2   = ZERO
26394 *
26395          IF (ECM0.GT.ZERO) THEN
26396             S = ECM0**2
26397          ELSE
26398             IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26399                S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0)
26400             ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26401                S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2)
26402             ENDIF
26403          ENDIF
26404          PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2
26405      &                     +AMLPT2**2+AMT2**2)/(4.0D0*S) )
26406          PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2)
26407          PNUCL(1) = ZERO
26408          PNUCL(2) = ZERO
26409          PNUCL(3) = -PLEPT0(3)
26410          PNUCL(4) = SQRT(S)-PLEPT0(4)
26411       ENDIF
26412 * Lorentz-parameter for transformation Lab. - projectile rest system
26413       IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
26414          GALAB = TINY10
26415          BGLAB = TINY10
26416          BLAB  = TINY10
26417       ELSE
26418          GALAB = EPROJ/AMP
26419          BGLAB = PPROJ/AMP
26420          BLAB  = BGLAB/GALAB
26421       ENDIF
26422 * Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
26423       IF (IDP.EQ.7) THEN
26424          GACMS(1) = TINY10
26425          BGCMS(1) = TINY10
26426       ELSE
26427          GACMS(1) = (ETARG+AMP)/UMO
26428          BGCMS(1) = PTARG/UMO
26429       ENDIF
26430 * Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
26431       GACMS(2) = (EPROJ+AMT)/UMO
26432       BGCMS(2) = PPROJ/UMO
26433       PPCM     = GACMS(2)*PPROJ-BGCMS(2)*EPROJ
26434
26435       EPN0 = EPN
26436       PPN0 = PPN
26437       ECM0 = ECM
26438
26439       RETURN
26440       END
26441
26442 *$ CREATE DT_LTRANS.FOR
26443 *COPY DT_LTRANS
26444 *
26445 *===ltrans=============================================================*
26446 *
26447       SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
26448
26449 ************************************************************************
26450 * Lorentz-transformations.                                             *
26451 *   MODE = 1(-1)    projectile rest syst.   --> Lab (back)             *
26452 *        = 2(-2)    projectile rest syst.   --> nucl.-nucl.cms (back)  *
26453 *        = 3(-3)    target rest syst. (=Lab)--> nucl.-nucl.cms (back)  *
26454 * This version dated 01.11.95 is written by  S. Roesler.               *
26455 ************************************************************************
26456
26457       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26458       SAVE
26459       PARAMETER ( LINP = 10 ,
26460      &            LOUT = 6 ,
26461      &            LDAT = 9 )
26462       PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
26463
26464       PARAMETER (SQTINF=1.0D+15)
26465
26466 * particle properties (BAMJET index convention)
26467       CHARACTER*8  ANAME
26468       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26469      &                IICH(210),IIBAR(210),K1(210),K2(210)
26470
26471       PXO = PXI
26472       PYO = PYI
26473       CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
26474
26475 * check particle mass for consistency (numerical rounding errors)
26476       PO     = SQRT(PXO*PXO+PYO*PYO+PZO*PZO)
26477       AMO2   = (PEO-PO)*(PEO+PO)
26478       AMORQ2 = AAM(ID)**2
26479       AMDIF2 = ABS(AMO2-AMORQ2)
26480       IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN
26481          DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO))
26482          PEO   = PEO+DELTA
26483          PO1   = PO -DELTA
26484          PXO   = PXO*PO1/PO
26485          PYO   = PYO*PO1/PO
26486          PZO   = PZO*PO1/PO
26487 C        WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
26488       ENDIF
26489
26490       RETURN
26491       END
26492
26493 *$ CREATE DT_LTNUC.FOR
26494 *COPY DT_LTNUC
26495 *
26496 *===ltnuc==============================================================*
26497 *
26498       SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
26499
26500 ************************************************************************
26501 * Lorentz-transformations.                                             *
26502 *   PIN        longitudnal momentum       (input)                      *
26503 *   EIN        energy                     (input)                      *
26504 *   POUT       transformed long. momentum (output)                     *
26505 *   EOUT       transformed energy         (output)                     *
26506 *   MODE = 1(-1)    projectile rest syst.   --> Lab (back)             *
26507 *        = 2(-2)    projectile rest syst.   --> nucl.-nucl.cms (back)  *
26508 *        = 3(-3)    target rest syst. (=Lab)--> nucl.-nucl.cms (back)  *
26509 * This version dated 01.11.95 is written by  S. Roesler.               *
26510 ************************************************************************
26511
26512       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26513       SAVE
26514       PARAMETER ( LINP = 10 ,
26515      &            LOUT = 6 ,
26516      &            LDAT = 9 )
26517       PARAMETER (ZERO=0.0D0)
26518
26519 * Lorentz-parameters of the current interaction
26520       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26521      &                UMO,PPCM,EPROJ,PPROJ
26522
26523       BDUM1 = ZERO
26524       BDUM2 = ZERO
26525       PDUM1 = ZERO
26526       PDUM2 = ZERO
26527       IF (ABS(MODE).EQ.1) THEN
26528          BG = -SIGN(BGLAB,DBLE(MODE))
26529          CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN,
26530      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26531       ELSEIF (ABS(MODE).EQ.2) THEN
26532          BG = SIGN(BGCMS(1),DBLE(MODE))
26533          CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26534      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26535       ELSEIF (ABS(MODE).EQ.3) THEN
26536          BG = -SIGN(BGCMS(2),DBLE(MODE))
26537          CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26538      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26539       ELSE
26540          WRITE(LOUT,1000) MODE
26541  1000    FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
26542          EOUT = EIN
26543          POUT = PIN
26544       ENDIF
26545
26546       RETURN
26547       END
26548
26549 *$ CREATE DT_DALTRA.FOR
26550 *COPY DT_DALTRA
26551 *
26552 *===daltra=============================================================*
26553 *
26554       SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
26555
26556 ************************************************************************
26557 * Arbitrary Lorentz-transformation.                                    *
26558 * Adopted from the original by S. Roesler. This version dated 15.01.95 *
26559 ************************************************************************
26560
26561       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26562       SAVE
26563       PARAMETER (ONE=1.0D0)
26564
26565       EP = PCX*BGX+PCY*BGY+PCZ*BGZ
26566       PE = EP/(GA+ONE)+EC
26567       PX = PCX+BGX*PE
26568       PY = PCY+BGY*PE
26569       PZ = PCZ+BGZ*PE
26570       P  = SQRT(PX*PX+PY*PY+PZ*PZ)
26571       E  = GA*EC+EP
26572
26573       RETURN
26574       END
26575
26576 *$ CREATE DT_DTRAFO.FOR
26577 *COPY DT_DTRAFO
26578 *
26579 *====dtrafo============================================================*
26580 *
26581       SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
26582      &                                    PL,CXL,CYL,CZL,EL)
26583
26584 C     LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
26585
26586       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26587       SAVE
26588
26589       IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
26590       SID  = SQRT(1.D0-COD*COD)
26591       PLX  = P*SID*COF
26592       PLY  = P*SID*SIF
26593       PCMZ = P*COD
26594       PLZ  = GAM*PCMZ+BGAM*ECM
26595       PL   = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
26596       EL   = GAM*ECM+BGAM*PCMZ
26597 C     ROTATION INTO THE ORIGINAL DIRECTION
26598       COZ  = PLZ/PL
26599       SIZ  = SQRT(1.D0-COZ**2)
26600       CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
26601
26602       RETURN
26603       END
26604
26605 *$ CREATE DT_STTRAN.FOR
26606 *COPY DT_STTRAN
26607 *
26608 *====sttran============================================================*
26609 *
26610       SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
26611
26612       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26613       SAVE
26614       DATA ANGLSQ/1.D-30/
26615 ************************************************************************
26616 *     VERSION BY                     J. RANFT                          *
26617 *                                    LEIPZIG                           *
26618 *                                                                      *
26619 *     THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES      *
26620 *                                                                      *
26621 *     INPUT VARIABLES:                                                 *
26622 *        XO,YO,ZO = ORIGINAL DIRECTION COSINES                         *
26623 *        CDE,SDE  = COSINE AND SINE OF THE POLAR (THETA)               *
26624 *                   ANGLE OF "SCATTERING"                              *
26625 *        SDE      = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING"    *
26626 *        SFE,CFE  = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE       *
26627 *                   OF "SCATTERING"                                    *
26628 *                                                                      *
26629 *     OUTPUT VARIABLES:                                                *
26630 *        X,Y,Z     = NEW DIRECTION COSINES                             *
26631 *                                                                      *
26632 *     ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 )                  *
26633 ************************************************************************
26634 *
26635 *
26636 *  Changed by A. Ferrari
26637 *
26638 *     IF (ABS(XO)-0.0001D0) 1,1,2
26639 *   1 IF (ABS(YO)-0.0001D0) 3,3,2
26640 *   3 CONTINUE
26641       A = XO**2 + YO**2
26642       IF ( A .LT. ANGLSQ ) THEN
26643          X=SDE*CFE
26644          Y=SDE*SFE
26645          Z=CDE*ZO
26646       ELSE
26647          XI=SDE*CFE
26648          YI=SDE*SFE
26649          ZI=CDE
26650          A=SQRT(A)
26651          X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
26652          Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
26653          Z=A*YI+ZO*ZI
26654       ENDIF
26655
26656       RETURN
26657       END
26658
26659 *$ CREATE DT_MYTRAN.FOR
26660 *COPY DT_MYTRAN
26661 *
26662 *===mytran=============================================================*
26663 *
26664       SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
26665
26666 ************************************************************************
26667 * This subroutine rotates the coordinate frame                         *
26668 *    a) theta  around y                                                *
26669 *    b) phi    around z      if IMODE = 1                              *
26670 *                                                                      *
26671 *     x'          cos(ph) -sin(ph) 0      cos(th)  0  sin(th)   x      *
26672 *     y' = A B =  sin(ph) cos(ph)  0  .   0        1        0   y      *
26673 *     z'          0       0        1     -sin(th)  0  cos(th)   z      *
26674 *                                                                      *
26675 * and vice versa if IMODE = 0.                                         *
26676 * This version dated 5.4.94 is based on the original version DTRAN     *
26677 * by J. Ranft and is written by S. Roesler.                            *
26678 ************************************************************************
26679
26680       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26681       SAVE
26682       PARAMETER ( LINP = 10 ,
26683      &            LOUT = 6 ,
26684      &            LDAT = 9 )
26685
26686       IF (IMODE.EQ.1) THEN
26687          X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
26688          Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
26689          Z=-SDE    *XO       +CDE    *ZO
26690       ELSE
26691          X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
26692          Y= -SFE*XO+CFE*YO
26693          Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
26694       ENDIF
26695       RETURN
26696       END
26697
26698 *$ CREATE DT_LT2LAO.FOR
26699 *COPY DT_LT2LAO
26700 *
26701 *===lt2lab=============================================================*
26702 *
26703       SUBROUTINE DT_LT2LAO
26704
26705 ************************************************************************
26706 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1   *
26707 * for final state particles/fragments defined in nucleon-nucleon-cms   *
26708 * and transforms them back to the lab.                                 *
26709 * This version dated 16.11.95 is written by S. Roesler                 *
26710 ************************************************************************
26711
26712       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26713       SAVE
26714       PARAMETER ( LINP = 10 ,
26715      &            LOUT = 6 ,
26716      &            LDAT = 9 )
26717
26718 * event history
26719       PARAMETER (NMXHKK=200000)
26720       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26721      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26722      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26723 * extended event history
26724       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26725      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26726      &                IHIST(2,NMXHKK)
26727
26728       NEND      = NHKK
26729       NPOINT(5) = NHKK+1
26730       IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
26731       DO 1 I=NPOINT(4),NEND
26732 C     DO 1 I=1,NEND
26733          IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26734      &                                (ISTHKK(I).EQ.1001)) THEN
26735             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26736             NOB = NOBAM(I)
26737             CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I),
26738      &                            PZ,PE,IDRES(I),IDXRES(I),IDCH(I))
26739             IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN
26740                ISTHKK(I) = 3*ISTHKK(I)
26741                NOBAM(NHKK)  = NOB
26742             ELSE
26743                IF (ISTHKK(I).EQ.-1) NOBAM(NHKK)  = NOB
26744                ISTHKK(I) = SIGN(3,ISTHKK(I))
26745             ENDIF
26746             JDAHKK(1,I) = NHKK
26747          ENDIF
26748     1 CONTINUE
26749
26750       RETURN
26751       END
26752
26753 *$ CREATE DT_LT2LAB.FOR
26754 *COPY DT_LT2LAB
26755 *
26756 *===lt2lab=============================================================*
26757 *
26758       SUBROUTINE DT_LT2LAB
26759
26760 ************************************************************************
26761 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1   *
26762 * for final state particles/fragments defined in nucleon-nucleon-cms   *
26763 * and transforms them to the lab.                                      *
26764 * This version dated 07.01.96 is written by S. Roesler                 *
26765 ************************************************************************
26766
26767       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26768       SAVE
26769       PARAMETER ( LINP = 10 ,
26770      &            LOUT = 6 ,
26771      &            LDAT = 9 )
26772
26773 * event history
26774       PARAMETER (NMXHKK=200000)
26775       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26776      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26777      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26778 * extended event history
26779       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26780      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26781      &                IHIST(2,NMXHKK)
26782
26783       IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
26784       DO 1 I=NPOINT(4),NHKK
26785          IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26786      &                                (ISTHKK(I).EQ.1001)) THEN
26787
26788             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26789             PHKK(3,I) = PZ
26790             PHKK(4,I) = PE
26791          ENDIF
26792     1 CONTINUE
26793
26794       RETURN
26795       END
26796
26797 ************************************************************************
26798 *                                                                      *
26799 *                 5) Sampling from distributions                       *
26800 *                                                                      *
26801 ************************************************************************
26802 *$ CREATE IDT_NPOISS.FOR
26803 *COPY IDT_NPOISS
26804 *
26805 *===npoiss=============================================================*
26806 *
26807       INTEGER FUNCTION IDT_NPOISS(AVN)
26808
26809 ************************************************************************
26810 * Sample according to Poisson distribution with Poisson parameter AVN. *
26811 * The original version written by J. Ranft.                            *
26812 * This version dated 11.1.95 is written by S. Roesler.                 *
26813 ************************************************************************
26814
26815       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26816       SAVE
26817       PARAMETER ( LINP = 10 ,
26818      &            LOUT = 6 ,
26819      &            LDAT = 9 )
26820
26821       EXPAVN = EXP(-AVN)
26822       K = 1
26823       A = 1.0D0
26824
26825    10 CONTINUE
26826       A = DT_RNDM(A)*A
26827       IF (A.GE.EXPAVN) THEN
26828          K = K+1
26829          GOTO 10
26830       ENDIF
26831       IDT_NPOISS = K-1
26832
26833       RETURN
26834       END
26835
26836 *$ CREATE DT_SAMPXB.FOR
26837 *COPY DT_SAMPXB
26838 *
26839 *===sampxb=============================================================*
26840 *
26841       DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
26842
26843 ************************************************************************
26844 * Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2.             *
26845 * Processed by S. Roesler, 6.5.95                                      *
26846 ************************************************************************
26847
26848       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26849       SAVE
26850       PARAMETER (TWO=2.0D0)
26851
26852       A1 = LOG(X1+SQRT(X1**2+B**2))
26853       A2 = LOG(X2+SQRT(X2**2+B**2))
26854       AN = A2-A1
26855       A  = AN*DT_RNDM(A1)+A1
26856       BB = EXP(A)
26857       DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
26858
26859       RETURN
26860       END
26861
26862 *$ CREATE DT_SAMPEX.FOR
26863 *COPY DT_SAMPEX
26864 *
26865 *===sampex=============================================================*
26866 *
26867       DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
26868
26869 ************************************************************************
26870 * Sampling from f(x)=1./x between x1 and x2.                           *
26871 * Processed by S. Roesler, 6.5.95                                      *
26872 ************************************************************************
26873
26874       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26875       SAVE
26876       PARAMETER (ONE=1.0D0)
26877
26878       R   = DT_RNDM(X1)
26879       AL1 = LOG(X1)
26880       AL2 = LOG(X2)
26881       DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
26882
26883       RETURN
26884       END
26885
26886 *$ CREATE DT_SAMSQX.FOR
26887 *COPY DT_SAMSQX
26888 *
26889 *===samsqx=============================================================*
26890 *
26891       DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
26892
26893 ************************************************************************
26894 * Sampling from f(x)=1./x^0.5 between x1 and x2.                       *
26895 * Processed by S. Roesler, 6.5.95                                      *
26896 ************************************************************************
26897
26898       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26899       SAVE
26900       PARAMETER (ONE=1.0D0)
26901
26902       R = DT_RNDM(X1)
26903       DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
26904
26905       RETURN
26906       END
26907
26908 *$ CREATE DT_SAMPLW.FOR
26909 *COPY DT_SAMPLW
26910 *
26911 *===samplw=============================================================*
26912 *
26913       DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
26914
26915 ************************************************************************
26916 * Sampling from f(x)=1/x^b between x_min and x_max.                    *
26917 * S. Roesler, 18.4.98                                                  *
26918 ************************************************************************
26919
26920       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26921       SAVE
26922       PARAMETER (ONE=1.0D0)
26923
26924       R = DT_RNDM(B)
26925       IF (B.EQ.ONE) THEN
26926          DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
26927       ELSE
26928          ONEMB  = ONE-B
26929          DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
26930       ENDIF
26931
26932       RETURN
26933       END
26934
26935 *$ CREATE DT_BETREJ.FOR
26936 *COPY DT_BETREJ
26937 *
26938 *===betrej=============================================================*
26939 *
26940       DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
26941
26942       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26943       SAVE
26944
26945       PARAMETER ( LINP = 10 ,
26946      &            LOUT = 6 ,
26947      &            LDAT = 9 )
26948       PARAMETER (ONE=1.0D0)
26949
26950       IF (XMIN.GE.XMAX)THEN
26951          WRITE (LOUT,500) XMIN,XMAX
26952   500    FORMAT(1X,'DT_BETREJ:  XMIN<XMAX execution stopped ',2F10.5)
26953          STOP
26954       ENDIF
26955
26956    10 CONTINUE
26957       XX     = XMIN+(XMAX-XMIN)*DT_RNDM(ETA)
26958       BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE)
26959       YY     = BETMAX*DT_RNDM(XX)
26960       BETXX  = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE)
26961       IF (YY.GT.BETXX) GOTO 10
26962       DT_BETREJ = XX
26963
26964       RETURN
26965       END
26966
26967 *$ CREATE DT_DGAMRN.FOR
26968 *COPY DT_DGAMRN
26969 *
26970 *===dgamrn=============================================================*
26971 *
26972       DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
26973
26974 ************************************************************************
26975 * Sampling from Gamma-distribution.                                    *
26976 *       F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)            *
26977 * Processed by S. Roesler, 6.5.95                                      *
26978 ************************************************************************
26979
26980       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26981       SAVE
26982       PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
26983
26984       NCOU = 0
26985       N    = INT(ETA)
26986       F    = ETA-DBLE(N)
26987       IF (F.EQ.ZERO) GOTO 20
26988    10 R = DT_RNDM(F)
26989       NCOU = NCOU+1
26990       IF (NCOU.GE.11) GOTO 20
26991       IF (R.LT.F/(F+2.71828D0)) GOTO 30
26992       YYY = LOG(DT_RNDM(R)+TINY9)/F
26993       IF (ABS(YYY).GT.50.0D0) GOTO 20
26994       Y = EXP(YYY)
26995       IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
26996       GOTO 40
26997    20 Y = 0.0D0
26998       GOTO 50
26999    30 Y = ONE-LOG(DT_RNDM(Y)+TINY9)
27000       IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10
27001    40 IF (N.EQ.0) GOTO 70
27002    50 Z = 1.0D0
27003       DO 60 I = 1,N
27004    60 Z = Z*DT_RNDM(Z)
27005       Y = Y-LOG(Z+TINY9)
27006    70 DT_DGAMRN = Y/ALAM
27007
27008       RETURN
27009       END
27010
27011 *$ CREATE DT_DBETAR.FOR
27012 *COPY DT_DBETAR
27013 *
27014 *===dbetar=============================================================*
27015 *
27016       DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
27017
27018 ************************************************************************
27019 * Sampling from Beta -distribution between 0.0 and 1.0                 *
27020 *  F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
27021 * Processed by S. Roesler, 6.5.95                                      *
27022 ************************************************************************
27023
27024       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27025       SAVE
27026
27027       Y = DT_DGAMRN(1.0D0,GAM)
27028       Z = DT_DGAMRN(1.0D0,ETA)
27029       DT_DBETAR = Y/(Y+Z)
27030
27031       RETURN
27032       END
27033
27034 *$ CREATE DT_RANNOR.FOR
27035 *COPY DT_RANNOR
27036 *
27037 *===rannor=============================================================*
27038 *
27039       SUBROUTINE DT_RANNOR(X,Y)
27040
27041 ************************************************************************
27042 * Sampling from Gaussian distribution.                                 *
27043 * Processed by S. Roesler, 6.5.95                                      *
27044 ************************************************************************
27045
27046       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27047       SAVE
27048       PARAMETER (TINY10=1.0D-10)
27049
27050       CALL DT_DSFECF(SFE,CFE)
27051       V = MAX(TINY10,DT_RNDM(X))
27052       A = SQRT(-2.D0*LOG(V))
27053       X = A*SFE
27054       Y = A*CFE
27055
27056       RETURN
27057       END
27058
27059 *$ CREATE DT_DPOLI.FOR
27060 *COPY DT_DPOLI
27061 *
27062 *===dpoli==============================================================*
27063 *
27064       SUBROUTINE DT_DPOLI(CS,SI)
27065
27066       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27067       SAVE
27068
27069       U  = DT_RNDM(CS)
27070       CS = DT_RNDM(U)
27071       IF (U.LT.0.5D0) CS=-CS
27072       SI = SQRT(1.0D0-CS*CS+1.0D-10)
27073
27074       RETURN
27075       END
27076
27077 *$ CREATE DT_DSFECF.FOR
27078 *COPY DT_DSFECF
27079 *
27080 *===dsfecf=============================================================*
27081 *
27082       SUBROUTINE DT_DSFECF(SFE,CFE)
27083
27084       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27085       SAVE
27086       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
27087
27088     1 CONTINUE
27089       X  = DT_RNDM(SFE)
27090       Y  = DT_RNDM(X)
27091       XX = X*X
27092       YY = Y*Y
27093       XY = XX+YY
27094       IF (XY.GT.ONE) GOTO 1
27095       CFE = (XX-YY)/XY
27096       SFE = TWO*X*Y/XY
27097       IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
27098       RETURN
27099       END
27100
27101 *$ CREATE DT_RACO.FOR
27102 *COPY DT_RACO
27103 *
27104 *===raco===============================================================*
27105 *
27106       SUBROUTINE DT_RACO(WX,WY,WZ)
27107
27108 ************************************************************************
27109 * Direction cosines of random uniform (isotropic) direction in three   *
27110 * dimensional space                                                    *
27111 * Processed by S. Roesler, 20.11.95                                    *
27112 ************************************************************************
27113
27114       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27115       SAVE
27116       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
27117
27118   10  CONTINUE
27119       X  = TWO*DT_RNDM(WX)-ONE
27120       Y  = DT_RNDM(X)
27121       X2 = X*X
27122       Y2 = Y*Y
27123       IF (X2+Y2.GT.ONE) GOTO 10
27124
27125       CFE = (X2-Y2)/(X2+Y2)
27126       SFE = TWO*X*Y/(X2+Y2)
27127 * z = 1/2 [ 1 + cos (theta) ]
27128       Z   = DT_RNDM(X)
27129 * 1/2 sin (theta)
27130       WZ = SQRT(Z*(ONE-Z))
27131       WX = TWO*WZ*CFE
27132       WY = TWO*WZ*SFE
27133       WZ = TWO*Z-ONE
27134
27135       RETURN
27136       END
27137
27138 ************************************************************************
27139 *                                                                      *
27140 *           6) Special functions, algorithms and service routines      *
27141 *                                                                      *
27142 ************************************************************************
27143 *$ CREATE DT_YLAMB.FOR
27144 *COPY DT_YLAMB
27145 *
27146 *===ylamb==============================================================*
27147 *
27148       DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
27149
27150 ************************************************************************
27151 *                                                                      *
27152 *     auxiliary function for three particle decay mode                 *
27153 *     (standard LAMBDA**(1/2) function)                                *
27154 *                                                                      *
27155 * Adopted from an original version written by R. Engel.                *
27156 * This version dated 12.12.94 is written by S. Roesler.                *
27157 ************************************************************************
27158
27159       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27160       SAVE
27161
27162       YZ   = Y-Z
27163       XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ
27164       IF (XLAM.LE.0.D0) XLAM = ABS(XLAM)
27165       DT_YLAMB = SQRT(XLAM)
27166
27167       RETURN
27168       END
27169
27170 *$ CREATE DT_SORT.FOR
27171 *COPY DT_SORT
27172 *
27173 *===sort1==============================================================*
27174 *
27175       SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
27176
27177 ************************************************************************
27178 * This subroutine sorts entries in A in increasing/decreasing order    *
27179 * of A(3,i).                                                           *
27180 *              MODE  = 1     increasing in A(3,i=1..N)                 *
27181 *                    = 2     decreasing in A(3,i=1..N)                 *
27182 * This version dated 21.04.95 is revised by S. Roesler                 *
27183 ************************************************************************
27184
27185       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27186       SAVE
27187
27188       DIMENSION A(3,N)
27189
27190       M = I1
27191    10 CONTINUE
27192       M = I1-1
27193       IF (M.LE.0) RETURN
27194       L = 0
27195       DO 20 I=I0,M
27196          J = I+1
27197          IF (MODE.EQ.1) THEN
27198             IF (A(3,I).LE.A(3,J)) GOTO 20
27199          ELSE
27200             IF (A(3,I).GE.A(3,J)) GOTO 20
27201          ENDIF
27202          B = A(3,I)
27203          C = A(1,I)
27204          D = A(2,I)
27205          A(3,I) = A(3,J)
27206          A(2,I) = A(2,J)
27207          A(1,I) = A(1,J)
27208          A(3,J) = B
27209          A(1,J) = C
27210          A(2,J) = D
27211          L = 1
27212    20 CONTINUE
27213       IF (L.EQ.1) GOTO 10
27214
27215       RETURN
27216       END
27217
27218 *$ CREATE DT_SORT1.FOR
27219 *COPY DT_SORT1
27220 *
27221 *===sort1==============================================================*
27222 *
27223       SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
27224
27225 ************************************************************************
27226 * This subroutine sorts entries in A in increasing/decreasing order    *
27227 * of A(i).                                                             *
27228 *              MODE  = 1     increasing in A(i=1..N)                   *
27229 *                    = 2     decreasing in A(i=1..N)                   *
27230 * This version dated 21.04.95 is revised by S. Roesler                 *
27231 ************************************************************************
27232
27233       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27234       SAVE
27235
27236       DIMENSION A(N),IDX(N)
27237
27238       M = I1
27239    10 CONTINUE
27240       M = I1-1
27241       IF (M.LE.0) RETURN
27242       L = 0
27243       DO 20 I=I0,M
27244          J = I+1
27245          IF (MODE.EQ.1) THEN
27246             IF (A(I).LE.A(J)) GOTO 20
27247          ELSE
27248             IF (A(I).GE.A(J)) GOTO 20
27249          ENDIF
27250          B    = A(I)
27251          A(I) = A(J)
27252          A(J) = B
27253          IX     = IDX(I)
27254          IDX(I) = IDX(J)
27255          IDX(J) = IX
27256          L = 1
27257    20 CONTINUE
27258       IF (L.EQ.1) GOTO 10
27259
27260       RETURN
27261       END
27262
27263 *$ CREATE DT_XTIME.FOR
27264 *COPY DT_XTIME
27265 *
27266 *===xtime==============================================================*
27267 *
27268       SUBROUTINE DT_XTIME
27269
27270       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27271       SAVE
27272       PARAMETER ( LINP = 10 ,
27273      &            LOUT = 6 ,
27274      &            LDAT = 9 )
27275
27276       CHARACTER DAT*9,TIM*11
27277
27278       DAT = '         '
27279       TIM = '           '
27280 C     CALL GETDAT(IYEAR,IMONTH,IDAY)
27281 C     CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
27282
27283 C     CALL DATE(DAT)
27284 C     CALL TIME(TIM)
27285 C     WRITE(LOUT,1000) DAT,TIM
27286  1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
27287
27288       RETURN
27289       END
27290
27291 ************************************************************************
27292 *                                                                      *
27293 *                 7) Random number generator package                   *
27294 *                                                                      *
27295 *    THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND        *
27296 *    SERVICE ROUTINES.                                                 *
27297 *    THE ALGORITHM IS FROM                                             *
27298 *      'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR'                     *
27299 *      G.MARSAGLIA, A.ZAMAN ;  FSU-SCRI-87-50                          *
27300 *    IMPLEMENTATION BY K. HAHN  DEC. 88,                               *
27301 *    THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS *
27302 *    AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ),        *
27303 *    THE PERIOD IS ABOUT 2**144,                                       *
27304 *    TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS,            *
27305 *    THE PACKAGE CONTAINS                                              *
27306 *      FUNCTION DT_RNDM(I)                  : GENERATOR                *
27307 *      SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION           *
27308 *      SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J)  : PUT SEED TO GENERATOR    *
27309 *      SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J)  : TAKE SEED FROM GENERATOR *
27310 *      SUBROUTINE DT_RNDMTE(IO)             : TEST OF GENERATOR        *
27311 *---                                                                   *
27312 *    FUNCTION DT_RNDM(I)                                               *
27313 *       GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS  IN (0..1)          *
27314 *       I  - DUMMY VARIABLE, NOT USED                                  *
27315 *    SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)                             *
27316 *       INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM *
27317 *       NA1,NA2,NA3,NB1  - VALUES FOR INITIALIZING THE GENERATOR       *
27318 *                          NA? MUST BE IN 1..178 AND NOT ALL 1         *
27319 *                          12,34,56  ARE THE STANDARD VALUES           *
27320 *                          NB1 MUST BE IN 1..168                       *
27321 *                          78  IS THE STANDARD VALUE                   *
27322 *    SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J)                               *
27323 *       PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS   *
27324 *       AS AFTER THE LAST DT_RNDMOU CALL )                             *
27325 *       U(97),C,CD,CM,I,J  - SEED VALUES AS TAKEN FROM DT_RNDMOU       *
27326 *    SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J)                               *
27327 *       TAKES SEED FROM GENERATOR                                      *
27328 *       U(97),C,CD,CM,I,J  - SEED VALUES                               *
27329 *    SUBROUTINE DT_RNDMTE(IO)                                          *
27330 *       TEST OF THE GENERATOR                                          *
27331 *       IO     - DEFINES OUTPUT                                        *
27332 *                  = 0  OUTPUT ONLY IF AN ERROR IS DETECTED            *
27333 *                  = 1  OUTPUT INDEPENDEND ON AN ERROR                 *
27334 *       DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO   *
27335 *       SAME STATUS                                                    *
27336 *       AS BEFORE CALL OF DT_RNDMTE                                    *
27337 ************************************************************************
27338 *$ CREATE DT_RNDM.FOR
27339 *COPY DT_RNDM
27340 *
27341 c$$$*===rndm===============================================================*
27342 c$$$*
27343 c$$$      DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
27344 c$$$
27345 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27346 c$$$      SAVE
27347 c$$$
27348 c$$$* random number generator
27349 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27350 c$$$
27351 c$$$* counter of calls to random number generator
27352 c$$$* uncomment if needed
27353 c$$$C     COMMON /DTRNCT/ IRNCT0,IRNCT1
27354 c$$$C     LOGICAL LFIRST
27355 c$$$C     DATA LFIRST /.TRUE./
27356 c$$$
27357 c$$$* counter of calls to random number generator
27358 c$$$* uncomment if needed
27359 c$$$C     IF (LFIRST) THEN
27360 c$$$C        IRNCT0 = 0
27361 c$$$C        IRNCT1 = 0
27362 c$$$C        LFIRST = .FALSE.
27363 c$$$C     ENDIF
27364 c$$$ 100  CONTINUE
27365 c$$$      DT_RNDM = U(I)-U(J)
27366 c$$$      IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0
27367 c$$$      U(I) = DT_RNDM
27368 c$$$      I    = I-1
27369 c$$$      IF ( I.EQ.0 ) I = 97
27370 c$$$      J    = J-1
27371 c$$$      IF ( J.EQ.0 ) J = 97
27372 c$$$      C    = C-CD
27373 c$$$      IF ( C.LT.0.0D0 ) C = C+CM
27374 c$$$      DT_RNDM = DT_RNDM-C
27375 c$$$      IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0
27376 c$$$
27377 c$$$      IF ((DT_RNDM.EQ.0.D0).OR.(DT_RNDM.EQ.1.D0)) GOTO 100
27378 c$$$
27379 c$$$* counter of calls to random number generator
27380 c$$$* uncomment if needed
27381 c$$$C     IRNCT0 = IRNCT0+1
27382 c$$$
27383 c$$$      RETURN
27384 c$$$      END
27385 c$$$
27386 c$$$*$ CREATE DT_RNDMST.FOR
27387 c$$$*COPY DT_RNDMST
27388 c$$$*
27389 c$$$*===rndmst=============================================================*
27390 c$$$*
27391 c$$$      SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
27392 c$$$
27393 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27394 c$$$      SAVE
27395 c$$$
27396 c$$$* random number generator
27397 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27398 c$$$
27399 c$$$      MA1 = NA1
27400 c$$$      MA2 = NA2
27401 c$$$      MA3 = NA3
27402 c$$$      MB1 = NB1
27403 c$$$      I   = 97
27404 c$$$      J   = 33
27405 c$$$      DO 20 II2 = 1,97
27406 c$$$        S = 0
27407 c$$$        T = 0.5D0
27408 c$$$        DO 10 II1 = 1,24
27409 c$$$          MAT  = MOD(MOD(MA1*MA2,179)*MA3,179)
27410 c$$$          MA1  = MA2
27411 c$$$          MA2  = MA3
27412 c$$$          MA3  = MAT
27413 c$$$          MB1  = MOD(53*MB1+1,169)
27414 c$$$          IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
27415 c$$$   10   T = 0.5D0*T
27416 c$$$   20 U(II2) = S
27417 c$$$      C  =   362436.0D0/16777216.0D0
27418 c$$$      CD =  7654321.0D0/16777216.0D0
27419 c$$$      CM = 16777213.0D0/16777216.0D0
27420 c$$$      RETURN
27421 c$$$      END
27422 c$$$
27423 c$$$*$ CREATE DT_RNDMIN.FOR
27424 c$$$*COPY DT_RNDMIN
27425 c$$$*
27426 c$$$*===rndmin=============================================================*
27427 c$$$*
27428 c$$$      SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
27429 c$$$
27430 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27431 c$$$      SAVE
27432 c$$$
27433 c$$$* random number generator
27434 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27435 c$$$
27436 c$$$      DIMENSION UIN(97)
27437 c$$$
27438 c$$$      DO 10 KKK = 1,97
27439 c$$$   10 U(KKK) = UIN(KKK)
27440 c$$$      C  = CIN
27441 c$$$      CD = CDIN
27442 c$$$      CM = CMIN
27443 c$$$      I  = IIN
27444 c$$$      J  = JIN
27445 c$$$
27446 c$$$      RETURN
27447 c$$$      END
27448 c$$$
27449 c$$$*$ CREATE DT_RNDMOU.FOR
27450 c$$$*COPY DT_RNDMOU
27451 c$$$*
27452 c$$$*===rndmou=============================================================*
27453 c$$$*
27454 c$$$      SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
27455 c$$$
27456 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27457 c$$$      SAVE
27458 c$$$
27459 c$$$* random number generator
27460 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27461 c$$$
27462 c$$$      DIMENSION UOUT(97)
27463 c$$$
27464 c$$$      DO 10 KKK = 1,97
27465 c$$$   10 UOUT(KKK) = U(KKK)
27466 c$$$      COUT  = C
27467 c$$$      CDOUT = CD
27468 c$$$      CMOUT = CM
27469 c$$$      IOUT  = I
27470 c$$$      JOUT  = J
27471 c$$$
27472 c$$$      RETURN
27473 c$$$      END
27474 c$$$
27475 c$$$*$ CREATE DT_RNDMTE.FOR
27476 c$$$*COPY DT_RNDMTE
27477 c$$$*
27478 c$$$*===rndmte=============================================================*
27479 c$$$*
27480 c$$$      SUBROUTINE DT_RNDMTE(IO)
27481 c$$$
27482 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27483 c$$$      SAVE
27484 c$$$
27485 c$$$      DIMENSION UU(97),U(6),X(6),D(6)
27486 c$$$      DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0,
27487 c$$$     +8354498.D0, 10633180.D0/
27488 c$$$
27489 c$$$      CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ)
27490 c$$$      CALL DT_RNDMST(12,34,56,78)
27491 c$$$      DO 10 II1 = 1,20000
27492 c$$$   10 XX = DT_RNDM(XX)
27493 c$$$      SD        = 0.0D0
27494 c$$$      DO 20 II2 = 1,6
27495 c$$$        X(II2)  = 4096.D0*(4096.D0*DT_RNDM(SD))
27496 c$$$        D(II2)  = X(II2)-U(II2)
27497 c$$$   20 SD = SD+D(II2)
27498 c$$$      CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
27499 c$$$**sr 24.01.95
27500 c$$$C     IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6)
27501 c$$$      IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN
27502 c$$$C        WRITE(6,1000)
27503 c$$$ 1000    FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
27504 c$$$     &          ' passed')
27505 c$$$      ENDIF
27506 c$$$**
27507 c$$$      RETURN
27508 c$$$  500 FORMAT('  === TEST OF THE RANDOM-GENERATOR ===',/,
27509 c$$$     &'    EXPECTED VALUE    CALCULATED VALUE     DIFFERENCE',/, 6(F17.
27510 c$$$     &1,F20.1,F15.3,/), '  === END OF TEST ;',
27511 c$$$     &'  GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE')
27512 c$$$      END
27513 *
27514 *$ CREATE PHO_RNDM.FOR
27515 *COPY PHO_RNDM
27516 *
27517 *===pho_rndm===========================================================*
27518 *
27519       DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
27520
27521       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27522       SAVE
27523
27524       PHO_RNDM = DT_RNDM(DUMMY)
27525
27526       RETURN
27527       END
27528
27529 *$ CREATE PYR.FOR
27530 *COPY PYR
27531 *
27532 *===pyr================================================================*
27533 *
27534       DOUBLE PRECISION FUNCTION PYR(IDUMMY)
27535
27536       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27537       SAVE
27538
27539       DUMMY = DBLE(IDUMMY)
27540       PYR = DT_RNDM(DUMMY)
27541
27542       RETURN
27543       END
27544
27545 *$ CREATE DT_TITLE.FOR
27546 *COPY DT_TITLE
27547 *
27548 *===title==============================================================*
27549 *
27550       SUBROUTINE DT_TITLE
27551
27552       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27553       SAVE
27554       PARAMETER ( LINP = 10 ,
27555      &            LOUT = 6 ,
27556      &            LDAT = 9 )
27557
27558       CHARACTER*6 CVERSI
27559       CHARACTER*11 CCHANG
27560       DATA CVERSI,CCHANG /'3.0-5 ','08 Jan 2007'/
27561
27562       CALL DT_XTIME
27563       WRITE(LOUT,1000) CVERSI,CCHANG
27564  1000 FORMAT(1X,'+-------------------------------------------------',
27565      &                  '----------------------+',/,
27566      &     1X,'|',71X,'|',/,
27567      &     1X,'|',26X,'DPMJET version ',A6,24X,'|',/,
27568      &     1X,'|',71X,'|',/,
27569      &     1X,'|',22X,'(Last change: ',A11,')',23X,'|',/,
27570      &     1X,'|',71X,'|',/,
27571      &     1X,'|',12X,'Authors: Stefan Roesler   (CERN)',27X,'|',/,
27572      &     1X,'|',21X,'Ralph Engel      (FZ Karlsruhe)',19X,'|',/,
27573      &     1X,'|',21X,'Johannes Ranft   (Siegen Univ.)',19X,'|',/,
27574      &     1X,'|',71X,'|',/,
27575      &     1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html',
27576      &                                              17X,'|',/,
27577      &     1X,'|',71X,'|',/,
27578      &     1X,'+-------------------------------------------------',
27579      &                '----------------------+',/,
27580      &     1X,'| Please send suggestions, bug reports, etc. to: ',
27581      &                                  'Stefan.Roesler@cern.ch |',/,
27582      &     1X,'+-------------------------------------------------',
27583      &                '----------------------+',/)
27584
27585       RETURN
27586       END
27587
27588 *$ CREATE DT_EVTINI.FOR
27589 *COPY DT_EVTINI
27590 *
27591 *===evtini=============================================================*
27592 *
27593       SUBROUTINE DT_EVTINI
27594
27595 ************************************************************************
27596 * Initialization of DTEVT1.                                            *
27597 * This version dated 15.01.94 is written by S. Roesler                 *
27598 ************************************************************************
27599
27600       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27601       SAVE
27602       PARAMETER ( LINP = 10 ,
27603      &            LOUT = 6 ,
27604      &            LDAT = 9 )
27605
27606 * event history
27607       PARAMETER (NMXHKK=200000)
27608       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27609      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27610      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27611 * extended event history
27612       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27613      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27614      &                IHIST(2,NMXHKK)
27615 * event flag
27616       COMMON /DTEVNO/ NEVENT,ICASCA
27617       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27618 * emulsion treatment
27619       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
27620      &                NCOMPO,IEMUL
27621
27622 * initialization of DTEVT1/DTEVT2
27623       NEND = NHKK
27624       IF (NEVENT.EQ.1) NEND = NMXHKK
27625       NHKK   = 0
27626       NEVHKK = NEVENT
27627       DO 1 I=1,NEND
27628          ISTHKK(I)   = 0
27629          IDHKK(I)    = 0
27630          JMOHKK(1,I) = 0
27631          JMOHKK(2,I) = 0
27632          JDAHKK(1,I) = 0
27633          JDAHKK(2,I) = 0
27634          IDRES(I)    = 0
27635          IDXRES(I)   = 0
27636          NOBAM(I)    = 0
27637          IDCH(I)     = 0
27638          IHIST(1,I)  = 0
27639          IHIST(2,I)  = 0
27640          DO 2 J=1,4
27641             PHKK(J,I) = 0.0D0
27642             VHKK(J,I) = 0.0D0
27643             WHKK(J,I) = 0.0D0
27644     2    CONTINUE
27645          PHKK(5,I) = 0.0D0
27646     1 CONTINUE
27647       DO 3 I=1,10
27648          NPOINT(I) = 0
27649     3 CONTINUE
27650       CALL DT_CHASTA(-1)
27651
27652 C* initialization of DTLTRA
27653 C      IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
27654
27655       RETURN
27656       END
27657
27658 *$ CREATE DT_STATIS.FOR
27659 *COPY DT_STATIS
27660 *
27661 *===statis=============================================================*
27662 *
27663       SUBROUTINE DT_STATIS(MODE)
27664
27665 ************************************************************************
27666 * Initialization and output of run-statistics.                         *
27667 *              MODE  = 1     initialization                            *
27668 *                    = 2     output                                    *
27669 * This version dated 23.01.94 is written by S. Roesler                 *
27670 ************************************************************************
27671
27672       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27673       SAVE
27674       PARAMETER ( LINP = 10 ,
27675      &            LOUT = 6 ,
27676      &            LDAT = 9 )
27677       PARAMETER (TINY3=1.0D-3)
27678
27679 * statistics
27680       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
27681      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
27682      &                ICEVTG(8,0:30)
27683 * rejection counter
27684       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27685      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27686      &                IREXCI(3),IRDIFF(2),IRINC
27687 * central particle production, impact parameter biasing
27688       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
27689 * various options for treatment of partons (DTUNUC 1.x)
27690 * (chain recombination, Cronin,..)
27691       LOGICAL LCO2CR,LINTPT
27692       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
27693      &                LCO2CR,LINTPT
27694 * nucleon-nucleon event-generator
27695       CHARACTER*8 CMODEL
27696       LOGICAL LPHOIN
27697       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
27698 * flags for particle decays
27699       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
27700      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
27701      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
27702 * diquark-breaking mechanism
27703       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
27704
27705       DIMENSION PP(4),PT(4)
27706
27707       GOTO (1,2) MODE
27708
27709 * initialization
27710     1 CONTINUE
27711
27712 *   initialize statistics counter
27713       ICREQU = 0
27714       ICSAMP = 0
27715       ICCPRO = 0
27716       ICDPR  = 0
27717       ICDTA  = 0
27718       ICRJSS = 0
27719       ICVV2S = 0
27720       DO 10 I=1,9
27721          ICRES(I)    = 0
27722          ICCHAI(1,I) = 0
27723          ICCHAI(2,I) = 0
27724    10 CONTINUE
27725 *   initialize rejection counter
27726       IRPT      = 0
27727       IRHHA     = 0
27728       LOMRES    = 0
27729       LOBRES    = 0
27730       IRFRAG    = 0
27731       IREVT     = 0
27732       IRRES(1)  = 0
27733       IRRES(2)  = 0
27734       IRCHKI(1) = 0
27735       IRCHKI(2) = 0
27736       IRCRON(1) = 0
27737       IRCRON(2) = 0
27738       IRCRON(3) = 0
27739       IRDIFF(1) = 0
27740       IRDIFF(2) = 0
27741       IRINC     = 0
27742       DO 11 I=1,5
27743          ICDIFF(I) = 0
27744    11 CONTINUE
27745       DO 12 I=1,8
27746          DO 13 J=0,30
27747             ICEVTG(I,J) = 0
27748    13    CONTINUE
27749    12 CONTINUE
27750
27751       RETURN
27752
27753 * output
27754     2 CONTINUE
27755
27756 *   statistics counter
27757       WRITE(LOUT,1000)
27758  1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/,
27759      &       28X,'---------------------')
27760       IF (ICREQU.GT.0) THEN
27761       WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
27762  1001 FORMAT(/,1X,'number of events requested / sampled',13X,
27763      &       I8,' / ',I8,/,1X,'number of samp. evts per requested ',
27764      &       'event',11X,F9.1)
27765       ENDIF
27766       IF (ICDIFF(1).NE.0) THEN
27767          WRITE(LOUT,1009) ICDIFF
27768  1009    FORMAT(/,1X,'diffractive events:    total   ',I8,/,49X,
27769      &          'low mass   high mass',/,24X,'single diffraction',
27770      &          7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
27771       ENDIF
27772       IF (ICENTR.GT.0.AND.ICSAMP.GT.0.AND.ICCPRO.GT.0) THEN
27773          WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
27774      &                    DBLE(ICSAMP)/DBLE(ICCPRO)
27775  1002    FORMAT(/,1X,'central production:',/,2X,'mean number',
27776      &          ' of sampled Glauber-events per event',9X,F9.1,/,
27777      &          2X,'fraction of production cross section',21X,F10.6)
27778       ENDIF
27779       IF (ICSAMP.GT.0) THEN
27780       WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
27781      &                 DBLE(ICDTA)/DBLE(ICSAMP)
27782  1003 FORMAT(/,54X,'proj.    targ.',/,1X,'average number of wounded',
27783      &       ' nucleons after x-sampling',2(4X,F6.2))
27784       ENDIF
27785
27786       IF (MCGENE.EQ.1) THEN
27787          IF (ICSAMP.GT.0) THEN
27788          WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
27789  1004    FORMAT(/,1X,'mean number of sea-sea chain rejections per',
27790      &          ' event',3X,F9.1)
27791          IF (ISICHA.EQ.1) THEN
27792             WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
27793  1005       FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
27794      &             'of single chains  per event',13X,F9.1)
27795          ENDIF
27796          ENDIF
27797          IF (ICSAMP.GT.0.AND.ICREQU.GT.0) THEN
27798          WRITE(LOUT,1006)
27799  1006    FORMAT(/,1X,'chain system statistics:  (per event)',/,
27800      &       23X,'mean number of chains      mean number of chains',/,
27801      &       23X,'sampled    hadronized      having mass of a reso.')
27802          WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
27803      &                     DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
27804      &                     DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
27805      &                  DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
27806  1007    FORMAT(1X,'sea     - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27807      &          1X,'disea   - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27808      &          1X,'sea     - disea   ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27809      &          1X,'sea     - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27810      &          1X,'disea   - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27811      &          1X,'valence - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27812      &          1X,'valence - disea   ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27813      &          1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27814      &          1X,'fused chains      ',18X,F4.1,17X,F4.1,/)
27815          WRITE(LOUT,1008)
27816      &     (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
27817      &     DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
27818      &     DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
27819      &     (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
27820      &     (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
27821      &     DBLE(IRHHA)/DBLE(ICREQU),
27822      &     DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
27823      &     (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
27824  1008    FORMAT(/,1X,'Rejection counter:  (NEVT = no. of events)',/,/,
27825      &       1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
27826      &       F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
27827      &       'Intrins. p_t (GETSPT)',21X,'IRPT     /NEVT = ',F7.2,/,
27828      &       1X,'Chain mass corr. for resonances (EVTRES)',2X,
27829      &       'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES)  IRRES(2) /',
27830      &       'NEVT = ',F7.2,/,43X,'LOMRES   /NEVT = ',F7.2,/,
27831      &       43X,'LOBRES   /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
27832      &       ' 2-chain systems (CHKINE)  IRCHKI(1)/NEVT = ',F7.2,/,
27833      &       43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
27834      &       'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
27835      &       F7.2,/,1X,'Total no. of rej.',
27836      &       ' in chain-systems treatment (GETCSY)',/,43X,
27837      &       'IRHHA    /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
27838      &       ' (not yet used!)',4X,'IRFRAG   /NEVT = ',F7.2,/,
27839      &       1X,'Total no. of rej. in DPM-treatment of one event',
27840      &       ' (EVENTA)',/,43X,'IREVT    /NEVT = ',F7.2,/,1X,
27841      &       'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
27842      &       ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
27843      &       'IREXCI(3) = ',I5,/)
27844          ENDIF
27845       ELSEIF (MCGENE.EQ.2) THEN
27846          WRITE(LOUT,1010) ELOJET
27847  1010    FORMAT(/,/,1X,'PHOJET-treatment of chain systems above  ',
27848      &          F4.1,' GeV')
27849          WRITE(LOUT,1011)
27850  1011    FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
27851      &          30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
27852      &          5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
27853          WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
27854      &                    (INT(ICCHAI(2,I)/2.0D0),I=1,8),
27855      &                    (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
27856      &                    ((ICEVTG(I,J),I=1,8),J=3,7),
27857      &                    ((ICEVTG(I,J),I=1,8),J=19,21),
27858      &                    (ICEVTG(I,8),I=1,8),
27859      &                    ((ICEVTG(I,J),I=1,8),J=22,24),
27860      &                    (ICEVTG(I,9),I=1,8),
27861      &                    ((ICEVTG(I,J),I=1,8),J=25,28),
27862      &                    ((ICEVTG(I,J),I=1,8),J=10,18)
27863  1012    FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
27864      &          8I8,/,/,1X,'PHOJET ',8I8,/,'   sngl ',8I8,/,/,
27865      &          ' no-dif.',8I8,/,
27866      &          ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
27867      &          ' diff-1 ',8I8,/,'  low   ',8I8,/,'  high  ',8I8,/,
27868      &          '  h-diff',8I8,/,' diff-2 ',8I8,/,'  low   ',8I8,/,
27869      &          '  high  ',8I8,/,'  h-diff',8I8,/,' dbl-di.',8I8,/,
27870      &          '  lo-lo ',8I8,/,'  hi-hi ',8I8,/,'  lo-hi ',8I8,/,
27871      &          '  hi-lo ',8I8,/,
27872      &          ' dir-ga.',8I8,/,/,' dir-1  ',8I8,/,' dir-2  ',8I8,/,
27873      &          ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
27874      &          ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
27875          WRITE(LOUT,1013)
27876  1013    FORMAT(/,1X,'2. chain system statistics -',
27877      &          ' mean numbers per evt:',/,30X,'---------------------',
27878      &          /,/,16X,'s-s',7X,'d-s',7X,'s-d')
27879          IF (ICSAMP.GT.0) THEN
27880          WRITE(LOUT,1014)
27881      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
27882      &                 (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
27883      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
27884  1014    FORMAT(/,1X,'req.to.    ',3E10.2,/,/,1X,'low rq.    ',3E10.2,/,
27885      &          1X,'low ac.    ',3E10.2,/,/,1X,'PHOJET     ',3E10.2,/,/,
27886      &          ' no-dif.    ',3E10.2,/,' el-sca.    ',3E10.2,/,
27887      &          ' qel-sc.    ',3E10.2,/,' dbl-Po.    ',3E10.2,/,
27888      &          ' diff-1     ',3E10.2,/,' diff-2     ',3E10.2,/,
27889      &          ' dbl-di.    ',3E10.2,/,' dir-ga.    ',3E10.2,/,/,
27890      &          ' dir-1      ',3E10.2,/,' dir-2      ',3E10.2,/,
27891      &          ' dbl-dir    ',3E10.2,/,' s-Pom.     ',3E10.2,/,
27892      &          ' h-Pom.     ',3E10.2,/,' s-Reg.     ',3E10.2,/,
27893      &          ' enh-trg    ',3E10.2,/,' enh-log    ',3E10.2)
27894          ENDIF
27895          WRITE(LOUT,1015)
27896  1015    FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
27897          IF (ICSAMP.GT.0) THEN
27898          WRITE(LOUT,1016)
27899      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
27900      &                 (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
27901      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
27902  1016    FORMAT(/,1X,'req.to.    ',5E10.2,/,/,1X,'low rq.    ',5E10.2,/,
27903      &          1X,'low ac.    ',5E10.2,/,/,1X,'PHOJET     ',5E10.2,/,/,
27904      &          ' no-dif.    ',5E10.2,/,' el-sca.    ',5E10.2,/,
27905      &          ' qel-sc.    ',5E10.2,/,' dbl-Po.    ',5E10.2,/,
27906      &          ' diff-1     ',5E10.2,/,' diff-2     ',5E10.2,/,
27907      &          ' dbl-di.    ',5E10.2,/,' dir-ga.    ',5E10.2,/,/,
27908      &          ' dir-1      ',5E10.2,/,' dir-2      ',5E10.2,/,
27909      &          ' dbl-dir    ',5E10.2,/,' s-Pom.     ',5E10.2,/,
27910      &          ' h-Pom.     ',5E10.2,/,' s-Reg.     ',5E10.2,/,
27911      &          ' enh-trg    ',5E10.2,/,' enh-log    ',5E10.2)
27912          ENDIF
27913
27914       ENDIF
27915       CALL DT_CHASTA(1)
27916
27917       IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
27918      &                        .OR.(PDBSEA(3).GT.0.0D0)) THEN
27919          WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
27920      &    DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
27921      &    DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
27922          WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
27923      &    DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
27924      &    DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
27925          WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
27926      &    DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
27927      &    DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
27928          WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
27929      &    DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
27930      &    DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
27931          WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
27932      &    DBRKA(3,1),DBRKA(3,2),
27933      &    DBRKA(3,3),DBRKA(3,4)
27934          WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
27935      &    DBRKR(3,1),DBRKR(3,2),
27936      &    DBRKR(3,3),DBRKR(3,4)
27937          WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
27938      &    DBRKA(3,5),DBRKA(3,6),
27939      &    DBRKA(3,7),DBRKA(3,8)
27940          WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
27941      &    DBRKR(3,5),DBRKR(3,6),
27942      &    DBRKR(3,7),DBRKR(3,8)
27943       ENDIF
27944
27945       FAC = 1.0D0
27946       IF (MCGENE.EQ.2) THEN
27947 C        CALL PHO_PHIST(-2,SIGMAX)
27948          CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
27949       ENDIF
27950
27951       CALL DT_XTIME
27952
27953       RETURN
27954       END
27955
27956 *$ CREATE DT_EVTOUT.FOR
27957 *COPY DT_EVTOUT
27958 *
27959 *===evtout=============================================================*
27960 *
27961       SUBROUTINE DT_EVTOUT(MODE)
27962
27963 ************************************************************************
27964 *            MODE  = 1  plot content of complete DTEVT1 to out. unit   *
27965 *                    3  plot entries of extended DTEVT1 (DTEVT2)       *
27966 *                    4  plot entries of DTEVT1 and DTEVT2              *
27967 * This version dated 11.12.94 is written by S. Roesler                 *
27968 ************************************************************************
27969
27970       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27971       SAVE
27972       PARAMETER ( LINP = 10 ,
27973      &            LOUT = 6 ,
27974      &            LDAT = 9 )
27975 * event history
27976       PARAMETER (NMXHKK=200000)
27977       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27978      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27979      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27980
27981       DIMENSION IRANGE(NMXHKK)
27982
27983       IF (MODE.EQ.2) RETURN
27984
27985       CALL DT_EVTPLO(IRANGE,MODE)
27986
27987       RETURN
27988       END
27989
27990 *$ CREATE DT_EVTPLO.FOR
27991 *COPY DT_EVTPLO
27992 *
27993 *===evtplo=============================================================*
27994 *
27995       SUBROUTINE DT_EVTPLO(IRANGE,MODE)
27996
27997 ************************************************************************
27998 *            MODE  = 1  plot content of complete DTEVT1 to out. unit   *
27999 *                    2  plot entries of DTEVT1 given by IRANGE         *
28000 *                    3  plot entries of extended DTEVT1 (DTEVT2)       *
28001 *                    4  plot entries of DTEVT1 and DTEVT2              *
28002 *                    5  plot rejection counter                         *
28003 * This version dated 11.12.94 is written by S. Roesler                 *
28004 ************************************************************************
28005
28006       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28007       SAVE
28008       PARAMETER ( LINP = 10 ,
28009      &            LOUT = 6 ,
28010      &            LDAT = 9 )
28011
28012       CHARACTER*16 CHAU
28013
28014 * event history
28015       PARAMETER (NMXHKK=200000)
28016       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28017      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28018      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28019 * extended event history
28020       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28021      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28022      &                IHIST(2,NMXHKK)
28023 * rejection counter
28024       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
28025      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
28026      &                IREXCI(3),IRDIFF(2),IRINC
28027
28028       DIMENSION IRANGE(NMXHKK)
28029
28030       IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
28031          WRITE(LOUT,1000)
28032  1000    FORMAT(/,1X,'EVTPLO:',14X,'    content of COMMON /DTEVT1/',/,
28033      &         15X,'           --------------------------',/,/,
28034      &             '       ST    ID  M1   M2   D1   D2     PX     PY',
28035      &             '     PZ      E       M',/)
28036          DO 1 I=1,NHKK
28037             WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28038      &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28039      &                       PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
28040      &                       PHKK(5,I)
28041 C           WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28042 C    &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28043 C    &                       PHKK(3,I),PHKK(4,I)
28044 C           WRITE(LOUT,'(4E15.4)')
28045 C    &         VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
28046  1001       FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
28047  1011       FORMAT(I5,I5,I6,4I5,2E15.5)
28048     1    CONTINUE
28049          WRITE(LOUT,*)
28050 C        DO 4 I=1,NHKK
28051 C           WRITE(LOUT,1006) I,ISTHKK(I),
28052 C    &                    VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
28053 C    &                    WHKK(2,I),WHKK(3,I)
28054 C1006       FORMAT(1X,I4,I6,6E10.3)
28055 C   4    CONTINUE
28056       ENDIF
28057
28058       IF (MODE.EQ.2) THEN
28059          WRITE(LOUT,1000)
28060          NC = 0
28061     2    CONTINUE
28062          NC = NC+1
28063          IF (IRANGE(NC).EQ.-100) GOTO 9999
28064          I = IRANGE(NC)
28065          WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28066      &                    JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28067      &                    PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
28068      &                    PHKK(5,I)
28069          GOTO 2
28070       ENDIF
28071
28072       IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
28073          WRITE(LOUT,1002)
28074  1002    FORMAT(/,1X,'EVTPLO:',14X,
28075      &         ' content of COMMON /DTEVT1/,/DTEVT2/',/,
28076      &         15X,'        -----------------------------------',/,/,
28077      &             '       ST    ID   M1   M2   D1   D2  IDR  IDXR',
28078      &             ' NOBAM IDCH    M',/)
28079          DO 3 I=1,NHKK
28080 C           IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
28081                KF    = IDHKK(I)
28082                IDCHK = KF/10000
28083                IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28084      &            (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
28085                CALL PYNAME(KF,CHAU)
28086                WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28087      &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28088      &                       IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
28089      &                       PHKK(5,I),CHAU
28090  1003          FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
28091 C           ENDIF
28092     3    CONTINUE
28093       ENDIF
28094
28095       IF (MODE.EQ.5) THEN
28096          WRITE(LOUT,1004)
28097  1004    FORMAT(/,1X,'EVTPLO:',14X,'    content of COMMON /DTREJC/',/,
28098      &         15X,'           --------------------------',/)
28099          WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
28100      &                    IRSEA,IRCRON
28101  1005    FORMAT(1X,'IRPT   = ',I5,'  IRHHA = ',I5,/,
28102      &          1X,'IRRES  = ',2I5,'  LOMRES = ',I5,'  LOBRES = ',I5,/,
28103      &          1X,'IREMC  = ',10I5,/,
28104      &          1X,'IRFRAG = ',I5,'  IRSEA = ',I5,' IRCRON = ',I5,/)
28105       ENDIF
28106
28107  9999 RETURN
28108       END
28109
28110 *$ CREATE DT_EVTPUT.FOR
28111 *COPY DT_EVTPUT
28112 *
28113 *===evtput=============================================================*
28114 *
28115       SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
28116
28117       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28118       SAVE
28119       PARAMETER ( LINP = 10 ,
28120      &            LOUT = 6 ,
28121      &            LDAT = 9 )
28122       PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
28123      &           TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0)
28124
28125 * event history
28126       PARAMETER (NMXHKK=200000)
28127       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28128      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28129      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28130 * extended event history
28131       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28132      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28133      &                IHIST(2,NMXHKK)
28134 * Lorentz-parameters of the current interaction
28135       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28136      &                UMO,PPCM,EPROJ,PPROJ
28137 * particle properties (BAMJET index convention)
28138       CHARACTER*8  ANAME
28139       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28140      &                IICH(210),IIBAR(210),K1(210),K2(210)
28141
28142 C     IF (MODE.GT.100) THEN
28143 C        WRITE(LOUT,'(1X,A,I5,A,I5)')
28144 C    &        'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
28145 C        NHKK = NHKK-MODE+100
28146 C        RETURN
28147 C     ENDIF
28148       MO1  = M1
28149       MO2  = M2
28150       NHKK = NHKK+1
28151
28152       IF (NHKK.GT.NMXHKK) THEN
28153          WRITE(LOUT,1000) NHKK
28154  1000    FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
28155      &             '! program execution stopped..')
28156          STOP
28157       ENDIF
28158       IF (M1.LT.0) MO1 = NHKK+M1
28159       IF (M2.LT.0) MO2 = NHKK+M2
28160       ISTHKK(NHKK)   = IST
28161       IDHKK(NHKK)    = ID
28162       JMOHKK(1,NHKK) = MO1
28163       JMOHKK(2,NHKK) = MO2
28164       JDAHKK(1,NHKK) = 0
28165       JDAHKK(2,NHKK) = 0
28166       IDRES(NHKK)    = IDR
28167       IDXRES(NHKK)   = IDXR
28168       IDCH(NHKK)     = IDC
28169 ** here we need to do something..
28170       IF (ID.EQ.88888) THEN
28171          IDMO1 = ABS(IDHKK(MO1))
28172          IDMO2 = ABS(IDHKK(MO2))
28173          IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
28174          IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
28175          IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
28176          IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
28177       ELSE
28178          NOBAM(NHKK) = 0
28179       ENDIF
28180       IDBAM(NHKK) = IDT_ICIHAD(ID)
28181       IF (MO1.GT.0) THEN
28182          IF (JDAHKK(1,MO1).NE.0) THEN
28183             JDAHKK(2,MO1) = NHKK
28184          ELSE
28185             JDAHKK(1,MO1) = NHKK
28186          ENDIF
28187       ENDIF
28188       IF (MO2.GT.0) THEN
28189          IF (JDAHKK(1,MO2).NE.0) THEN
28190             JDAHKK(2,MO2) = NHKK
28191          ELSE
28192             JDAHKK(1,MO2) = NHKK
28193          ENDIF
28194       ENDIF
28195 C      IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
28196 C         PTOT   = SQRT(PX**2+PY**2+PZ**2)
28197 C         AM0    = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
28198 C         AMRQ   = AAM(IDBAM(NHKK))
28199 C         AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
28200 C         IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
28201 C     &       (PTOT.GT.ZERO)) THEN
28202 C            DELTA = -AMDIF2/(2.0D0*(E+PTOT))
28203 CC           DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
28204 C            E     = E+DELTA
28205 C            PTOT1 = PTOT-DELTA
28206 C            PX    = PX*PTOT1/PTOT
28207 C            PY    = PY*PTOT1/PTOT
28208 C            PZ    = PZ*PTOT1/PTOT
28209 C         ENDIF
28210 C      ENDIF
28211       PHKK(1,NHKK) = PX
28212       PHKK(2,NHKK) = PY
28213       PHKK(3,NHKK) = PZ
28214       PHKK(4,NHKK) = E
28215       PTOT = SQRT( PX**2+PY**2+PZ**2 )
28216       IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
28217          PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
28218          PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
28219       ELSE
28220          PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
28221 C        IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
28222 C    &      WRITE(LOUT,'(1X,A,G10.3)')
28223 C    &        'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
28224          PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
28225       ENDIF
28226       IDCHK = ID/10000
28227       IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
28228 * special treatment for chains:
28229 *    z coordinate of chain in Lab  = pos. of target nucleon
28230 *    time of chain-creation in Lab = time of passage of projectile
28231 *                                    nucleus at pos. of taget nucleus
28232 C        VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
28233 C        VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
28234          VHKK(1,NHKK) = VHKK(1,MO2)
28235          VHKK(2,NHKK) = VHKK(2,MO2)
28236          VHKK(3,NHKK) = VHKK(3,MO2)
28237          VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
28238 C        WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
28239 C        WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
28240          WHKK(1,NHKK) = WHKK(1,MO1)
28241          WHKK(2,NHKK) = WHKK(2,MO1)
28242          WHKK(3,NHKK) = WHKK(3,MO1)
28243          WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
28244       ELSE
28245          IF (MO1.GT.0) THEN
28246             DO 1 I=1,4
28247                VHKK(I,NHKK) = VHKK(I,MO1)
28248                WHKK(I,NHKK) = WHKK(I,MO1)
28249     1       CONTINUE
28250          ELSE
28251             DO 2 I=1,4
28252                VHKK(I,NHKK) = ZERO
28253                WHKK(I,NHKK) = ZERO
28254     2       CONTINUE
28255          ENDIF
28256       ENDIF
28257
28258       RETURN
28259       END
28260
28261 *$ CREATE DT_CHASTA.FOR
28262 *COPY DT_CHASTA
28263 *
28264 *===chasta=============================================================*
28265 *
28266       SUBROUTINE DT_CHASTA(MODE)
28267
28268 ************************************************************************
28269 * This subroutine performs CHAin STAtistics and checks sequence of     *
28270 * partons in dtevt1 and sorts them with projectile partons coming      *
28271 * first if necessary.                                                  *
28272 *                                                                      *
28273 * This version dated  8.5.00  is written by S. Roesler.                *
28274 ************************************************************************
28275
28276       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28277       SAVE
28278       PARAMETER ( LINP = 10 ,
28279      &            LOUT = 6 ,
28280      &            LDAT = 9 )
28281
28282       CHARACTER*5 CCHTYP
28283
28284 * event history
28285       PARAMETER (NMXHKK=200000)
28286       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28287      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28288      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28289 * extended event history
28290       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28291      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28292      &                IHIST(2,NMXHKK)
28293 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
28294       PARAMETER (MAXCHN=10000)
28295       COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
28296
28297       DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
28298      &          CCHTYP(9),ICHSTA(10),ITOT(10)
28299       DATA ICHCFG /1800*0/
28300       DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
28301       DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
28302       DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
28303       DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
28304       DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
28305       DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
28306       DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
28307      &              'ad aq',' d ad','ad d ',' g g '/
28308 *
28309 * initialization
28310 *
28311       IF (MODE.EQ.-1) THEN
28312          NCHAIN = 0
28313 *
28314 * loop over DTEVT1 and analyse chain configurations
28315 *
28316       ELSEIF (MODE.EQ.0) THEN
28317          DO 21 IDX=NPOINT(3),NHKK
28318             IDCHK = IDHKK(IDX)/10000
28319             IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28320      &          (IDHKK(IDX).NE.80000).AND.
28321      &          (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
28322                IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
28323                   WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
28324      &                          ' at entry ',IDX
28325                   GOTO 21
28326                ENDIF
28327 *
28328                IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28329                IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28330                IMO1 = IST1/10
28331                IMO1 = IST1-10*IMO1
28332                IMO2 = IST2/10
28333                IMO2 = IST2-10*IMO2
28334 *   swop parton entries if necessary since we need projectile partons
28335 *   to come first in the common
28336                IF (IMO1.GT.IMO2) THEN
28337                   NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
28338                   DO 22 K=1,NPTN/2
28339                      I0 = JMOHKK(1,IDX)-1+K
28340                      I1 = JMOHKK(2,IDX)+1-K
28341                      ITMP = ISTHKK(I0)
28342                      ISTHKK(I0) = ISTHKK(I1)
28343                      ISTHKK(I1) = ITMP
28344                      ITMP = IDHKK(I0)
28345                      IDHKK(I0) = IDHKK(I1)
28346                      IDHKK(I1) = ITMP
28347                      IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
28348      &                  JDAHKK(1,JMOHKK(1,I0)) = I1
28349                      IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
28350      &                  JDAHKK(2,JMOHKK(1,I0)) = I1
28351                      IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
28352      &                  JDAHKK(1,JMOHKK(2,I0)) = I1
28353                      IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
28354      &                  JDAHKK(2,JMOHKK(2,I0)) = I1
28355                      IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
28356      &                  JDAHKK(1,JMOHKK(1,I1)) = I0
28357                      IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
28358      &                  JDAHKK(2,JMOHKK(1,I1)) = I0
28359                      IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
28360      &                  JDAHKK(1,JMOHKK(2,I1)) = I0
28361                      IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
28362      &                  JDAHKK(2,JMOHKK(2,I1)) = I0
28363                      ITMP = JMOHKK(1,I0)
28364                      JMOHKK(1,I0) = JMOHKK(1,I1)
28365                      JMOHKK(1,I1) = ITMP
28366                      ITMP = JMOHKK(2,I0)
28367                      JMOHKK(2,I0) = JMOHKK(2,I1)
28368                      JMOHKK(2,I1) = ITMP
28369                      ITMP = JDAHKK(1,I0)
28370                      JDAHKK(1,I0) = JDAHKK(1,I1)
28371                      JDAHKK(1,I1) = ITMP
28372                      ITMP = JDAHKK(2,I0)
28373                      JDAHKK(2,I0) = JDAHKK(2,I1)
28374                      JDAHKK(2,I1) = ITMP
28375                      DO 23 J=1,4
28376                         RTMP1 = PHKK(J,I0)
28377                         RTMP2 = VHKK(J,I0)
28378                         RTMP3 = WHKK(J,I0)
28379                         PHKK(J,I0) = PHKK(J,I1)
28380                         VHKK(J,I0) = VHKK(J,I1)
28381                         WHKK(J,I0) = WHKK(J,I1)
28382                         PHKK(J,I1) = RTMP1
28383                         VHKK(J,I1) = RTMP2
28384                         WHKK(J,I1) = RTMP3
28385    23                CONTINUE
28386                      RTMP1 = PHKK(5,I0)
28387                      PHKK(5,I0) = PHKK(5,I1)
28388                      PHKK(5,I1) = RTMP1
28389                      ITMP = IDRES(I0)
28390                      IDRES(I0) = IDRES(I1)
28391                      IDRES(I1) = ITMP
28392                      ITMP = IDXRES(I0)
28393                      IDXRES(I0) = IDXRES(I1)
28394                      IDXRES(I1) = ITMP
28395                      ITMP = NOBAM(I0)
28396                      NOBAM(I0) = NOBAM(I1)
28397                      NOBAM(I1) = ITMP
28398                      ITMP = IDBAM(I0)
28399                      IDBAM(I0) = IDBAM(I1)
28400                      IDBAM(I1) = ITMP
28401                      ITMP = IDCH(I0)
28402                      IDCH(I0) = IDCH(I1)
28403                      IDCH(I1) = ITMP
28404                      ITMP = IHIST(1,I0)
28405                      IHIST(1,I0) = IHIST(1,I1)
28406                      IHIST(1,I1) = ITMP
28407                      ITMP = IHIST(2,I0)
28408                      IHIST(2,I0) = IHIST(2,I1)
28409                      IHIST(2,I1) = ITMP
28410    22             CONTINUE
28411                ENDIF
28412                IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28413                IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28414 *
28415 *   parton 1 (projectile side)
28416                IF (IST1.EQ.21) THEN
28417                   IDX1 = 1
28418                ELSEIF (IST1.EQ.22) THEN
28419                   IDX1 = 2
28420                ELSEIF (IST1.EQ.31) THEN
28421                   IDX1 = 3
28422                ELSEIF (IST1.EQ.32) THEN
28423                   IDX1 = 4
28424                ELSEIF (IST1.EQ.41) THEN
28425                   IDX1 = 5
28426                ELSEIF (IST1.EQ.42) THEN
28427                   IDX1 = 6
28428                ELSEIF (IST1.EQ.51) THEN
28429                   IDX1 = 7
28430                ELSEIF (IST1.EQ.52) THEN
28431                   IDX1 = 8
28432                ELSEIF (IST1.EQ.61) THEN
28433                   IDX1 = 9
28434                ELSEIF (IST1.EQ.62) THEN
28435                   IDX1 = 10
28436                ELSE
28437 c                 WRITE(LOUT,*)
28438 c    &               ' CHASTA: unknown parton status flag (',
28439 c    &               IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28440                   GOTO 21
28441                ENDIF
28442                ID = IDHKK(JMOHKK(1,IDX))
28443                IF (ABS(ID).LE.4) THEN
28444                   IF (ID.GT.0) THEN
28445                      ITYP1 = 1
28446                   ELSE
28447                      ITYP1 = 2
28448                   ENDIF
28449                ELSEIF (ABS(ID).GE.1000) THEN
28450                   IF (ID.GT.0) THEN
28451                      ITYP1 = 3
28452                   ELSE
28453                      ITYP1 = 4
28454                   ENDIF
28455                ELSEIF (ID.EQ.21) THEN
28456                   ITYP1 = 5
28457                ELSE
28458                   WRITE(LOUT,*)
28459      &               ' CHASTA: inconsistent parton identity (',
28460      &               ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28461                   GOTO 21
28462                ENDIF
28463 *
28464 *   parton 2 (target side)
28465                IF (IST2.EQ.21) THEN
28466                   IDX2 = 1
28467                ELSEIF (IST2.EQ.22) THEN
28468                   IDX2 = 2
28469                ELSEIF (IST2.EQ.31) THEN
28470                   IDX2 = 3
28471                ELSEIF (IST2.EQ.32) THEN
28472                   IDX2 = 4
28473                ELSEIF (IST2.EQ.41) THEN
28474                   IDX2 = 5
28475                ELSEIF (IST2.EQ.42) THEN
28476                   IDX2 = 6
28477                ELSEIF (IST2.EQ.51) THEN
28478                   IDX2 = 7
28479                ELSEIF (IST2.EQ.52) THEN
28480                   IDX2 = 8
28481                ELSEIF (IST2.EQ.61) THEN
28482                   IDX2 = 9
28483                ELSEIF (IST2.EQ.62) THEN
28484                   IDX2 = 10
28485                ELSE
28486 c                 WRITE(LOUT,*)
28487 c    &               ' CHASTA: unknown parton status flag (',
28488 c    &               IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
28489                   GOTO 21
28490                ENDIF
28491                ID = IDHKK(JMOHKK(2,IDX))
28492                IF (ABS(ID).LE.4) THEN
28493                   IF (ID.GT.0) THEN
28494                      ITYP2 = 1
28495                   ELSE
28496                      ITYP2 = 2
28497                   ENDIF
28498                ELSEIF (ABS(ID).GE.1000) THEN
28499                   IF (ID.GT.0) THEN
28500                      ITYP2 = 3
28501                   ELSE
28502                      ITYP2 = 4
28503                   ENDIF
28504                ELSEIF (ID.EQ.21) THEN
28505                   ITYP2 = 5
28506                ELSE
28507                   WRITE(LOUT,*)
28508      &               ' CHASTA: inconsistent parton identity (',
28509      &               ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28510                   GOTO 21
28511                ENDIF
28512 *
28513 *   fill counter
28514                ITYPE = ICHTYP(ITYP1,ITYP2)
28515                IF (ITYPE.NE.0) THEN
28516                   ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
28517                   NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
28518                   ICHCFG(IDX1,IDX2,ITYPE,2) =
28519      &               ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
28520
28521                   NCHAIN = NCHAIN+1
28522                   IF (NCHAIN.GT.MAXCHN) THEN
28523                      WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
28524      &                  NCHAIN,MAXCHN
28525                      STOP
28526                   ENDIF
28527                   IDXCHN(1,NCHAIN) = IDX
28528                   IDXCHN(2,NCHAIN) = ITYPE
28529                ELSE
28530                   WRITE(LOUT,*)
28531      &               ' CHASTA: inconsistent chain at entry ',IDX
28532                   GOTO 21
28533                ENDIF
28534             ENDIF
28535    21    CONTINUE
28536 *
28537 * write statistics to output unit
28538 *
28539       ELSEIF (MODE.EQ.1) THEN
28540          WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
28541          DO 31 I=1,10
28542             WRITE(LOUT,'(/,2A)')
28543      &         ' -----------------------------------------',
28544      &         '------------------------------------'
28545             WRITE(LOUT,'(2A)')
28546      &         ' p\\t         21     22     31     32     41',
28547      &         '     42     51     52     61     62'
28548             WRITE(LOUT,'(2A)')
28549      &         ' -----------------------------------------',
28550      &         '------------------------------------'
28551             DO 32 J=1,10
28552                ITOT(J) = 0
28553                DO 33 K=1,9
28554                   ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
28555    33          CONTINUE
28556    32       CONTINUE
28557             WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
28558             DO 34 K=1,9
28559                ISUM = 0
28560                DO 35 J=1,10
28561                   ISUM = ISUM+ICHCFG(I,J,K,1)
28562    35          CONTINUE
28563                IF (ISUM.GT.0)
28564      &            WRITE(LOUT,'(1X,A5,2X,10I7)')
28565      &               CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
28566    34       CONTINUE
28567 C           WRITE(LOUT,'(2A)')
28568 C    &         ' -----------------------------------------',
28569 C    &         '-------------------------------'
28570    31    CONTINUE
28571 *
28572       ELSE
28573          WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
28574          STOP
28575       ENDIF
28576
28577       RETURN
28578       END
28579 *$ CREATE PHO_PHIST.FOR
28580 *COPY PHO_PHIST
28581 *
28582 *===pohist=============================================================*
28583 *
28584       SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
28585
28586       IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28587       SAVE
28588
28589       PARAMETER ( LINP = 10 ,
28590      &            LOUT = 6 ,
28591      &            LDAT = 9 )
28592       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
28593 * Glauber formalism: cross sections
28594       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
28595      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
28596      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
28597      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
28598      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
28599      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
28600      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
28601      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
28602      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
28603      &                BSLOPE,NEBINI,NQBINI
28604
28605       ILAB = 0
28606       IF (IMODE.EQ.10) THEN
28607          IMODE = 1
28608          ILAB  = 1
28609       ENDIF
28610       IF (ABS(IMODE).LT.1000) THEN
28611 * PHOJET-statistics
28612 C        CALL POHISX(IMODE,WEIGHT)
28613          IF (IMODE.EQ.-1) THEN
28614             MODE = 1
28615             XSTOT(1,1,1) = WEIGHT
28616          ENDIF
28617          IF (IMODE.EQ. 1) MODE = 2
28618          IF (IMODE.EQ.-2) MODE = 3
28619          IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
28620 C        IF (MODE.EQ.3) WRITE(LOUT,*)
28621 C    &      ' Sigma = ',XSPRO(1,1,1),' mb   used for normalization'
28622          CALL DT_HISTOG(MODE)
28623          CALL DT_USRHIS(MODE)
28624       ELSE
28625 * DTUNUC-statistics
28626          MODE = IMODE/1000
28627 C        IF (MODE.EQ.3) WRITE(LOUT,*)
28628 C    &      ' Sigma = ',XSPRO(1,1,1),' mb   used for normalization'
28629          CALL DT_HISTOG(MODE)
28630          CALL DT_USRHIS(MODE)
28631       ENDIF
28632
28633       RETURN
28634       END
28635
28636 *$ CREATE DT_SWPPHO.FOR
28637 *COPY DT_SWPPHO
28638 *
28639 *===swppho=============================================================*
28640 *
28641       SUBROUTINE DT_SWPPHO(ILAB)
28642
28643       IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28644       SAVE
28645       PARAMETER ( LINP = 10 ,
28646      &            LOUT = 6 ,
28647      &            LDAT = 9 )
28648       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28649
28650       LOGICAL LSTART
28651
28652 * event history
28653       PARAMETER (NMXHKK=200000)
28654       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28655      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28656      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28657 * extended event history
28658       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28659      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28660      &                IHIST(2,NMXHKK)
28661 * flags for input different options
28662       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28663       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28664      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28665 * properties of photon/lepton projectiles
28666       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
28667
28668 **PHOJET105a
28669 C     PARAMETER (NMXHEP=2000)
28670 C     COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28671 C    &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
28672 C     COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28673 C     COMMON /PLASAV/ PLAB
28674 **PHOJET110
28675 C  standard particle data interface
28676       INTEGER NMXHEP
28677       PARAMETER (NMXHEP=4000)
28678       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28679       DOUBLE PRECISION PHEP,VHEP
28680       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28681      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28682      &                VHEP(4,NMXHEP),NSD1, NSD2, NDD
28683 C  extension to standard particle data interface (PHOJET specific)
28684       INTEGER IMPART,IPHIST,ICOLOR
28685       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28686 C  global event kinematics and particle IDs
28687       INTEGER IFPAP,IFPAB
28688       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28689       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28690 **
28691       DATA ICOUNT/0/
28692
28693       DATA LSTART /.TRUE./
28694
28695 C     IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
28696       IF ((IFRAME.EQ.1).AND.LSTART) THEN
28697          UMO  = ECM
28698          ELA  = ZERO
28699          PLA  = ZERO
28700          IDP  = IDT_ICIHAD(IFPAP(1))
28701          IDT  = IDT_ICIHAD(IFPAP(2))
28702          VIRT = PVIRT(1)
28703          CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
28704          PLAB = PLA
28705          LSTART = .FALSE.
28706       ENDIF
28707
28708       NHKK   = 0
28709       ICOUNT = ICOUNT+1
28710 C     NEVHKK = NEVHEP
28711       NEVHKK = ICOUNT
28712       IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
28713       DO 1 I=3,NHEP
28714          IF (ISTHEP(I).EQ.1) THEN
28715             NHKK = NHKK+1
28716             ISTHKK(NHKK) = 1
28717             IDHKK(NHKK)  = IDHEP(I)
28718             JMOHKK(1,NHKK) = 0
28719             JMOHKK(2,NHKK) = 0
28720             JDAHKK(1,NHKK) = 0
28721             JDAHKK(2,NHKK) = 0
28722             DO 2 K=1,4
28723                PHKK(K,NHKK) = PHEP(K,I)
28724                VHKK(K,NHKK) = ZERO
28725                WHKK(K,NHKK) = ZERO
28726     2       CONTINUE
28727             IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
28728      &         CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
28729      &                    PHKK(3,NHKK),PHKK(4,NHKK),-3)
28730             PHKK(5,NHKK) = PHEP(5,I)
28731             IDRES(NHKK)  = 0
28732             IDXRES(NHKK) = 0
28733             NOBAM(NHKK)  = 0
28734             IDBAM(NHKK)  = IDT_ICIHAD(IDHEP(I))
28735             IDCH(NHKK)   = 0
28736          ENDIF
28737     1 CONTINUE
28738
28739       RETURN
28740       END
28741
28742 *$ CREATE DT_HISTOG.FOR
28743 *COPY DT_HISTOG
28744 *
28745 *===histog=============================================================*
28746 *
28747       SUBROUTINE DT_HISTOG(MODE)
28748
28749 ************************************************************************
28750 * This version dated 25.03.96 is written by S. Roesler                 *
28751 ************************************************************************
28752
28753       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28754       SAVE
28755       PARAMETER ( LINP = 10 ,
28756      &            LOUT = 6 ,
28757      &            LDAT = 9 )
28758
28759       LOGICAL LFSP,LRNL
28760
28761 * event history
28762       PARAMETER (NMXHKK=200000)
28763       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28764      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28765      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28766 * extended event history
28767       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28768      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28769      &                IHIST(2,NMXHKK)
28770 * event flag used for histograms
28771       COMMON /DTNORM/ ICEVT,IEVHKK
28772 * flags for activated histograms
28773       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
28774
28775       IEVHKK = NEVHKK
28776       GOTO (1,2,3) MODE
28777
28778 *------------------------------------------------------------------
28779 * initialization
28780     1 CONTINUE
28781       ICEVT = 0
28782       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
28783       IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
28784
28785       RETURN
28786 *------------------------------------------------------------------
28787 * filling of histogram with event-record
28788     2 CONTINUE
28789       ICEVT = ICEVT+1
28790
28791       DO 20 I=1,NHKK
28792          CALL DT_SWPFSP(I,LFSP,LRNL)
28793          IF (LFSP) THEN
28794             IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
28795             IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
28796          ENDIF
28797          IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
28798    20 CONTINUE
28799       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
28800
28801       RETURN
28802 *------------------------------------------------------------------
28803 * output
28804     3 CONTINUE
28805       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
28806       IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
28807
28808       RETURN
28809       END
28810
28811 *$ CREATE DT_SWPFSP.FOR
28812 *COPY DT_SWPFSP
28813 *
28814 *===swpfsp=============================================================*
28815 *
28816       SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
28817
28818       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28819       SAVE
28820       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28821       PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
28822      &           PI   =TWOPI/TWO,
28823      &           BOG  =TWOPI/360.0D0)
28824
28825 * event history
28826       PARAMETER (NMXHKK=200000)
28827       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28828      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28829      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28830 * extended event history
28831       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28832      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28833      &                IHIST(2,NMXHKK)
28834 * particle properties (BAMJET index convention)
28835       CHARACTER*8  ANAME
28836       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28837      &                IICH(210),IIBAR(210),K1(210),K2(210)
28838 * Lorentz-parameters of the current interaction
28839       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28840      &                UMO,PPCM,EPROJ,PPROJ
28841 * flags for input different options
28842       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28843       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28844      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28845 * (original name: PAREVT)
28846       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
28847      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
28848       PARAMETER ( NALLWP = 39   )
28849       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
28850      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
28851      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
28852      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
28853 * temporary storage for one final state particle
28854       LOGICAL LFRAG,LGREY,LBLACK
28855       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28856      &                SINTHE,COSTHE,THETA,THECMS,
28857      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28858      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28859      &                LFRAG,LGREY,LBLACK
28860
28861       LOGICAL LFSP,LRNL
28862
28863       LFSP = .FALSE.
28864       LRNL = .FALSE.
28865       ISTRNL = 1000
28866       MULDEF = 1
28867       IF (LEVPRT) ISTRNL = 1001
28868
28869       IF (ABS(ISTHKK(IDX)).EQ.1) THEN
28870          IST    = ISTHKK(IDX)
28871          IDPDG  = IDHKK(IDX)
28872          LFRAG  = .FALSE.
28873          IF (IDHKK(IDX).LT.80000) THEN
28874             IDBJT  = IDBAM(IDX)
28875             IBARY  = IIBAR(IDBJT)
28876             ICHAR  = IICH(IDBJT)
28877             AMASS  = AAM(IDBJT)
28878          ELSEIF (IDHKK(IDX).EQ.80000) THEN
28879             IDBJT  = 0
28880             IBARY  = IDRES(IDX)
28881             ICHAR  = IDXRES(IDX)
28882             AMASS  = PHKK(5,IDX)
28883             INUT   = IBARY-ICHAR
28884             IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
28885             IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
28886             IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
28887             IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
28888             IF (IDBJT.EQ.0) LFRAG = .TRUE.
28889          ELSE
28890             GOTO 9999
28891          ENDIF
28892          PE     = PHKK(4,IDX)
28893          PX     = PHKK(1,IDX)
28894          PY     = PHKK(2,IDX)
28895          PZ     = PHKK(3,IDX)
28896          PT2    = PX**2+PY**2
28897          PT     = SQRT(PT2)
28898          PTOT   = SQRT(PT2+PZ**2)
28899          SINTHE = PT/MAX(PTOT,TINY14)
28900          COSTHE = PZ/MAX(PTOT,TINY14)
28901          IF (COSTHE.GT.ONE) THEN
28902             THETA = ZERO
28903          ELSEIF (COSTHE.LT.-ONE) THEN
28904             THETA = TWOPI/2.0D0
28905          ELSE
28906             THETA = ACOS(COSTHE)
28907          ENDIF
28908          EKIN   = PE-AMASS
28909 **sr 15.4.96 new E_t-definition
28910          IF (IBARY.GT.0) THEN
28911             ET = EKIN*SINTHE
28912          ELSEIF (IBARY.LT.0) THEN
28913             ET = (EKIN+TWO*AMASS)*SINTHE
28914          ELSE
28915             ET = PE*SINTHE
28916          ENDIF
28917 **
28918          XLAB   = PZ/MAX(PPROJ,TINY14)
28919 C        XLAB   = PE/MAX(EPROJ,TINY14)
28920          BETA   = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
28921      &                     *(ONE+AMASS/MAX(PE,TINY14)) ))
28922          PPLUS  = PE+PZ
28923          PMINUS = PE-PZ
28924          IF (PMINUS.GT.TINY14) THEN
28925             YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28926          ELSE
28927             YY = 100.0D0
28928          ENDIF
28929          IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28930             ETA = -LOG(TAN(THETA/TWO))
28931          ELSE
28932             ETA = 100.0D0
28933          ENDIF
28934          IF (IFRAME.EQ.1) THEN
28935             CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
28936             PPLUS  = EECMS+PZCMS
28937             PMINUS = EECMS-PZCMS
28938             IF ((PPLUS*PMINUS).GT.TINY14) THEN
28939                YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28940             ELSE
28941                YYCMS = 100.0D0
28942             ENDIF
28943             PTOTCM = SQRT(PT2+PZCMS**2)
28944             COSTH = PZCMS/MAX(PTOTCM,TINY14)
28945             IF (COSTH.GT.ONE) THEN
28946                THECMS = ZERO
28947             ELSEIF (COSTH.LT.-ONE) THEN
28948                THECMS = TWOPI/2.0D0
28949             ELSE
28950                THECMS = ACOS(COSTH)
28951             ENDIF
28952             IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
28953                ETACMS = -LOG(TAN(THECMS/TWO))
28954             ELSE
28955                ETACMS = 100.0D0
28956             ENDIF
28957             XF = PZCMS/MAX(PPCM,TINY14)
28958             THECMS = THECMS/BOG
28959          ELSE
28960             PZCMS  = PZ
28961             EECMS  = PE
28962             YYCMS  = YY
28963             ETACMS = ETA
28964             XF     = XLAB
28965             THECMS = THETA/BOG
28966          ENDIF
28967          THETA  = THETA/BOG
28968
28969 * set flag for "grey/black"
28970          LGREY  = .FALSE.
28971          LBLACK = .FALSE.
28972          EK     = EKIN
28973          IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
28974          IF (MULDEF.EQ.1) THEN
28975 *  EMU01-Def.
28976             IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
28977      &                              (EK.LE.375.0D-3)      ).OR.
28978      &           ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
28979      &                              (EK.LE. 56.0D-3)      ).OR.
28980      &           ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
28981      &                              (EK.LE. 56.0D-3)      ).OR.
28982      &           ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
28983      &                              (EK.LE.198.0D-3)      ).OR.
28984      &           ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
28985      &                              (EK.LE.198.0D-3)      ).OR.
28986      &           ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28987      &             (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28988      &             (IDBJT.NE.16).AND.
28989      &             (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)    ) )
28990      &         LGREY = .TRUE.
28991             IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
28992      &           ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
28993      &           ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
28994      &           ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
28995      &           ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
28996      &           ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28997      &             (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28998      &             (IDBJT.NE.16).AND.(BETA.LE.0.23D0)  ) )
28999      &         LBLACK = .TRUE.
29000          ELSE
29001 *  common Def.
29002             IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
29003             IF (BETA.LE.0.23D0) LBLACK=.TRUE.
29004          ENDIF
29005          LFSP = .TRUE.
29006       ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
29007          IST    = ISTHKK(IDX)
29008          IDPDG  = IDHKK(IDX)
29009          LFRAG  = .TRUE.
29010          IDBJT  = 0
29011          IBARY  = IDRES(IDX)
29012          ICHAR  = IDXRES(IDX)
29013          AMASS  = PHKK(5,IDX)
29014          PE     = PHKK(4,IDX)
29015          PX     = PHKK(1,IDX)
29016          PY     = PHKK(2,IDX)
29017          PZ     = PHKK(3,IDX)
29018          PT2    = PX**2+PY**2
29019          PT     = SQRT(PT2)
29020          PTOT   = SQRT(PT2+PZ**2)
29021          SINTHE = PT/MAX(PTOT,TINY14)
29022          COSTHE = PZ/MAX(PTOT,TINY14)
29023          IF (COSTHE.GT.ONE) THEN
29024             THETA = ZERO
29025          ELSEIF (COSTHE.LT.-ONE) THEN
29026             THETA = TWOPI/2.0D0
29027          ELSE
29028             THETA  = ACOS(COSTHE)
29029          ENDIF
29030          EKIN   = PE-AMASS
29031 **sr 15.4.96 new E_t-definition
29032 C        ET     = PE*SINTHE
29033          ET     = EKIN*SINTHE
29034 **
29035          IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
29036             ETA = -LOG(TAN(THETA/TWO))
29037          ELSE
29038             ETA = 100.0D0
29039          ENDIF
29040          THETA  = THETA/BOG
29041          LRNL   = .TRUE.
29042       ENDIF
29043
29044  9999 CONTINUE
29045       RETURN
29046       END
29047
29048 *$ CREATE DT_HIMULT.FOR
29049 *COPY DT_HIMULT
29050 *
29051 *===himult=============================================================*
29052 *
29053       SUBROUTINE DT_HIMULT(MODE)
29054
29055 ************************************************************************
29056 * Tables of average energies/multiplicities.                           *
29057 * This version dated 30.08.2000 is written by S. Roesler               *
29058 ************************************************************************
29059
29060       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29061       SAVE
29062       PARAMETER ( LINP = 10 ,
29063      &            LOUT = 6 ,
29064      &            LDAT = 9 )
29065       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29066
29067       PARAMETER (SWMEXP=1.7D0)
29068
29069       CHARACTER*8 ANAMEH(4)
29070
29071 * particle properties (BAMJET index convention)
29072       CHARACTER*8  ANAME
29073       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29074      &                IICH(210),IIBAR(210),K1(210),K2(210)
29075 * temporary storage for one final state particle
29076       LOGICAL LFRAG,LGREY,LBLACK
29077       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29078      &                SINTHE,COSTHE,THETA,THECMS,
29079      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29080      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29081      &                LFRAG,LGREY,LBLACK
29082 * event flag used for histograms
29083       COMMON /DTNORM/ ICEVT,IEVHKK
29084 * Lorentz-parameters of the current interaction
29085       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
29086      &                UMO,PPCM,EPROJ,PPROJ
29087
29088       PARAMETER (NOPART=210)
29089       DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
29090      &          AVPT(4,NOPART),IAVPT(4,NOPART)
29091       DATA ANAMEH /'DEUTERON','3-H     ','3-HE    ','4-HE    '/
29092
29093       GOTO (1,2,3) MODE
29094
29095 *------------------------------------------------------------------
29096 * initialization
29097     1 CONTINUE
29098       DO 10 I=1,NOPART
29099          DO 11 J=1,4
29100             AVMULT(J,I) = ZERO
29101             AVE(J,I)    = ZERO
29102             AVSWM(J,I)  = ZERO
29103             AVPT(J,I)   = ZERO
29104             IAVPT(J,I)  = 0
29105    11    CONTINUE
29106    10 CONTINUE
29107
29108       RETURN
29109
29110 *------------------------------------------------------------------
29111 * filling of histogram with event-record
29112     2 CONTINUE
29113       IF (PE.LT.0.0D0) THEN
29114          WRITE(LOUT,*) ' HIMULT:  PE < 0 ! ',PE
29115          RETURN
29116       ENDIF
29117       IF (.NOT.LFRAG) THEN
29118          IVEL = 2
29119          IF (LGREY)  IVEL = 3
29120          IF (LBLACK) IVEL = 4
29121          AVE(1,IDBJT)       = AVE(1,IDBJT)   +PE
29122          AVE(IVEL,IDBJT)    = AVE(IVEL,IDBJT)+PE
29123          AVPT(1,IDBJT)     = AVPT(1,IDBJT)   +PT
29124          AVPT(IVEL,IDBJT)  = AVPT(IVEL,IDBJT)+PT
29125          IAVPT(1,IDBJT)    = IAVPT(1,IDBJT)   +1
29126          IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
29127          AVSWM(1,IDBJT)     = AVSWM(1,IDBJT)   +PE**SWMEXP
29128          AVSWM(IVEL,IDBJT)  = AVSWM(IVEL,IDBJT)+PE**SWMEXP
29129          AVMULT(1,IDBJT)    = AVMULT(1,IDBJT)   +ONE
29130          AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
29131          IF (IDBJT.LT.116) THEN
29132 *   total energy, multiplicity
29133             AVE(1,30)       = AVE(1,30)   +PE
29134             AVE(IVEL,30)    = AVE(IVEL,30)+PE
29135             AVPT(1,30)     = AVPT(1,30)   +PT
29136             AVPT(IVEL,30)  = AVPT(IVEL,30)+PT
29137             IAVPT(1,30)    = IAVPT(1,30)   +1
29138             IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
29139             AVSWM(1,30)     = AVSWM(1,30)+PE**SWMEXP
29140             AVSWM(IVEL,30)  = AVSWM(IVEL,30)+PE**SWMEXP
29141             AVMULT(1,30)    = AVMULT(1,30)   +ONE
29142             AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
29143 *   charged energy, multiplicity
29144             IF (ICHAR.LT.0) THEN
29145                AVE(1,26)       = AVE(1,26)   +PE
29146                AVE(IVEL,26)    = AVE(IVEL,26)+PE
29147                AVPT(1,26)     = AVPT(1,26)   +PT
29148                AVPT(IVEL,26)  = AVPT(IVEL,26)+PT
29149                IAVPT(1,26)    = IAVPT(1,26)   +1
29150                IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
29151                AVSWM(1,26)     = AVSWM(1,26)   +PE**SWMEXP
29152                AVSWM(IVEL,26)  = AVSWM(IVEL,26)+PE**SWMEXP
29153                AVMULT(1,26)    = AVMULT(1,26)   +ONE
29154                AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
29155             ENDIF
29156             IF (ICHAR.NE.0) THEN
29157                AVE(1,27)       = AVE(1,27)   +PE
29158                AVE(IVEL,27)    = AVE(IVEL,27)+PE
29159                AVPT(1,27)     = AVPT(1,27)   +PT
29160                AVPT(IVEL,27)  = AVPT(IVEL,27)+PT
29161                IAVPT(1,27)    = IAVPT(1,27)   +1
29162                IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
29163                AVSWM(1,27)     = AVSWM(1,27)   +PE**SWMEXP
29164                AVSWM(IVEL,27)  = AVSWM(IVEL,27)+PE**SWMEXP
29165                AVMULT(1,27)    = AVMULT(1,27)   +ONE
29166                AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
29167             ENDIF
29168          ENDIF
29169       ENDIF
29170
29171       RETURN
29172
29173 *------------------------------------------------------------------
29174 * output
29175     3 CONTINUE
29176       WRITE(LOUT,3000)
29177  3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
29178      &       29X,'---------------------',/)
29179       IF (MULDEF.EQ.1) THEN
29180          WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
29181       ELSE
29182          BETGRE = 0.7D0
29183          BETBLC = 0.23D0
29184          WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
29185  3002    FORMAT(1X,'fast:  beta > ',F4.2,'    grey:  ',F4.2,' > beta > '
29186      &          ,F4.2,'    black:  beta < ',F4.2,/)
29187       ENDIF
29188       WRITE(LOUT,3003) SWMEXP
29189  3003 FORMAT(1X,'particle    |',12X,'average multiplicity',/,
29190      &      13X,'|     total         fast',
29191 C    &      '       grey     black      K      f(',F3.1,')',/,1X,
29192      &      '       grey     black    <pt>     f(',F3.1,')',/,1X,
29193      &      '------------+--------------',
29194      &      '-------------------------------------------------')
29195       DO 30 I=1,NOPART
29196          DO 31 J=1,4
29197             AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
29198             AVE(J,I)    = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
29199             AVPT(J,I)   = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
29200             AVSWM(J,I)  = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
29201    31    CONTINUE
29202          IF (I.LE.115) THEN
29203             WRITE(LOUT,3004) ANAME(I),I,
29204      &                       AVMULT(1,I),AVMULT(2,I),
29205      &                       AVMULT(3,I),AVMULT(4,I),
29206 C    &                       AVE(1,I),AVSWM(1,I)
29207      &                       AVPT(1,I),AVSWM(1,I)
29208          ELSEIF (I.LE.119) THEN
29209             WRITE(LOUT,3004) ANAMEH(I-115),I,
29210      &                       AVMULT(1,I),AVMULT(2,I),
29211      &                       AVMULT(3,I),AVMULT(4,I),
29212 C    &                       AVE(1,I),AVSWM(1,I)
29213      &                       AVPT(1,I),AVSWM(1,I)
29214          ENDIF
29215  3004    FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
29216    30 CONTINUE
29217 **temporary
29218 C     WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
29219 C    &               AVMULT(3,27)+AVMULT(4,27)
29220 **
29221
29222       RETURN
29223       END
29224
29225 *$ CREATE DT_HISTAT.FOR
29226 *COPY DT_HISTAT
29227 *
29228 *===histat=============================================================*
29229 *
29230       SUBROUTINE DT_HISTAT(IDX,MODE)
29231
29232 ************************************************************************
29233 * This version dated 26.02.96 is written by S. Roesler                 *
29234 *                                                                      *
29235 * Last change 27.12.2006 by S. Roesler.                                *
29236 ************************************************************************
29237
29238       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29239       SAVE
29240       PARAMETER ( LINP = 10 ,
29241      &            LOUT = 6 ,
29242      &            LDAT = 9 )
29243       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29244       PARAMETER (NDIM=199)
29245
29246 * event history
29247       PARAMETER (NMXHKK=200000)
29248       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
29249      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
29250      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
29251 * extended event history
29252       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
29253      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
29254      &                IHIST(2,NMXHKK)
29255 * particle properties (BAMJET index convention)
29256       CHARACTER*8  ANAME
29257       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29258      &                IICH(210),IIBAR(210),K1(210),K2(210)
29259       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
29260 * Glauber formalism: cross sections
29261       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
29262      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
29263      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
29264      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
29265      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
29266      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
29267      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
29268      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
29269      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
29270      &                BSLOPE,NEBINI,NQBINI
29271 * emulsion treatment
29272       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
29273      &                NCOMPO,IEMUL
29274 * properties of interacting particles
29275       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
29276 * rejection counter
29277       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
29278      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
29279      &                IREXCI(3),IRDIFF(2),IRINC
29280 * statistics: residual nuclei
29281       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
29282      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
29283      &                NINCST(2,4),NINCEV(2),
29284      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
29285      &                NRESPB(2),NRESCH(2),NRESEV(4),
29286      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
29287      &                NEVAFI(2,2)
29288 * parameter for intranuclear cascade
29289       LOGICAL LPAULI
29290       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
29291 * (original name: PAREVT)
29292       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
29293      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
29294       PARAMETER ( NALLWP = 39   )
29295       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
29296      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
29297      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
29298      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
29299 * (original name: FRBKCM)
29300       PARAMETER ( MXFFBK =     6 )
29301       PARAMETER ( MXZFBK =     9 )
29302       PARAMETER ( MXNFBK =    10 )
29303       PARAMETER ( MXAFBK =    16 )
29304       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
29305       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
29306       PARAMETER ( NXAFBK = MXAFBK + 1 )
29307       PARAMETER ( MXPSST =   300 )
29308       PARAMETER ( MXPSFB = 41000 )
29309       LOGICAL LFRMBK, LNCMSS
29310       COMMON /FKFRBK/  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
29311      &          EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
29312      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
29313      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
29314      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
29315      &          IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
29316      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
29317      &          IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
29318      &          IFBFRB, NBUFBK, LFRMBK, LNCMSS
29319 * (original name: INPFLG)
29320       COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
29321 * temporary storage for one final state particle
29322       LOGICAL LFRAG,LGREY,LBLACK
29323       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29324      &                SINTHE,COSTHE,THETA,THECMS,
29325      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29326      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29327      &                LFRAG,LGREY,LBLACK
29328 * event flag used for histograms
29329       COMMON /DTNORM/ ICEVT,IEVHKK
29330 * statistics: double-Pomeron exchange
29331       COMMON /DTFLG2/ INTFLG,IPOPO
29332
29333       DIMENSION EMUSAM(NCOMPX)
29334
29335       CHARACTER*13 CMSG(3)
29336       DATA CMSG /'not requested','not requested','not requested'/
29337
29338       GOTO (1,2,3,4,5) MODE
29339
29340 *------------------------------------------------------------------
29341 * initialization
29342     1 CONTINUE
29343 *  emulsion treatment
29344       IF (NCOMPO.GT.0) THEN
29345          DO 10 I=1,NCOMPX
29346             EMUSAM(I) = ZERO
29347    10    CONTINUE
29348       ENDIF
29349 * common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
29350       NINCGE = 0
29351       DO 11 I=1,2
29352          EXCDPM(I)   = ZERO
29353          EXCDPM(I+2) = ZERO
29354          EXCEVA(I)   = ZERO
29355          NINCWO(I)   = 0
29356          NINCEV(I)   = 0
29357          NRESTO(I)   = 0
29358          NRESPR(I)   = 0
29359          NRESNU(I)   = 0
29360          NRESBA(I)   = 0
29361          NRESPB(I)   = 0
29362          NRESCH(I)   = 0
29363          NRESEV(I)   = 0
29364          NRESEV(I+2) = 0
29365          NEVAGA(I)   = 0
29366          NEVAHT(I)   = 0
29367          NEVAFI(1,I) = 0
29368          NEVAFI(2,I) = 0
29369          DO 12 J=1,6
29370             IF (J.LE.2) NINCHR(I,J) = 0
29371             IF (J.LE.3) NINCCO(I,J) = 0
29372             IF (J.LE.4) NINCST(I,J) = 0
29373             NEVA(I,J) = 0
29374    12    CONTINUE
29375          DO 13 J=1,210
29376             NEVAHY(1,I,J) = 0
29377             NEVAHY(2,I,J) = 0
29378    13    CONTINUE
29379    11 CONTINUE
29380       MAXGEN = 0
29381 **dble Po statistics.
29382       KPOPO = 0
29383
29384       RETURN
29385 *------------------------------------------------------------------
29386 * filling of histogram with event-record
29387     2 CONTINUE
29388       IF (IST.EQ.-1) THEN
29389          IF (.NOT.LFRAG) THEN
29390             IF (IDPDG.EQ.2212) THEN
29391                NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
29392             ELSEIF (IDPDG.EQ.2112) THEN
29393                NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
29394             ELSEIF (IDPDG.EQ.22) THEN
29395                NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
29396             ELSEIF (IDPDG.EQ.80000) THEN
29397                IF (IDBJT.EQ.116) THEN
29398                   NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
29399                ELSEIF (IDBJT.EQ.117) THEN
29400                   NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
29401                ELSEIF (IDBJT.EQ.118) THEN
29402                   NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
29403                ELSEIF (IDBJT.EQ.119) THEN
29404                   NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
29405                ENDIF
29406             ENDIF
29407          ELSE
29408 *   heavy fragments (here: fission products only)
29409             NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
29410             NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
29411             NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29412          ENDIF
29413       ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
29414          IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
29415       ENDIF
29416
29417       RETURN
29418 *------------------------------------------------------------------
29419 * output
29420     3 CONTINUE
29421
29422 **dble Po statistics.
29423 C     WRITE(LOUT,'(1X,A,2I7,2E12.4)')
29424 C    &   '# evts. / # dble-Po. evts / s_in / s_popo :',
29425 C    & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
29426
29427 *  emulsion treatment
29428       IF (NCOMPO.GT.0) THEN
29429          WRITE(LOUT,3000)
29430  3000    FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
29431      &          22X,'----------------------------',/,/,19X,
29432      &          'mass    charge          fraction',/,39X,
29433      &          'input     treated',/)
29434          DO 30 I=1,NCOMPO
29435             WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
29436      &                       EMUSAM(I)/DBLE(ICEVT)
29437  3013       FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
29438    30    CONTINUE
29439       ENDIF
29440
29441 *  i.n.c. statistics: output
29442       WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
29443  3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
29444      &       22X,'---------------------------------',/,/,1X,
29445      &       'no. of events for normalization: (accepted final events,',
29446      &       ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
29447      &       /,1X,'no. of rejected events due to intranuclear',
29448      &       ' cascade',15X,I6,/)
29449       ICEV  = MAX(ICEVT,1)
29450       ICEV1 = ICEV
29451       IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
29452       WRITE(LOUT,3002)
29453      &     (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
29454      &     ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
29455      &     KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
29456      &    (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29457      &     (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
29458      &     (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29459      &     (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
29460  3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
29461      &       5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
29462      &       ' proj./ target (mean per evt)',/,8X,'baryons:  pos. ',
29463      &       F7.3,' /',F7.3,'   neg. ',F7.3,' /',F7.3,/,8X,
29464      &       'mesons:   pos. ',F7.3,' /',F7.3,'   neg. ',F7.3,' /',F7.3,
29465      &       /,1X,'maximum no. of generations treated (maximum allowed:'
29466      &       ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
29467      &       ' interactions in proj./ target (mean per evt1)',
29468      &       F7.3,' /',F7.3,/,8X,'out of which by inelastic',
29469      &       ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
29470      &       'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
29471      &       '(ap, K-, pi- only)     ',F7.3,' /',F7.3,/)
29472       WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
29473      &                 IREXCI(1)+IREXCI(2)+IREXCI(3)
29474  3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
29475      &       'evaporation',/,22X,'-----------------------------',
29476      &       '------------',/,/,1X,'no. of events for normal.: ',
29477      &       '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
29478      &       ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
29479      &       ' rejected events     (',I4,',',I4,',',I4,')',22X,I6,/)
29480
29481       WRITE(LOUT,3004)
29482  3004 FORMAT(/,22X,'1) before evaporation-step:',/)
29483       ICEV  = MAX(NRESEV(2),1)
29484       WRITE(LOUT,3005)
29485      &     (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
29486      &     (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
29487      &     (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
29488      &     (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
29489      &     (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
29490      &     (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
29491      &     (EXCDPM(I)/DBLE(ICEV),I=1,2),
29492      &     (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
29493  3005    FORMAT(1X,'residual nuclei:  (mean values per evt)',12X,
29494      &       'proj. / target',/,/,8X,'total number of particles',15X,
29495      &       2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29496      &       'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
29497      &       'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
29498      &       /,8X,'excitation energy (bef. evap.-step)   ',2E11.3,/,
29499      &       8X,'excitation energy per nucleon         ',2E11.3,/,/)
29500
29501 * evaporation / fission / fragmentation statistics: output
29502       ICEV  = MAX(NRESEV(2),1)
29503       ICEV1 = MAX(NRESEV(4),1)
29504       NTEVA1 =
29505      &   NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
29506       NTEVA2 =
29507      &   NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
29508       IF (LEVPRT) THEN
29509          IF (IFISS.EQ.1) CMSG(1) = 'requested    '
29510          IF (LFRMBK)     CMSG(2) = 'requested    '
29511          IF (LDEEXG)     CMSG(3) = 'requested    '
29512          WRITE(LOUT,3006)
29513      &        CMSG,
29514      &        DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
29515      &        (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
29516      &        (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
29517      &        (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
29518      &        (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
29519      &        (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
29520      &        (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
29521      &        (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
29522      &        (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
29523  3006    FORMAT(22X,'2) after  evaporation-step:',/,/,1X,'Fission:',
29524      &       13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
29525      &       'deexcitation:',2X,A13,/,/,
29526      &       1X,'evaporation/deexcitation:  (mean values per evt1)  ',
29527      &       'proj. / target',/,/,8X,'total number of evap. particles',
29528      &       9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29529      &       'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
29530      &       '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
29531      &       2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
29532      &       'heavy fragments',25X,2F9.3,/)
29533          IF (IFISS.EQ.1) THEN
29534             WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
29535      &                       NEVAFI(2,1),NEVAFI(2,2),
29536      &             DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
29537      &             DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
29538  3007       FORMAT(1X,'Fission:   total number of events',14X,2I9,/
29539      &             12X,'out of which fission occured',8X,2I9,/,
29540      &             50X,'(',F5.2,'%) (',F5.2,'%)',/)
29541          ENDIF
29542 C        IF ((LFRMBK).OR.(IFISS.EQ.1)) THEN
29543 C           WRITE(LOUT,3008)
29544 C3008       FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
29545 C    &             '       proj.   / target',/)
29546 C           DO 31 I=1,210
29547 C              IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
29548 C                 WRITE(LOUT,3009) I,
29549 C    &            (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29550 C3009             FORMAT(38X,I3,3X,2E12.3)
29551 C              ENDIF
29552 C  31       CONTINUE
29553 C           WRITE(LOUT,3010)
29554 C3010       FORMAT(1X,'heavy fragments - statistics:',7X,'mass  ',
29555 C    &             '       proj.   / target',/)
29556 C           DO 32 I=1,210
29557 C              IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
29558 C                 WRITE(LOUT,3011) I,
29559 C    &            (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29560 C3011             FORMAT(38X,I3,3X,2E12.3)
29561 C              ENDIF
29562 C  32       CONTINUE
29563 C           WRITE(LOUT,*)
29564 C        ENDIF
29565       ELSE
29566          WRITE(LOUT,3012)
29567  3012    FORMAT(22X,'2) after  evaporation-step:',/,/,1X,
29568      &       'Evaporation:         not requested',/)
29569       ENDIF
29570
29571       RETURN
29572 *------------------------------------------------------------------
29573 * filling of histogram with event-record
29574     4 CONTINUE
29575 *  emulsion treatment
29576       IF (NCOMPO.GT.0) THEN
29577          DO 40 I=1,NCOMPO
29578             IF (IT.EQ.IEMUMA(I)) THEN
29579                EMUSAM(I) = EMUSAM(I)+ONE
29580             ENDIF
29581    40    CONTINUE
29582       ENDIF
29583       NINCGE = NINCGE+MAXGEN
29584       MAXGEN = 0
29585 **dble Po statistics.
29586       IF (IPOPO.EQ.1) KPOPO = KPOPO+1
29587
29588       RETURN
29589 *------------------------------------------------------------------
29590 * filling of histogram with event-record
29591     5 CONTINUE
29592       IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
29593          IB = IIBAR(IDBAM(IDX))
29594          IC = IICH(IDBAM(IDX))
29595          J  = ISTHKK(IDX)-14
29596          IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
29597             NINCST(J,1) = NINCST(J,1)+1
29598          ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
29599             NINCST(J,2) = NINCST(J,2)+1
29600          ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
29601             NINCST(J,3) = NINCST(J,3)+1
29602          ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
29603             NINCST(J,4) = NINCST(J,4)+1
29604          ENDIF
29605       ELSEIF (ISTHKK(IDX).EQ.17) THEN
29606          NINCWO(1) = NINCWO(1)+1
29607       ELSEIF (ISTHKK(IDX).EQ.18) THEN
29608          NINCWO(2) = NINCWO(2)+1
29609       ELSEIF (ISTHKK(IDX).EQ.1001) THEN
29610          IB = IDRES(IDX)
29611          IC = IDXRES(IDX)
29612          IF (IC.GT.0) THEN
29613             NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
29614             NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
29615          ENDIF
29616          NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29617       ENDIF
29618
29619       RETURN
29620       END
29621
29622 *$ CREATE DT_NEWHGR.FOR
29623 *COPY DT_NEWHGR
29624 *
29625 *===newhgr=============================================================*
29626 *
29627       SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
29628
29629 ************************************************************************
29630 *                                                                      *
29631 *     Histogram initialization.                                        *
29632 *                                                                      *
29633 *     input:  XLIM1/XLIM2  lower/upper edge of histogram-window        *
29634 *             XLIM3        bin size                                    *
29635 *             IBIN    > 0  number of bins in equidistant lin. binning  *
29636 *                     = -1 reset histograms                            *
29637 *                     < -1 |IBIN| number of bins in equidistant log.   *
29638 *                          binning or log. binning in user def. struc. *
29639 *             XLIMB(*)     user defined bin structure                  *
29640 *                                                                      *
29641 *     The bin structure is sensitive to                                *
29642 *             XLIM1, XLIM3, IBIN     if     XLIM3 > 0   (lin.)         *
29643 *             XLIM1, XLIM2, IBIN     if     XLIM3 = 0   (lin. & log.)  *
29644 *             XLIMB, IBIN            if     XLIM3 < 0                  *
29645 *                                                                      *
29646 *                                                                      *
29647 *     output: IREFN        histogram index                             *
29648 *                          (= -1 for inconsistent histogr. request)    *
29649 *                                                                      *
29650 * This subroutine is based on a original version by R. Engel.          *
29651 * This version dated 22.4.95 is written  by S. Roesler.                *
29652 ************************************************************************
29653
29654       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29655       SAVE
29656       PARAMETER ( LINP = 10 ,
29657      &            LOUT = 6 ,
29658      &            LDAT = 9 )
29659
29660       LOGICAL LSTART
29661
29662       PARAMETER (ZERO   =  0.0D0,
29663      &           TINY   =  1.0D-10)
29664
29665       DIMENSION XLIMB(*)
29666
29667 * histograms
29668       PARAMETER (NHIS=150, NDIM=250)
29669       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29670      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29671 * auxiliary common for histograms
29672       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29673
29674       DATA LSTART /.TRUE./
29675
29676 * reset histogram counter
29677       IF (LSTART.OR.(IBIN.EQ.-1)) THEN
29678          IHISL  = 0
29679          IF (IBIN.EQ.-1) RETURN
29680          LSTART = .FALSE.
29681       ENDIF
29682
29683       IHIS  = IHISL+1
29684 * check for maximum number of allowed histograms
29685       IF (IHIS.GT.NHIS) THEN
29686          WRITE(LOUT,1003) IHIS,NHIS,IHIS
29687  1003    FORMAT(1X,'NEWHGR:   warning!  number of histograms (',
29688      &          I4,') exceeds array size (',I4,')',/,21X,
29689      &          'histogram',I3,' skipped!')
29690          GOTO 9999
29691       ENDIF
29692
29693       IREFN = IHIS
29694       IBINS(IHIS) = ABS(IBIN)
29695 * check requested number of bins
29696       IF (IBINS(IHIS).GE.NDIM) THEN
29697          WRITE(LOUT,1000) IBIN,NDIM,NDIM
29698  1000    FORMAT(1X,'NEWHGR:   warning!  number of bins (',
29699      &          I3,') exceeds array size (',I3,')',/,21X,
29700      &          'and will be reset to ',I3)
29701          IBINS(IHIS) = NDIM
29702       ENDIF
29703       IF (IBINS(IHIS).EQ.0) THEN
29704          WRITE(LOUT,1001) IBIN,IHIS
29705  1001    FORMAT(1X,'NEWHGR:   warning!  inconsistent number of',
29706      &          ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
29707          GOTO 9999
29708       ENDIF
29709
29710 * initialize arrays
29711       DO 1 I=1,NDIM
29712          DO 2 K=1,3
29713             HIST(K,IHIS,I)   = ZERO
29714             HIST(K+3,IHIS,I) = ZERO
29715             TMPHIS(K,IHIS,I) = ZERO
29716     2    CONTINUE
29717          HIST(7,IHIS,I)   = ZERO
29718     1 CONTINUE
29719       DENTRY(1,IHIS)= ZERO
29720       DENTRY(2,IHIS)= ZERO
29721       OVERF(IHIS)   = ZERO
29722       UNDERF(IHIS)  = ZERO
29723       TMPUFL(IHIS)  = ZERO
29724       TMPOFL(IHIS)  = ZERO
29725
29726 * bin str. sensitive to lower edge, bin size, and numb. of bins
29727       IF (XLIM3.GT.ZERO) THEN
29728          DO 3 K=1,IBINS(IHIS)+1
29729             HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
29730     3    CONTINUE
29731          ISWI(IHIS) = 1
29732 * bin str. sensitive to lower/upper edge and numb. of bins
29733       ELSEIF (XLIM3.EQ.ZERO) THEN
29734 *   linear binning
29735          IF (IBIN.GT.0) THEN
29736             XLOW = XLIM1
29737             XHI  = XLIM2
29738             IF (XLIM2.LE.XLIM1) THEN
29739                WRITE(LOUT,1002) XLIM1,XLIM2
29740  1002          FORMAT(1X,'NEWHGR:   warning!  inconsistent x-range',
29741      &                /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29742                GOTO 9999
29743             ENDIF
29744             ISWI(IHIS) = 1
29745          ELSEIF (IBIN.LT.-1) THEN
29746 *   logarithmic binning
29747             IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
29748                WRITE(LOUT,1004) XLIM1,XLIM2
29749  1004          FORMAT(1X,'NEWHGR:   warning!  inconsistent log. ',
29750      &                'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29751                GOTO 9999
29752             ENDIF
29753             IF (XLIM2.LE.XLIM1) THEN
29754                WRITE(LOUT,1005) XLIM1,XLIM2
29755  1005          FORMAT(1X,'NEWHGR:   warning!  inconsistent x-range',
29756      &                /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29757                GOTO 9999
29758             ENDIF
29759             XLOW = LOG10(XLIM1)
29760             XHI  = LOG10(XLIM2)
29761             ISWI(IHIS) = 3
29762          ENDIF
29763          DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
29764          DO 4 K=1,IBINS(IHIS)+1
29765             HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
29766     4    CONTINUE
29767       ELSE
29768 * user defined bin structure
29769          DO 5 K=1,IBINS(IHIS)+1
29770             IF (IBIN.GT.0) THEN
29771                HIST(1,IHIS,K) = XLIMB(K)
29772                ISWI(IHIS) = 2
29773             ELSEIF (IBIN.LT.-1) THEN
29774                HIST(1,IHIS,K) = LOG10(XLIMB(K))
29775                ISWI(IHIS) = 4
29776             ENDIF
29777     5    CONTINUE
29778       ENDIF
29779
29780 * histogram accepted
29781       IHISL = IHIS
29782
29783       RETURN
29784
29785  9999 CONTINUE
29786       IREFN = -1
29787       RETURN
29788       END
29789
29790 *$ CREATE DT_FILHGR.FOR
29791 *COPY DT_FILHGR
29792 *
29793 *===filhgr=============================================================*
29794 *
29795       SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
29796
29797 ************************************************************************
29798 *                                                                      *
29799 *     Scoring for histogram IHIS.                                      *
29800 *                                                                      *
29801 * This subroutine is based on a original version by R. Engel.          *
29802 * This version dated 23.4.95 is written  by S. Roesler.                *
29803 ************************************************************************
29804
29805       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29806       SAVE
29807       PARAMETER ( LINP = 10 ,
29808      &            LOUT = 6 ,
29809      &            LDAT = 9 )
29810
29811       PARAMETER (ZERO = 0.0D0,
29812      &           ONE  = 1.0D0,
29813      &           TINY = 1.0D-10)
29814
29815 * histograms
29816       PARAMETER (NHIS=150, NDIM=250)
29817       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29818      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29819 * auxiliary common for histograms
29820       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29821
29822       DATA NCEVT /1/
29823
29824       X = XI
29825       Y = YI
29826
29827 * dump content of temorary arrays into histograms
29828       IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
29829          CALL DT_EVTHIS(IDUM)
29830          NCEVT = NEVT
29831       ENDIF
29832
29833 * check histogram index
29834       IF (IHIS.EQ.-1) RETURN
29835       IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
29836 C        WRITE(LOUT,1000) IHIS,IHISL
29837  1000    FORMAT(1X,'FILHGR:   warning!  histogram index',I4,
29838      &          ' out of range (1..',I3,')')
29839          RETURN
29840       ENDIF
29841
29842       IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
29843 * bin structure not explicitly given
29844          IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
29845          DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
29846          IF (X.LT.HIST(1,IHIS,1)) THEN
29847             I1 = 0
29848          ELSE
29849             I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
29850          ENDIF
29851
29852       ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
29853 * user defined bin structure
29854          IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
29855          IF (X.LT.HIST(1,IHIS,1)) THEN
29856             I1 = 0
29857          ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
29858             I1 = IBINS(IHIS)+1
29859          ELSE
29860 *   binary sort algorithm
29861             KMIN = 0
29862             KMAX = IBINS(IHIS)+1
29863     1       CONTINUE
29864             IF ((KMAX-KMIN).EQ.1) GOTO 2
29865             KK = (KMAX+KMIN)/2
29866             IF (X.LE.HIST(1,IHIS,KK)) THEN
29867                KMAX=KK
29868             ELSE
29869                KMIN=KK
29870             ENDIF
29871             GOTO 1
29872     2       CONTINUE
29873             I1 = KMIN
29874          ENDIF
29875
29876       ELSE
29877          WRITE(LOUT,1001)
29878  1001    FORMAT(1X,'FILHGR:   warning!  histogram not initialized')
29879          RETURN
29880       ENDIF
29881
29882 * scoring
29883       IF (I1.LE.0) THEN
29884          TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
29885       ELSEIF (I1.LE.IBINS(IHIS)) THEN
29886          TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
29887          IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
29888             TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
29889          ELSE
29890             TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
29891          ENDIF
29892          TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
29893       ELSE
29894          TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
29895       ENDIF
29896
29897       RETURN
29898       END
29899
29900 *$ CREATE DT_EVTHIS.FOR
29901 *COPY DT_EVTHIS
29902 *
29903 *===evthis=============================================================*
29904 *
29905       SUBROUTINE DT_EVTHIS(NEVT)
29906
29907 ************************************************************************
29908 * Dump content of temorary histograms into /DTHIS1/. This subroutine   *
29909 * is called after each event and for the last event before any call    *
29910 * to OUTHGR.                                                           *
29911 *         NEVT   number of events dumped, this is only needed to       *
29912 *                get the normalization after the last event            *
29913 * This version dated 23.4.95 is written  by S. Roesler.                *
29914 ************************************************************************
29915
29916       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29917       SAVE
29918       PARAMETER ( LINP = 10 ,
29919      &            LOUT = 6 ,
29920      &            LDAT = 9 )
29921
29922       LOGICAL LNOETY
29923
29924       PARAMETER (ZERO = 0.0D0,
29925      &           ONE  = 1.0D0,
29926      &           TINY = 1.0D-10)
29927
29928 * histograms
29929       PARAMETER (NHIS=150, NDIM=250)
29930       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29931      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29932 * auxiliary common for histograms
29933       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29934
29935       DATA NCEVT /0/
29936
29937       NCEVT = NCEVT+1
29938       NEVT  = NCEVT
29939
29940       DO 1 I=1,IHISL
29941          LNOETY = .TRUE.
29942          DO 2 J=1,IBINS(I)
29943             IF (TMPHIS(1,I,J).GT.ZERO) THEN
29944                LNOETY = .FALSE.
29945                HIST(2,I,J)   = HIST(2,I,J)+ONE
29946                HIST(7,I,J)   = HIST(7,I,J)+TMPHIS(1,I,J)
29947                DENTRY(2,I)   = DENTRY(2,I)+TMPHIS(1,I,J)
29948                AVX           = TMPHIS(2,I,J)/TMPHIS(1,I,J)
29949                HIST(3,I,J)   = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
29950                HIST(4,I,J)   = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
29951                HIST(5,I,J)   = HIST(5,I,J)+TMPHIS(3,I,J)
29952                HIST(6,I,J)   = HIST(6,I,J)+TMPHIS(3,I,J)**2
29953                TMPHIS(1,I,J) = ZERO
29954                TMPHIS(2,I,J) = ZERO
29955                TMPHIS(3,I,J) = ZERO
29956             ENDIF
29957     2    CONTINUE
29958          IF (LNOETY) THEN
29959             IF (TMPUFL(I).GT.ZERO) THEN
29960                UNDERF(I) = UNDERF(I)+ONE
29961                TMPUFL(I) = ZERO
29962             ELSEIF (TMPOFL(I).GT.ZERO) THEN
29963                OVERF(I)  = OVERF(I)+ONE
29964                TMPOFL(I) = ZERO
29965             ENDIF
29966          ELSE
29967             DENTRY(1,I) = DENTRY(1,I)+ONE
29968          ENDIF
29969     1 CONTINUE
29970
29971       RETURN
29972       END
29973
29974 *$ CREATE DT_OUTHGR.FOR
29975 *COPY DT_OUTHGR
29976 *
29977 *===outhgr=============================================================*
29978 *
29979       SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
29980      &                  ILOGY,INORM,NMODE)
29981
29982 ************************************************************************
29983 *                                                                      *
29984 *     Plot histogram(s) to standard output unit                        *
29985 *                                                                      *
29986 *         I1..6         indices of histograms to be plotted            *
29987 *         CHEAD,IHEAD   header string,integer                          *
29988 *         NEVTS         number of events                               *
29989 *         FAC           scaling factor                                 *
29990 *         ILOGY   = 1   logarithmic y-axis                             *
29991 *         INORM         normalization                                  *
29992 *                 = 0   no further normalization (FAC is obsolete)     *
29993 *                 = 1   per event and bin width                        *
29994 *                 = 2   per entry and bin width                        *
29995 *                 = 3   per bin entry                                  *
29996 *                 = 4   per event and "bin width" x1^2...x2^2          *
29997 *                 = 5   per event and "log. bin width" ln x1..ln x2    *
29998 *                 = 6   per event                                      *
29999 *         MODE    = 0   no output but normalization applied            *
30000 *                 = 1   all valid histograms separately (small frame)  *
30001 *                       all valid histograms separately (small frame)  *
30002 *                 = -1  and tables as histograms                       *
30003 *                 = 2   all valid histograms (one plot, wide frame)    *
30004 *                       all valid histograms (one plot, wide frame)    *
30005 *                 = -2  and tables as histograms                       *
30006 *                                                                      *
30007 *                                                                      *
30008 *     Note: All histograms to be plotted with one call to this         *
30009 *           subroutine and |MODE|=2 must have the same bin structure!  *
30010 *           There is no test included ensuring this fact.              *
30011 *                                                                      *
30012 * This version dated 23.4.95 is written  by S. Roesler.                *
30013 ************************************************************************
30014
30015       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30016       SAVE
30017       PARAMETER ( LINP = 10 ,
30018      &            LOUT = 6 ,
30019      &            LDAT = 9 )
30020
30021       CHARACTER*72 CHEAD
30022
30023       PARAMETER (ZERO   =  0.0D0,
30024      &           IZERO  =  0,
30025      &           ONE    =  1.0D0,
30026      &           TWO    =  2.0D0,
30027      &           OHALF  =  0.5D0,
30028      &           EPS    =  1.0D-5,
30029      &           TINY   =  1.0D-8,
30030      &           SMALL  =  -1.0D8,
30031      &           RLARGE =  1.0D8 )
30032
30033 * histograms
30034       PARAMETER (NHIS=150, NDIM=250)
30035       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30036      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30037
30038       PARAMETER (NDIM2 = 2*NDIM)
30039       DIMENSION XX(NDIM2),YY(NDIM2)
30040
30041       PARAMETER (NHISTO = 6)
30042       DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
30043      &          IDX(NHISTO)
30044
30045       CHARACTER*43 CNORM(0:8)
30046       DATA CNORM /'no further normalization                   ',
30047      &            'per event and bin width                    ',
30048      &            'per entry1 and bin width                   ',
30049      &            'per bin entry                              ',
30050      &            'per event and "bin width" x1^2...x2^2      ',
30051      &            'per event and "log. bin width" ln x1..ln x2',
30052      &            'per event                                  ',
30053      &            'per bin entry1                             ',
30054      &            'per entry2 and bin width                   '/
30055
30056       IDX1(1) = I1
30057       IDX1(2) = I2
30058       IDX1(3) = I3
30059       IDX1(4) = I4
30060       IDX1(5) = I5
30061       IDX1(6) = I6
30062
30063       MODE = NMODE
30064
30065 * initialization if "wide frame" is requested
30066       IF (ABS(MODE).EQ.2) THEN
30067          DO 1 I=1,NHISTO
30068             DO 2 J=1,NDIM
30069                XX1(J,I) = ZERO
30070                YY1(J,I) = ZERO
30071     2       CONTINUE
30072     1    CONTINUE
30073       ENDIF
30074
30075 * plot header
30076       WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
30077
30078 * check histogram indices
30079       NHI = 0
30080       DO 3 I=1,NHISTO
30081          IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
30082             IF (ISWI(IDX1(I)).NE.0) THEN
30083                IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
30084                   WRITE(LOUT,1000)
30085      &                 IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
30086  1000             FORMAT(/,1X,'OUTHGR:   warning!  no entries in',
30087      &                   ' histogram ',I3,/,21X,'underflows:',F10.0,
30088      &                   '   overflows:  ',F10.0)
30089                ELSE
30090                   NHI = NHI+1
30091                   IDX(NHI) = IDX1(I)
30092                ENDIF
30093             ENDIF
30094          ENDIF
30095     3 CONTINUE
30096       IF (NHI.EQ.0) THEN
30097          WRITE(LOUT,1001)
30098  1001    FORMAT(/,1X,'OUTHGR:   warning!  histogram indices not valid')
30099          RETURN
30100       ENDIF
30101
30102 * check normalization request
30103       IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
30104      &     ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
30105      &                        (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
30106      &     (INORM.LT.0).OR.(INORM.GT.8) ) THEN
30107          WRITE(LOUT,1002) NEVTS,INORM,FAC
30108  1002    FORMAT(/,1X,'OUTHGR:   warning!  normalization request not ',
30109      &          'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
30110      &          'FAC = ',E11.4)
30111          RETURN
30112       ENDIF
30113
30114       WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
30115
30116 * apply normalization
30117       DO 4 N=1,NHI
30118
30119          I = IDX(N)
30120
30121          IF (ISWI(I).EQ.1) THEN
30122             WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30123  1003       FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
30124      &             ' to',2X,E10.4,',',2X,I3,' bins')
30125          ELSEIF (ISWI(I).EQ.2) THEN
30126             WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30127             WRITE(LOUT,1007)
30128  1007       FORMAT(1X,'user defined bin structure')
30129          ELSEIF (ISWI(I).EQ.3) THEN
30130             WRITE(LOUT,1004)
30131      &         I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30132  1004       FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
30133      &             ' to',2X,E10.4,',',2X,I3,' bins')
30134          ELSEIF (ISWI(I).EQ.4) THEN
30135             WRITE(LOUT,1004)
30136      &         I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30137             WRITE(LOUT,1007)
30138          ELSE
30139             WRITE(LOUT,1008) ISWI(I)
30140  1008       FORMAT(/,1X,'warning!  inconsistent bin structure flag ',I4)
30141          ENDIF
30142          WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
30143  1005    FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
30144      &          ' overfl.:',F8.0)
30145          WRITE(LOUT,1009) CNORM(INORM)
30146  1009    FORMAT(1X,'normalization: ',A,/)
30147
30148          DO 5 K=1,IBINS(I)
30149             CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
30150             YMEAN = FAC*YMEAN
30151             YERR  = FAC*YERR
30152             WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
30153             WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
30154  1006       FORMAT(1X,5E11.3)
30155 *    small frame
30156             II = 2*K
30157             XX(II-1) = HIST(1,I,K)
30158             XX(II)   = HIST(1,I,K+1)
30159             YY(II-1) = YMEAN
30160             YY(II)   = YMEAN
30161 *    wide frame
30162             XX1(K,N) = XMEAN
30163             IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
30164      &         XX1(K,N) = LOG10(XMEAN)
30165             YY1(K,N) = YMEAN
30166     5    CONTINUE
30167
30168 * plot small frame
30169          IF (ABS(MODE).EQ.1) THEN
30170             IBIN2 = 2*IBINS(I)
30171             WRITE(LOUT,'(/,1X,A)') 'Preview:'
30172             IF(ILOGY.EQ.1) THEN
30173               CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30174             ELSE
30175               CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30176             ENDIF
30177          ENDIF
30178
30179     4 CONTINUE
30180
30181 * plot wide frame
30182       IF (ABS(MODE).EQ.2) THEN
30183          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30184          NSIZE = NDIM*NHISTO
30185          DXLOW = HIST(1,IDX(1),1)
30186          DDX   = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
30187          YLOW  = RLARGE
30188          YHI   = SMALL
30189          DO 6 I=1,NHISTO
30190             DO 7 J=1,NDIM
30191                IF (YY1(J,I).LT.YLOW) THEN
30192                   IF (ILOGY.EQ.1) THEN
30193                      IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
30194                   ELSE
30195                      YLOW = YY1(J,I)
30196                   ENDIF
30197                ENDIF
30198                IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
30199     7       CONTINUE
30200     6    CONTINUE
30201          DY = (YHI-YLOW)/DBLE(NDIM)
30202          IF (DY.LE.ZERO) THEN
30203             WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
30204      &         'OUTHGR:   warning! zero bin width for histograms ',
30205      &         IDX,': ',YLOW,YHI
30206             RETURN
30207          ENDIF
30208          IF (ILOGY.EQ.1) THEN
30209             YLOW = LOG10(YLOW)
30210             DY   = (LOG10(YHI)-YLOW)/100.0D0
30211             DO 8 I=1,NHISTO
30212                DO 9 J=1,NDIM
30213                   IF (YY1(J,I).LE.ZERO) THEN
30214                      YY1(J,I) = YLOW
30215                   ELSE
30216                      YY1(J,I) = LOG10(YY1(J,I))
30217                   ENDIF
30218     9          CONTINUE
30219     8       CONTINUE
30220          ENDIF
30221          CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
30222       ENDIF
30223
30224       RETURN
30225       END
30226
30227 *$ CREATE DT_GETBIN.FOR
30228 *COPY DT_GETBIN
30229 *
30230 *===getbin=============================================================*
30231 *
30232       SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
30233      &                  XMEAN,YMEAN,YERR)
30234
30235 ************************************************************************
30236 * This version dated 23.4.95 is written  by S. Roesler.                *
30237 ************************************************************************
30238
30239       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30240       SAVE
30241       PARAMETER ( LINP = 10 ,
30242      &            LOUT = 6 ,
30243      &            LDAT = 9 )
30244
30245       PARAMETER (ZERO   = 0.0D0,
30246      &           ONE    = 1.0D0,
30247      &           TINY35 = 1.0D-35)
30248
30249 * histograms
30250       PARAMETER (NHIS=150, NDIM=250)
30251       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30252      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30253
30254       XLOW = HIST(1,IHIS,IBIN)
30255       XHI  = HIST(1,IHIS,IBIN+1)
30256       IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
30257          XLOW = 10**XLOW
30258          XHI  = 10**XHI
30259       ENDIF
30260       IF (NORM.EQ.2) THEN
30261          DX   = XHI-XLOW
30262          NEVT = INT(DENTRY(1,IHIS))
30263       ELSEIF (NORM.EQ.3) THEN
30264          DX   = ONE
30265          NEVT = INT(HIST(2,IHIS,IBIN))
30266       ELSEIF (NORM.EQ.4) THEN
30267          DX   = XHI**2-XLOW**2
30268          NEVT = KEVT
30269       ELSEIF (NORM.EQ.5) THEN
30270          DX   = LOG(ABS(XHI))-LOG(ABS(XLOW))
30271          NEVT = KEVT
30272       ELSEIF (NORM.EQ.6) THEN
30273          DX   = ONE
30274          NEVT = KEVT
30275       ELSEIF (NORM.EQ.7) THEN
30276          DX   = ONE
30277          NEVT = INT(HIST(7,IHIS,IBIN))
30278       ELSEIF (NORM.EQ.8) THEN
30279          DX   = XHI-XLOW
30280          NEVT = INT(DENTRY(2,IHIS))
30281       ELSE
30282          DX   = ABS(XHI-XLOW)
30283          NEVT = KEVT
30284       ENDIF
30285       IF (ABS(DX).LT.TINY35) DX = ONE
30286       NEVT   = MAX(NEVT,1)
30287       YMEAN  = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
30288       YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
30289       YERR   = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
30290       YSUM   = HIST(5,IHIS,IBIN)
30291       IF (ABS(YSUM).LT.TINY35) YSUM = ONE
30292 C     XMEAN  = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
30293       XMEAN  = HIST(3,IHIS,IBIN)/YSUM
30294       IF (XMEAN.EQ.ZERO) XMEAN = XLOW
30295
30296       RETURN
30297       END
30298
30299 *$ CREATE DT_JOIHIS.FOR
30300 *COPY DT_JOIHIS
30301 *
30302 *===joihis=============================================================*
30303 *
30304       SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
30305
30306 ************************************************************************
30307 *                                                                      *
30308 *     Operation on histograms.                                         *
30309 *                                                                      *
30310 *     input:  IH1,IH2      histogram indices to be joined              *
30311 *             COPER        character defining the requested operation, *
30312 *                          i.e. '+', '-', '*', '/'                     *
30313 *             FAC1,FAC2    factors for joining, i.e.                   *
30314 *                          FAC1*histo1 COPER FAC2*histo2               *
30315 *                                                                      *
30316 * This version dated 23.4.95 is written  by S. Roesler.                *
30317 ************************************************************************
30318
30319       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30320       SAVE
30321       PARAMETER ( LINP = 10 ,
30322      &            LOUT = 6 ,
30323      &            LDAT = 9 )
30324
30325       CHARACTER COPER*1
30326
30327       PARAMETER (ZERO   =  0.0D0,
30328      &           ONE    =  1.0D0,
30329      &           OHALF  =  0.5D0,
30330      &           TINY8  =  1.0D-8,
30331      &           SMALL  =  -1.0D8,
30332      &           RLARGE =  1.0D8 )
30333
30334 * histograms
30335       PARAMETER (NHIS=150, NDIM=250)
30336       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30337      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30338
30339       PARAMETER (NDIM2 = 2*NDIM)
30340       DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
30341
30342       CHARACTER*43 CNORM(0:6)
30343       DATA CNORM /'no further normalization                   ',
30344      &            'per event and bin width                    ',
30345      &            'per entry and bin width                    ',
30346      &            'per bin entry                              ',
30347      &            'per event and "bin width" x1^2...x2^2      ',
30348      &            'per event and "log. bin width" ln x1..ln x2',
30349      &            'per event                                  '/
30350
30351 * check histogram indices
30352       IF ((IH1.LT.    1).OR.(IH2.LT.    1).OR.
30353      &    (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
30354          WRITE(LOUT,1000) IH1,IH2,IHISL
30355  1000    FORMAT(1X,'JOIHIS:   warning!  inconsistent histogram ',
30356      &          'indices (',I3,',',I3,'),',/,21X,'valid range:  1,',I3)
30357          GOTO 9999
30358       ENDIF
30359
30360 * check bin structure of histograms to be joined
30361       IF (IBINS(IH1).NE.IBINS(IH2)) THEN
30362          WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
30363  1001    FORMAT(1X,'JOIHIS:   warning!  joining histograms ',I3,
30364      &          ' and ',I3,' failed',/,21X,
30365      &          'due to different numbers of bins (',I3,',',I3,')')
30366          GOTO 9999
30367       ENDIF
30368       DO 1 K=1,IBINS(IH1)+1
30369          IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
30370             WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
30371  1002       FORMAT(1X,'JOIHIS:   warning!  joining histograms ',I3,
30372      &             ' and ',I3,' failed at bin edge ',I3,/,21X,
30373      &             'X1,X2 = ',2E11.4)
30374             GOTO 9999
30375          ENDIF
30376     1 CONTINUE
30377
30378       WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
30379  1003 FORMAT(1X,'JOIHIS:   joining histograms ',I3,',',I3,' with ',
30380      &       'operation ',A,/,11X,'and factors ',2E11.4)
30381       WRITE(LOUT,1004) CNORM(NORM)
30382  1004 FORMAT(1X,'normalization: ',A,/)
30383
30384       DO 2 K=1,IBINS(IH1)
30385          CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
30386          CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
30387          XLOW  = XLOW1
30388          XHI   = XHI1
30389          XMEAN = OHALF*(XMEAN1+XMEAN2)
30390          IF (COPER.EQ.'+') THEN
30391             YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
30392          ELSEIF (COPER.EQ.'*') THEN
30393             YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
30394          ELSEIF (COPER.EQ.'/') THEN
30395             IF (YMEAN2.EQ.ZERO) THEN
30396                YMEAN = ZERO
30397             ELSE
30398                IF (FAC2.EQ.ZERO) FAC2 = ONE
30399                YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
30400             ENDIF
30401          ELSE
30402             GOTO 9998
30403          ENDIF
30404          WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30405          WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30406  1006    FORMAT(1X,5E11.3)
30407 *    small frame
30408          II = 2*K
30409          XX(II-1) = HIST(1,IH1,K)
30410          XX(II)   = HIST(1,IH1,K+1)
30411          YY(II-1) = YMEAN
30412          YY(II)   = YMEAN
30413 *    wide frame
30414          XX1(K) = XMEAN
30415          IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
30416          YY1(K) = YMEAN
30417     2 CONTINUE
30418
30419 * plot small frame
30420       IF (ABS(MODE).EQ.1) THEN
30421          IBIN2 = 2*IBINS(IH1)
30422          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30423          IF(ILOGY.EQ.1) THEN
30424            CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30425          ELSE
30426            CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30427          ENDIF
30428       ENDIF
30429
30430 * plot wide frame
30431       IF (ABS(MODE).EQ.2) THEN
30432          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30433          NSIZE = NDIM
30434          DXLOW = HIST(1,IH1,1)
30435          DDX   = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
30436          YLOW  = RLARGE
30437          YHI   = SMALL
30438          DO 3 I=1,NDIM
30439             IF (YY1(I).LT.YLOW) THEN
30440                IF (ILOGY.EQ.1) THEN
30441                   IF (YY1(I).GT.ZERO) YLOW = YY1(I)
30442                ELSE
30443                   YLOW = YY1(I)
30444                ENDIF
30445             ENDIF
30446             IF (YY1(I).GT.YHI) YHI = YY1(I)
30447     3    CONTINUE
30448          DY = (YHI-YLOW)/DBLE(NDIM)
30449          IF (DY.LE.ZERO) THEN
30450             WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
30451      &         'JOIHIS:   warning! zero bin width for histograms ',
30452      &         IH1,IH2,': ',YLOW,YHI
30453             RETURN
30454          ENDIF
30455          IF (ILOGY.EQ.1) THEN
30456             YLOW = LOG10(YLOW)
30457             DY   = (LOG10(YHI)-YLOW)/100.0D0
30458             DO 4 I=1,NDIM
30459                IF (YY1(I).LE.ZERO) THEN
30460                   YY1(I) = YLOW
30461                ELSE
30462                   YY1(I) = LOG10(YY1(I))
30463                ENDIF
30464     4       CONTINUE
30465          ENDIF
30466          CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
30467       ENDIF
30468
30469       RETURN
30470
30471  9998 CONTINUE
30472       WRITE(LOUT,1005) COPER
30473  1005 FORMAT(1X,'JOIHIS:   unknown operation ',A)
30474
30475  9999 CONTINUE
30476       RETURN
30477       END
30478
30479 *$ CREATE DT_XGRAPH.FOR
30480 *COPY DT_XGRAPH
30481 *
30482 *===qgraph=============================================================*
30483 *
30484       SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
30485 C***********************************************************************
30486 C
30487 C     calculate quasi graphic picture with 25 lines and 79 columns
30488 C     ranges will be chosen automatically
30489 C
30490 C     input     N          dimension of input fields
30491 C               IARG       number of curves (fields) to plot
30492 C               X          field of X
30493 C               Y1         field of Y1
30494 C               Y2         field of Y2
30495 C
30496 C This subroutine is written by R. Engel.
30497 C***********************************************************************
30498       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30499       SAVE
30500
30501       PARAMETER ( LINP = 10 ,
30502      &            LOUT = 6 ,
30503      &            LDAT = 9 )
30504 C
30505       DIMENSION X(N),Y1(N),Y2(N)
30506       PARAMETER (EPS=1.D-30)
30507       PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30508       CHARACTER SYMB(5)
30509       CHARACTER COL(0:149,0:49)
30510 C
30511       DATA SYMB /'0','e','z','#','x'/
30512 C
30513       ISPALT=IBREIT-10
30514 C
30515 C***  automatic range fitting
30516 C
30517       XMAX=X(1)
30518       XMIN=X(1)
30519       DO 600 I=1,N
30520          XMAX=MAX(X(I),XMAX)
30521          XMIN=MIN(X(I),XMIN)
30522  600  CONTINUE
30523       XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30524 C
30525       ITEST=0
30526       DO 1100 K=0,IZEIL-1
30527          ITEST=ITEST+1
30528          IF (ITEST.EQ.IYRAST) THEN
30529             DO 1010 L=1,ISPALT-1
30530                COL(L,K)='-'
30531 1010        CONTINUE
30532             COL(ISPALT,K)='+'
30533             ITEST=0
30534             DO 1020 L=0,ISPALT-1,IXRAST
30535                COL(L,K)='+'
30536 1020        CONTINUE
30537          ELSE
30538             DO 1030 L=1,ISPALT-1
30539                COL(L,K)=' '
30540 1030        CONTINUE
30541             DO 1040 L=0,ISPALT-1,IXRAST
30542                COL(L,K)='|'
30543 1040        CONTINUE
30544             COL(ISPALT,K)='|'
30545          ENDIF
30546 1100  CONTINUE
30547 C
30548 C***  plot curve Y1
30549 C
30550       YMAX=Y1(1)
30551       YMIN=Y1(1)
30552       DO 500 I=1,N
30553          YMAX=MAX(Y1(I),YMAX)
30554          YMIN=MIN(Y1(I),YMIN)
30555 500   CONTINUE
30556       IF(IARG.GT.1) THEN
30557         DO 550 I=1,N
30558            YMAX=MAX(Y2(I),YMAX)
30559            YMIN=MIN(Y2(I),YMIN)
30560 550     CONTINUE
30561       ENDIF
30562       YMAX=(YMAX-YMIN)/40.0D0+YMAX
30563       YMIN=YMIN-(YMAX-YMIN)/40.0D0
30564       YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
30565       IF(YZOOM.LT.EPS) THEN
30566         WRITE(LOUT,'(1X,A)')
30567      &    'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30568         RETURN
30569       ENDIF
30570 C
30571 C***  plot curve Y1
30572 C
30573       ILAST=-1
30574       LLAST=-1
30575       DO 1200 K=1,N
30576          L=NINT((X(K)-XMIN)/XZOOM)
30577          I=NINT((YMAX-Y1(K))/YZOOM)
30578          IF(ILAST.GE.0) THEN
30579            LD = L-LLAST
30580            ID = I-ILAST
30581            DO 55 II=0,LD,SIGN(1,LD)
30582              DO 66 KK=0,ID,SIGN(1,ID)
30583                COL(II+LLAST,KK+ILAST)=SYMB(1)
30584  66          CONTINUE
30585  55        CONTINUE
30586          ELSE
30587            COL(L,I)=SYMB(1)
30588          ENDIF
30589          ILAST = I
30590          LLAST = L
30591 1200  CONTINUE
30592 C
30593       IF(IARG.GT.1) THEN
30594 C
30595 C***  plot curve Y2
30596 C
30597         DO 1250 K=1,N
30598            L=NINT((X(K)-XMIN)/XZOOM)
30599            I=NINT((YMAX-Y2(K))/YZOOM)
30600            COL(L,I)=SYMB(2)
30601 1250    CONTINUE
30602       ENDIF
30603 C
30604 C***  write it
30605 C
30606       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30607 C
30608 C***  write range of X
30609 C
30610       XZOOM = (XMAX-XMIN)/DBLE(7)
30611       WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30612 C
30613       DO 1300 K=0,IZEIL-1
30614          YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
30615          WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30616  110     FORMAT(1X,1PE9.2,70A1)
30617 1300  CONTINUE
30618 C
30619 C***  write range of X
30620 C
30621       XZOOM = (XMAX-XMIN)/DBLE(7)
30622       WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30623       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30624  120  FORMAT(6X,7(1PE10.3))
30625       END
30626
30627 *$ CREATE DT_XGLOGY.FOR
30628 *COPY DT_XGLOGY
30629 *
30630 *===qglogy=============================================================*
30631 *
30632       SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
30633 C***********************************************************************
30634 C
30635 C     calculate quasi graphic picture with 25 lines and 79 columns
30636 C     logarithmic y axis
30637 C     ranges will be chosen automatically
30638 C
30639 C     input     N          dimension of input fields
30640 C               IARG       number of curves (fields) to plot
30641 C               X          field of X
30642 C               Y1         field of Y1
30643 C               Y2         field of Y2
30644 C
30645 C This subroutine is written by R. Engel.
30646 C***********************************************************************
30647 C
30648       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30649       SAVE
30650
30651       PARAMETER ( LINP = 10 ,
30652      &            LOUT = 6 ,
30653      &            LDAT = 9 )
30654       DIMENSION X(N),Y1(N),Y2(N)
30655       PARAMETER (EPS=1.D-30)
30656       PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30657       CHARACTER SYMB(5)
30658       CHARACTER COL(0:149,0:49)
30659       PARAMETER (DEPS = 1.D-10)
30660 C
30661       DATA SYMB /'0','e','z','#','x'/
30662 C
30663       ISPALT=IBREIT-10
30664 C
30665 C***  automatic range fitting
30666 C
30667       XMAX=X(1)
30668       XMIN=X(1)
30669       DO 600 I=1,N
30670          XMAX=MAX(X(I),XMAX)
30671          XMIN=MIN(X(I),XMIN)
30672  600  CONTINUE
30673       XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30674 C
30675       ITEST=0
30676       DO 1100 K=0,IZEIL-1
30677          ITEST=ITEST+1
30678          IF (ITEST.EQ.IYRAST) THEN
30679             DO 1010 L=1,ISPALT-1
30680                COL(L,K)='-'
30681 1010        CONTINUE
30682             COL(ISPALT,K)='+'
30683             ITEST=0
30684             DO 1020 L=0,ISPALT-1,IXRAST
30685                COL(L,K)='+'
30686 1020        CONTINUE
30687          ELSE
30688             DO 1030 L=1,ISPALT-1
30689                COL(L,K)=' '
30690 1030        CONTINUE
30691             DO 1040 L=0,ISPALT-1,IXRAST
30692                COL(L,K)='|'
30693 1040        CONTINUE
30694             COL(ISPALT,K)='|'
30695          ENDIF
30696 1100  CONTINUE
30697 C
30698 C***  plot curve Y1
30699 C
30700       YMAX=Y1(1)
30701       YMIN=MAX(Y1(1),EPS)
30702       DO 500 I=1,N
30703          YMAX =MAX(Y1(I),YMAX)
30704          IF(Y1(I).GT.EPS) THEN
30705            IF(YMIN.EQ.EPS) THEN
30706              YMIN = Y1(I)/10.D0
30707            ELSE
30708              YMIN = MIN(Y1(I),YMIN)
30709            ENDIF
30710          ENDIF
30711 500   CONTINUE
30712       IF(IARG.GT.1) THEN
30713         DO 550 I=1,N
30714            YMAX=MAX(Y2(I),YMAX)
30715            IF(Y2(I).GT.EPS) THEN
30716              IF(YMIN.EQ.EPS) THEN
30717                YMIN = Y2(I)
30718              ELSE
30719                YMIN = MIN(Y2(I),YMIN)
30720              ENDIF
30721            ENDIF
30722 550     CONTINUE
30723       ENDIF
30724 C
30725       DO 560 I=1,N
30726         Y1(I) = MAX(Y1(I),YMIN)
30727  560  CONTINUE
30728       IF(IARG.GT.1) THEN
30729         DO 570 I=1,N
30730           Y2(I) = MAX(Y2(I),YMIN)
30731  570    CONTINUE
30732       ENDIF
30733 C
30734       IF(YMAX.LE.YMIN) THEN
30735         WRITE(LOUT,'(/1X,A,2E12.3,/)')
30736      &     'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
30737         WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
30738         RETURN
30739       ENDIF
30740 C
30741       YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
30742       YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
30743       YZOOM=(YMA-YMI)/DBLE(IZEIL)
30744       IF(YZOOM.LT.EPS) THEN
30745         WRITE(LOUT,'(1X,A)')
30746      &    'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30747         RETURN
30748       ENDIF
30749 C
30750 C***  plot curve Y1
30751 C
30752       ILAST=-1
30753       LLAST=-1
30754       DO 1200 K=1,N
30755          L=NINT((X(K)-XMIN)/XZOOM)
30756          I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
30757          IF(ILAST.GE.0) THEN
30758            LD = L-LLAST
30759            ID = I-ILAST
30760            DO 55 II=0,LD,SIGN(1,LD)
30761              DO 66 KK=0,ID,SIGN(1,ID)
30762                COL(II+LLAST,KK+ILAST)=SYMB(1)
30763  66          CONTINUE
30764  55        CONTINUE
30765          ELSE
30766            COL(L,I)=SYMB(1)
30767          ENDIF
30768          ILAST = I
30769          LLAST = L
30770 1200  CONTINUE
30771 C
30772       IF(IARG.GT.1) THEN
30773 C
30774 C***  plot curve Y2
30775 C
30776         DO 1250 K=1,N
30777            L=NINT((X(K)-XMIN)/XZOOM)
30778            I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
30779            COL(L,I)=SYMB(2)
30780 1250    CONTINUE
30781       ENDIF
30782 C
30783 C***  write it
30784 C
30785       WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
30786       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30787 C
30788 C***  write range of X
30789 C
30790       XZOOM1 = (XMAX-XMIN)/DBLE(7)
30791       WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30792 C
30793       DO 1300 K=0,IZEIL-1
30794          YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
30795          WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30796  110     FORMAT(1X,1PE9.2,70A1)
30797 1300  CONTINUE
30798 C
30799 C***  write range of X
30800 C
30801       WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30802       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30803  120  FORMAT(6X,7(1PE10.3))
30804 C
30805       END
30806
30807 *$ CREATE DT_SRPLOT.FOR
30808 *COPY DT_SRPLOT
30809 *
30810 *===plot===============================================================*
30811 *
30812       SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
30813
30814       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30815       SAVE
30816
30817       PARAMETER ( LINP = 10 ,
30818      &            LOUT = 6 ,
30819      &            LDAT = 9 )
30820 *
30821 *     initial version
30822 *     J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
30823 *     This is a subroutine of fluka to plot Y across the page
30824 *     as a function of X down the page. Up to 37 curves can be
30825 *     plotted in the same picture with different plotting characters.
30826 *     Output of first 10 overprinted characters addad by FB 88
30827 *  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
30828 *
30829 *     Input Variables:
30830 *        X   = array containing the values of X
30831 *        Y   = array containing the values of Y
30832 *        N   = number of values in X and in Y
30833 *              can exceed the fixed number of lines
30834 *        M   = number of different curves X,Y are containing
30835 *        MM  = number of points in each curve i.e. N=M*MM
30836 *        XO  = smallest value of X to be plotted
30837 *        DX  = increment of X between subsequent lines
30838 *        YO  = smallest value of Y to be plotted
30839 *        DY  = increment of Y between subsequent character spaces
30840 *
30841 *        other variables used inside:
30842 *        XX  = numbers along the X-coordinate axis
30843 *        YY  = numbers along the Y-coordinate axis
30844 *        LL  = ten lines temporary storage for the plot
30845 *        L   = character set used to plot different curves
30846 *        LOV = memorizes overprinted symbols
30847 *              the first 10 overprinted symbols are printed on
30848 *              the end of the line to avoid ambiguities
30849 *              (added by FB as considered quite helpful)
30850 *
30851 *********************************************************************
30852 *
30853       DIMENSION XX(61),YY(61),LL(101,10)
30854       DIMENSION X(N),Y(N),L(40),LOV(40,10)
30855       INTEGER*4 LL, L, LOV
30856       DATA  L/
30857      11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
30858      21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
30859      31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
30860      41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H  /
30861 *
30862 *
30863       MN=51
30864       DO 10 I=1,MN
30865         AI=I-1
30866    10 XX(I)=XO+AI*DX
30867       DO 20 I=1,11
30868         AI=I-1
30869    20 YY(I)=YO+10.0D0*AI*DY
30870       WRITE(LOUT, 500) (YY(I),I=1,11)
30871       MMN=MN-1
30872 *
30873 *
30874       DO 90 JJ=1,MMN,10
30875         JJJ=JJ-1
30876         DO 30 I=1,101
30877           DO 30 J=1,10
30878    30   LL(I,J)=L(40)
30879         DO 40 I=1,101
30880    40   LL(I,1)=L(39)
30881         DO 50 I=1,101,10
30882           DO 50 J=1,10
30883    50   LL(I,J)=L(38)
30884         DO 60 I=1,40
30885           DO 60 J=1,10
30886    60   LOV(I,J)=L(40)
30887 *
30888 *
30889         DO 70 I=1,M
30890           DO 70 J=1,MM
30891             II=J+(I-1)*MM
30892             AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
30893             AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
30894             AIX=AIX-DBLE(JJJ)
30895 *           changed Sept.88 by FB to avoid INTEGER OVERFLOW
30896             IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
30897      +      . AIY .LT. 102.D0) THEN
30898               IX=INT(AIX)
30899               IY=INT(AIY)
30900               IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
30901      +        THEN
30902                 IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
30903      +          =LL(IY,IX)
30904                 LL(IY,IX)=L(I)
30905               ENDIF
30906             ENDIF
30907    70   CONTINUE
30908 *
30909 *
30910         DO 80 I=1,10
30911           II=I+JJJ
30912           III=II+1
30913           WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
30914      &                    (LOV(J,I),J=1,10)
30915    80   CONTINUE
30916    90 CONTINUE
30917 *
30918 *
30919       WRITE(LOUT, 520)
30920       WRITE(LOUT, 500) (YY(I),I=1,11)
30921       RETURN
30922 *
30923   500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
30924   510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
30925   520 FORMAT(20X,10('1---------'),'1')
30926       END
30927
30928 *$ CREATE DT_DEFSET.FOR
30929 *COPY DT_DEFSET
30930 *
30931 *===defset=============================================================*
30932 *
30933       BLOCK DATA DT_DEFSET
30934
30935       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30936       SAVE
30937
30938 * flags for input different options
30939       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
30940       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
30941      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
30942       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
30943 * emulsion treatment
30944       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
30945      &                NCOMPO,IEMUL
30946
30947 * / DTFLG1 /
30948       DATA IFRAG  / 2, 1 /
30949       DATA IRESCO / 1 /
30950       DATA IMSHL  / 1 /
30951       DATA IRESRJ / 0 /
30952       DATA IOULEV / -1, -1, -1, -1, -1, -1 /
30953       DATA LEMCCK / .FALSE. /
30954       DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
30955      &              .TRUE.,.TRUE.,.TRUE./
30956       DATA LSEADI / .TRUE. /
30957       DATA LEVAPO / .TRUE. /
30958       DATA IFRAME / 1 /
30959       DATA ITRSPT / 0 /
30960
30961 * / DTCOMP /
30962       DATA EMUFRA / NCOMPX*0.0D0 /
30963       DATA IEMUMA / NCOMPX*1 /
30964       DATA IEMUCH / NCOMPX*1 /
30965       DATA NCOMPO / 0 /
30966       DATA IEMUL  / 0 /
30967
30968       END
30969
30970 *$ CREATE DT_HADPRP.FOR
30971 *COPY DT_HADPRP
30972 *
30973 *===hadprp=============================================================*
30974 *
30975       BLOCK DATA DT_HADPRP
30976
30977       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30978       SAVE
30979
30980 * auxiliary common for reggeon exchange (DTUNUC 1.x)
30981       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
30982      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
30983      &                IQTCHR(-6:6),MQUARK(3,39)
30984 * hadron index conversion (BAMJET <--> PDG)
30985       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
30986      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
30987      &                IAMCIN(210)
30988 * names of hadrons used in input-cards
30989       CHARACTER*8 BTYPE
30990       COMMON /DTPAIN/ BTYPE(30)
30991
30992 * / DTQUAR /
30993 *----------------------------------------------------------------------*
30994 *                                                                      *
30995 *     Quark content of particles:                                      *
30996 *          index   quark   el. charge  bar. charge  isospin  isospin3  *
30997 *              1 = u          2/3          1/3        1/2       1/2    *
30998 *             -1 = ubar      -2/3         -1/3        1/2      -1/2    *
30999 *              2 = d         -1/3          1/3        1/2      -1/2    *
31000 *             -2 = dbar       1/3         -1/3        1/2       1/2    *
31001 *              3 = s         -1/3          1/3         0         0     *
31002 *             -3 = sbar       1/3         -1/3         0         0     *
31003 *              4 = c          2/3          1/3         0         0     *
31004 *             -4 = cbar      -2/3         -1/3         0         0     *
31005 *              5 = b         -1/3          1/3         0         0     *
31006 *             -5 = bbar       1/3         -1/3         0         0     *
31007 *              6 = t          2/3          1/3         0         0     *
31008 *             -6 = tbar      -2/3         -1/3         0         0     *
31009 *                                                                      *
31010 *         Mquark = particle quark composition (Paprop numbering)       *
31011 *         Iqechr = electric charge ( in 1/3 unit )                     *
31012 *         Iqbchr = baryonic charge ( in 1/3 unit )                     *
31013 *         Iqichr = isospin ( in 1/2 unit ), z component                *
31014 *         Iqschr = strangeness                                         *
31015 *         Iqcchr = charm                                               *
31016 *         Iquchr = beauty                                              *
31017 *         Iqtchr = ......                                              *
31018 *                                                                      *
31019 *----------------------------------------------------------------------*
31020       DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
31021       DATA IQBCHR / 6*-1, 0, 6*1 /
31022       DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
31023       DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
31024       DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
31025       DATA IQUCHR / 0, 1, 9*0, -1, 0 /
31026       DATA IQTCHR / -1, 11*0, 1 /
31027       DATA MQUARK /
31028      &   2, 1, 1,   -2,-1,-1,    0, 0, 0,    0, 0, 0,    0, 0, 0,
31029      &   0, 0, 0,    0, 0, 0,    2, 2, 1,   -2,-2,-1,    0, 0, 0,
31030      &   0, 0, 0,    0, 0, 0,    1,-2, 0,    2,-1, 0,    1,-3, 0,
31031      &   3,-1, 0,    1, 2, 3,   -1,-2,-3,    0, 0, 0,    2, 2, 3,
31032      &   1, 1, 3,    1, 2, 3,    1,-1, 0,    2,-3, 0,    3,-2, 0,
31033      &   2,-2, 0,    3,-3, 0,    0, 0, 0,    0, 0, 0,    0, 0, 0,
31034      &  -1,-1,-3,   -1,-2,-3,   -2,-2,-3,    1, 3, 3,   -1,-3,-3,
31035      &   2, 3, 3,   -2,-3,-3,    3, 3, 3,   -3,-3,-3 /
31036
31037 * / DTHAIC /
31038 * (renamed) (HAdron InDex COnversion)
31039 * translation table version filled up by r.e. 25.01.94                 *
31040       DATA IAMCIN /
31041      &2212,-2212,11,-11,12,              -12,22,2112,-2112,-13,
31042      &13,130,211,-211,321,               -321,3122,-3122,310,3112,
31043      &3222,3212,111,311,-311,            0,0,0,0,0,
31044      &221,213,113,-213,223,              323,313,-323,-313,10323,
31045      &10313,-10323,-10313,30323,30313,   -30323,-30313,3224,3214,3114,
31046      &3216,3218,2224,2214,2114,          1114,12224,12214,12114,11114,
31047      &99999,99999,22212,22112,32124,     31214,-2224,-2214,-2114,-1114,
31048      &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
31049      &5*99999,                           5*99999,
31050      &4*99999,331,                       333,3322,3312,-3222,-3212,
31051      &-3112,-3322,-3312,3224,3214,       3114,3324,3314,3334,-3224,
31052      &-3214,-3114,-3324,-3314,-3334,     421,411,-411,-421,431,
31053      &-431,441,423,413,-413,             -423,433,-433,20443,443,
31054      &-15,15,16,-16,14,                  -14,4122,4232,4132,4222,
31055      &4212,4112,3*99999,                 3*99999,-4122,-4232,
31056      &-4132,-4222,-4212,-4112,99999,     5*99999,
31057      &5*99999,                           5*99999,
31058      &10*99999,
31059      &5*99999 , 20211,20111,-20211,99999,20321,
31060      &-20321,20311,-20311,7*99999 ,
31061      &7*99999,12212,12112,99999/
31062
31063 * / DTHAIC /
31064 * (HAdron InDex COnversion)
31065       DATA (IPDG2(1,K),K=1,7)
31066      &   /   -11,   -12,   -13,   -15,   -16,   -14,     0/
31067       DATA (IBAM2(1,K),K=1,7)
31068      &   /     4,     6,    10,   131,   134,   136,     0/
31069       DATA (IPDG2(2,K),K=1,7)
31070      &   /    11,    12,    22,    13,    15,    16,    14/
31071       DATA (IBAM2(2,K),K=1,7)
31072      &   /     3,     5,     7,    11,   132,   133,   135/
31073       DATA (IPDG3(1,K),K=1,22)
31074      &   /  -211,  -321,  -311,  -213,  -323,  -313,  -411,  -421,
31075      &      -431,  -413,  -423,  -433,     0,     0,     0,     0,
31076      &         0,     0,     0,     0,     0,     0/
31077       DATA (IBAM3(1,K),K=1,22)
31078      &   /    14,    16,    25,    34,    38,    39,   118,   119,
31079      &       121,   125,   126,   128,     0,     0,     0,     0,
31080      &         0,     0,     0,     0,     0,     0/
31081       DATA (IPDG3(2,K),K=1,22)
31082      &   /   130,   211,   321,   310,   111,   311,   221,   213,
31083      &       113,   223,   323,   313,   331,   333,   421,   411,
31084      &       431,   441,   423,   413,   433,   443/
31085       DATA (IBAM3(2,K),K=1,22)
31086      &   /    12,    13,    15,    19,    23,    24,    31,    32,
31087      &        33,    35,    36,    37,    95,    96,   116,   117,
31088      &       120,   122,   123,   124,   127,   130/
31089       DATA (IPDG4(1,K),K=1,29)
31090      &   / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
31091      &     -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
31092      &     -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
31093      &     -4212, -4112,     0,     0,     0/
31094       DATA (IBAM4(1,K),K=1,29)
31095      &   /     2,     9,    18,    67,    68,    69,    70,    75,
31096      &        76,    99,   100,   101,   102,   103,   110,   111,
31097      &       112,   113,   114,   115,   149,   150,   151,   152,
31098      &       153,   154,     0,     0,     0/
31099       DATA (IPDG4(2,K),K=1,29)
31100      &   /  2212,  2112,  3122,  3112,  3222,  3212,  3224,  3214,
31101      &      3114,  3216,  3218,  2224,  2214,  2114,  1114,  3322,
31102      &      3312,  3224,  3214,  3114,  3324,  3314,  3334,  4122,
31103      &      4232,  4132,  4222,  4212,  4112/
31104       DATA (IBAM4(2,K),K=1,29)
31105      &   /     1,     8,    17,    20,    21,    22,    48,    49,
31106      &        50,    51,    52,    53,    54,    55,    56,    97,
31107      &        98,   104,   105,   106,   107,   108,   109,   137,
31108      &       138,   139,   140,   141,   142/
31109       DATA (IPDG5(1,K),K=1,19)
31110      &   /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
31111      &    -20211,-20321,-20311,     0,     0,     0,     0,     0,
31112      &         0,     0,     0/
31113       DATA (IBAM5(1,K),K=1,19)
31114      &   /    42,    43,    46,    47,    71,    72,    73,    74,
31115      &       188,   191,   193,     0,     0,     0,     0,     0,
31116      &         0,     0,     0/
31117       DATA (IPDG5(2,K),K=1,19)
31118      &   / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
31119      &     22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
31120      &     20311, 12212, 12112/
31121       DATA (IBAM5(2,K),K=1,19)
31122      &   /    40,    41,    44,    45,    57,    58,    59,    60,
31123      &        63,    64,    65,    66,   129,   186,   187,   190,
31124      &       192,   208,   209/
31125
31126 * / DTPAIN /
31127 * internal particle names
31128       DATA BTYPE / 'PROTON  ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
31129      &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON  ' , 'NEUTRON ' , 'ANEUTRON' ,
31130      &'MUON+   ' , 'MUON-   ' , 'KAONLONG' , 'PION+   ' , 'PION-   ' ,
31131      &'KAON+   ' , 'KAON-   ' , 'LAMBDA  ' , 'ALAMBDA ' , 'KAONSHRT' ,
31132      &'SIGMA-  ' , 'SIGMA+  ' , 'SIGMAZER' , 'PIZERO  ' , 'KAONZERO' ,
31133      &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
31134      &'BLANK   ' /
31135
31136       END
31137
31138 *$ CREATE DT_BLKD46.FOR
31139 *COPY DT_BLKD46
31140 *
31141 *===blkd46=============================================================*
31142 *
31143       BLOCK DATA DT_BLKD46
31144
31145       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31146       SAVE
31147
31148       PARAMETER ( AMELCT = 0.51099906         D-03 )
31149       PARAMETER ( AMMUON = 0.105658389        D+00 )
31150
31151 * particle properties (BAMJET index convention)
31152       CHARACTER*8  ANAME
31153       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31154      &                IICH(210),IIBAR(210),K1(210),K2(210)
31155
31156 * / DTPART /
31157 * Particle  masses Engel version JETSET compatible
31158 C     DATA (AAM(K),K=1,85) /
31159 C    &   .9383D+00, .9383D+00,  AMELCT  ,  AMELCT  , .0000D+00,
31160 C    &   .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON   ,
31161 C    &   AMMUON   , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
31162 C    &   .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
31163 C    &   .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
31164 C    &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31165 C    &   .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
31166 C    &   .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
31167 C    &   .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
31168 C    &   .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
31169 C    &   .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31170 C    &   .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31171 C    &   .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31172 C    &   .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31173 C    &   .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31174 C    &   .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31175 C    &   .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01  /
31176 C     DATA (AAM(K),K=86,183) /
31177 C    &   .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31178 C    &   .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
31179 C    &   .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
31180 C    &   .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
31181 C    &   .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
31182 C    &   .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
31183 C    &   .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
31184 C    &   .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
31185 C    &   .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
31186 C    &   .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
31187 C    &   .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
31188 C    &   .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
31189 C    &   .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
31190 C    &   .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
31191 C    &   .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31192 C    &   .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31193 C    &   .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31194 C    &   .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31195 C    &   .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31196 C    &   .1250D+01, .1250D+01, .1250D+01  /
31197 C     DATA (AAM ( I ), I = 184,210 ) /
31198 C    & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31199 C    & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31200 C    & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31201 C    & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31202 C    & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31203 C    & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31204 C    & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31205 C    & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31206 C    & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31207 * sr 25.1.06: particle masses adjusted to Pythia
31208       DATA (AAM(K),K=1,85) /
31209      &   .938270E+00,.938270E+00, AMELCT    , AMELCT    ,.000000E+00,
31210      &   .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON    ,
31211      &    AMMUON    ,.497670E+00,.139570E+00,.139570E+00,.493600E+00,
31212      &   .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01,
31213      &   .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00,
31214      &     .0000D+00,  .0000D+00,  .0000D+00 , .0000D+00,  .0000D+00,
31215      &   .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00,
31216      &   .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01,
31217      &   .129000E+01,.129000E+01,.129000E+01,  .1421D+01,  .1421D+01,
31218      &     .1421D+01,  .1421D+01,.138280E+01,.138370E+01,.138720E+01,
31219      &     .1820D+01,  .2030D+01,  .1231D+01,  .1232D+01,  .1233D+01,
31220      &     .1234D+01,  .1675D+01,  .1675D+01,  .1675D+01,  .1675D+01,
31221      &     .1500D+01,  .1500D+01,  .1515D+01,  .1515D+01,  .1775D+01,
31222      &     .1775D+01,  .1231D+01,  .1232D+01,  .1233D+01,  .1234D+01,
31223      &     .1675D+01,  .1675D+01,  .1675D+01,  .1675D+01,  .1515D+01,
31224      &     .1515D+01,  .2500D+01,  .4890D+00,  .4890D+00,  .4890D+00,
31225      &     .1300D+01,  .1300D+01,  .1300D+01,  .1300D+01,  .2200D+01  /
31226       DATA (AAM(K),K=86,183) /
31227      &     .2200D+01,  .2200D+01,  .2200D+01,  .1700D+01,  .1700D+01,
31228      &     .1700D+01,  .1700D+01,  .1820D+01,  .2030D+01,.957770E+00,
31229      &   .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01,
31230      &   .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01,
31231      &   .138720E+01,.153180E+01,  .1535D+01,.167245E+01,.138280E+01,
31232      &   .138370E+01,.138720E+01,.153180E+01,  .1535D+01,.167245E+01,
31233      &   .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01,
31234      &   .196850E+01,.297980E+01,.200670E+01,  .2010D+01,  .2010D+01,
31235      &   .200670E+01,.211240E+01,.211240E+01,  .3686D+01,.309688E+01,
31236      &   .177700E+01,.177700E+01,  .0000D+00,  .0000D+00,  .0000D+00,
31237      &     .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01,
31238      &   .245350E+01,.245210E+01,  .2560D+01,  .2560D+01,  .2730D+01,
31239      &     .3610D+01,  .3610D+01,  .3790D+01,.228490E+01,.246560E+01,
31240      &     .2460D+01,.245290E+01,.245350E+01,.245210E+01,  .2560D+01,
31241      &     .2560D+01,  .2730D+01,  .3610D+01,  .3610D+01,  .3790D+01,
31242      &     .2490D+01,  .2490D+01,  .2490D+01,  .2610D+01,  .2610D+01,
31243      &     .2770D+01,  .3670D+01,  .3670D+01,  .3850D+01,  .4890D+01,
31244      &     .2490D+01,  .2490D+01,  .2490D+01,  .2610D+01,  .2610D+01,
31245      &     .2770D+01,  .3670D+01,  .3670D+01,  .3850D+01,  .4890D+01,
31246      &     .1250D+01,  .1250D+01,  .1250D+01  /
31247       DATA (AAM ( I ), I = 184,210 ) /
31248      & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31249      & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31250      & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31251      & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31252      & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31253      & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31254      & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31255      & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31256      & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31257 * Particle  mean lives
31258       DATA (TAU(K),K=1,183) /
31259      &   .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
31260      &   .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
31261      &   .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
31262      &   .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
31263      &   .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
31264      &   70*.0000D+00,
31265      &   .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
31266      &   .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
31267      &   .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
31268      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
31269      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31270      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31271      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31272      &   .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
31273      &   .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31274      &   40*.0000D+00,
31275      &   .0000D+00, .0000D+00, .0000D+00  /
31276       DATA ( TAU ( I ), I = 184,210 ) /
31277      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31278      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31279      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31280      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31281      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31282      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31283      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31284      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31285      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/
31286 * Resonance width Gamma in GeV
31287       DATA (GA(K),K=  1,85) /
31288      &    30*.0000D+00,
31289      &   .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
31290      &   .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
31291      &   .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
31292      &   .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
31293      &   .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
31294      &   .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
31295      &   .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
31296      &   .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
31297      &   .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
31298      &   .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
31299      &   .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00  /
31300       DATA (GA(K),K= 86,183) /
31301      &   .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
31302      &   .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
31303      &   .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31304      &   .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
31305      &   .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
31306      &   .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
31307      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31308      &   .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
31309      &   .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
31310      &   50*.0000D+00,
31311      &   .3000D+00, .3000D+00, .3000D+00  /
31312       DATA ( GA ( I ), I = 184,210 ) /
31313      & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
31314      & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
31315      & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
31316      & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
31317      & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31318      & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31319      & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
31320      & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
31321      & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
31322 * Particle  names
31323 * S+1385+Sigma+(1385)    L02030+Lambda0(2030)
31324 * Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
31325 * designation N*@@ means N*@1(@2)
31326       DATA (ANAME(K),K=1,85) /
31327      &  'P       ','AP      ','E-      ','E+      ','NUE     ',
31328      &  'ANUE    ','GAM     ','NEU     ','ANEU    ','MUE+    ',
31329      &  'MUE-    ','K0L     ','PI+     ','PI-     ','K+      ',
31330      &  'K-      ','LAM     ','ALAM    ','K0S     ','SIGM-   ',
31331      &  'SIGM+   ','SIGM0   ','PI0     ','K0      ','AK0     ',
31332      &  'BLANK   ','BLANK   ','BLANK   ','BLANK   ','BLANK   ',
31333      &  'ETA550  ','RHO+77  ','RHO077  ','RHO-77  ','OM0783  ',
31334      &  'K*+892  ','K*0892  ','K*-892  ','AK*089  ','KA+125  ',
31335      &  'KA0125  ','KA-125  ','AKA012  ','K*+142  ','K*0142  ',
31336      &  'K*-142  ','AK*014  ','S+1385  ','S01385  ','S-1385  ',
31337      &  'L01820  ','L02030  ','N*++12  ','N*+ 12  ','N*012   ',
31338      &  'N*-12   ','N*++16  ','N*+16   ','N*016   ','N*-16   ',
31339      &  'N*+14   ','N*014   ','N*+15   ','N*015   ','N*+18   ',
31340      &  'N*018   ','AN--12  ','AN*-12  ','AN*012  ','AN*+12  ',
31341      &  'AN--16  ','AN*-16  ','AN*016  ','AN*+16  ','AN*-15  ',
31342      &  'AN*015  ','DE*=24  ','RPI+49  ','RPI049  ','RPI-49  ',
31343      &  'PIN++   ','PIN+0   ','PIN+-   ','PIN-0   ','PPPI    ' /
31344       DATA (ANAME(K),K=86,183) /
31345      &  'PNPI    ','APPPI   ','APNPI   ','K+PPI   ','K-PPI   ',
31346      &  'K+NPI   ','K-NPI   ','S+1820  ','S-2030  ','ETA*    ',
31347      &  'PHI     ','TETA0   ','TETA-   ','ASIG-   ','ASIG0   ',
31348      &  'ASIG+   ','ATETA0  ','ATETA+  ','SIG*+   ','SIG*0   ',
31349      &  'SIG*-   ','TETA*0  ','TETA*   ','OMEGA-  ','ASIG*-  ',
31350      &  'ASIG*0  ','ASIG*+  ','ATET*0  ','ATET*+  ','OMEGA+  ',
31351      &  'D0      ','D+      ','D-      ','AD0     ','F+      ',
31352      &  'F-      ','ETAC    ','D*0     ','D*+     ','D*-     ',
31353      &  'AD*0    ','F*+     ','F*-     ','PSI     ','JPSI    ',
31354      &  'TAU+    ','TAU-    ','NUET    ','ANUET   ','NUEM    ',
31355      &  'ANUEM   ','C0+     ','A+      ','A0      ','C1++    ',
31356      &  'C1+     ','C10     ','S+      ','S0      ','T0      ',
31357      &  'XU++    ','XD+     ','XS+     ','AC0-    ','AA-     ',
31358      &  'AA0     ','AC1--   ','AC1-    ','AC10    ','AS-     ',
31359      &  'AS0     ','AT0     ','AXU--   ','AXD-    ','AXS     ',
31360      &  'C1*++   ','C1*+    ','C1*0    ','S*+     ','S*0     ',
31361      &  'T*0     ','XU*++   ','XD*+    ','XS*+    ','TETA++  ',
31362      &  'AC1*--  ','AC1*-   ','AC1*0   ','AS*-    ','AS*0    ',
31363      &  'AT*0    ','AXU*--  ','AXD*-   ','AXS*-   ','ATET--  ',
31364      &  'RO      ','R+      ','R-      '  /
31365       DATA (    ANAME ( I ), I = 184,210 ) /
31366      &'AN*-14  ','AN*014  ','PI+130  ','PI0130  ','PI-130  ','F01400  ',
31367      &'K*+146  ','K*-146  ','K*0146  ','AK0146  ','L01600  ','AL0160  ',
31368      &'S+1660  ','S01660  ','S-1660  ','AS-166  ','AS0166  ','AS+166  ',
31369      &'X01950  ','X-1950  ','AX0195  ','AX+195  ','OM-225  ','AOM+22  ',
31370      &'N*+14   ','N*014   ','BLANK   '/
31371 * Charge of particles and resonances
31372       DATA (IICH ( I ), I =   1,210 ) /
31373      &  1, -1, -1,  1,  0,  0,  0,  0,  0,  1, -1,  0,  1, -1,  1,
31374      & -1,  0,  0,  0, -1,  1,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31375      &  0,  1,  0, -1,  0,  1,  0, -1,  0,  1,  0, -1,  0,  1,  0,
31376      & -1,  0,  1,  0, -1,  0,  0,  2,  1,  0, -1,  2,  1,  0, -1,
31377      &  1,  0,  1,  0,  1,  0, -2, -1,  0,  1, -2, -1,  0,  1, -1,
31378      &  0,  1,  1,  0, -1,  2,  1,  0, -1,  2,  1,  0, -1,  2,  0,
31379      &  1, -1,  1, -1,  0,  0,  0, -1, -1,  0,  1,  0,  1,  1,  0,
31380      & -1,  0, -1, -1, -1,  0,  1,  0,  1,  1,  0,  1, -1,  0,  1,
31381      & -1,  0,  0,  1, -1,  0,  1, -1,  0,  0,  1, -1,  0,  0,  0,
31382      &  0,  1,  1,  0,  2,  1,  0,  1,  0,  0,  2,  1,  1, -1, -1,
31383      &  0, -2, -1,  0, -1,  0,  0, -2, -1, -1,  2,  1,  0,  1,  0,
31384      &  0,  2,  1,  1,  2, -2, -1,  0, -1,  0,  0, -2, -1, -1, -2,
31385      &  0,  1, -1, -1,  0,  1,  0, -1,  0,  1, -1,  0,  0,  0,  0,
31386      &  1,  0, -1, -1,  0,  1,  0, -1,  0,  1, -1,  1,  1,  0,  0/
31387 * Particle  baryonic charges
31388       DATA (IIBAR ( I ), I =   1,210 ) /
31389      &  1, -1,  0,  0,  0,  0,  0,  1, -1,  0,  0,  0,  0,  0,  0,
31390      &  0,  1, -1,  0,  1,  1,  1,  0,  0,  0,  0,  0,  0,  0,  0,
31391      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31392      &  0,  0,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,
31393      &  1,  1,  1,  1,  1,  1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31394      & -1,  2,  0,  0,  0,  1,  1,  1,  1,  2,  2,  0,  0,  1,  1,
31395      &  1,  1,  1,  1,  0,  0,  1,  1, -1, -1, -1, -1, -1,  1,  1,
31396      &  1,  1,  1,  1, -1, -1, -1, -1, -1, -1,  0,  0,  0,  0,  0,
31397      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31398      &  0,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1, -1, -1,
31399      & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,  1,  1,  1,  1,  1,
31400      &  1,  1,  1,  1,  1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31401      &  0,  0,  0, -1, -1,  0,  0,  0,  0,  0,  0,  0,  0,  1, -1,
31402      &  1,  1,  1, -1, -1, -1,  1,  1, -1, -1,  1, -1,  1,  1,  0/
31403 * First number of decay channels used for resonances
31404 * and decaying particles
31405       DATA K1/   1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 16, 17,
31406      &  18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
31407      &   2*330, 46, 51, 52, 54, 55, 58,
31408 *                                                             50
31409      &  60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
31410      & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
31411      & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
31412 *                                         85
31413      & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
31414      & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
31415      & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
31416      & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
31417      & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
31418      & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
31419      & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
31420      & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
31421      & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
31422      & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
31423      & 590, 596, 602 /
31424 * Last number of decay channels used for resonances
31425 * and decaying particles
31426       DATA K2/   1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 15, 16, 17,
31427      & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
31428      & 2* 330, 50, 51, 53, 54, 57,
31429 *                                                                 50
31430      & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
31431      & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
31432      & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
31433 *                                              85
31434      & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
31435      & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
31436      & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
31437      & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
31438      & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
31439      & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
31440      & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
31441      & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
31442      & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
31443      & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
31444      & 589, 595, 601, 602 /
31445
31446        END
31447
31448 *$ CREATE DT_BLKD47.FOR
31449 *COPY DT_BLKD47
31450 *
31451 *===blkd47=============================================================*
31452 *
31453       BLOCK DATA DT_BLKD47
31454
31455       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31456       SAVE
31457
31458 * HADRIN: decay channel information
31459       PARAMETER (IDMAX9=602)
31460       CHARACTER*8 ZKNAME
31461       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
31462
31463 * Name of decay channel
31464 * Designation N*@ means N*@1(1236)
31465 * @1=# means ++,  @1 = = means --
31466 * Designation  P+/0/- means Pi+/Pi0/Pi- , respectively
31467       DATA (ZKNAME(K),K=  1, 85) /
31468      &  'P       ','AP      ','E-      ','E+      ','NUE     ',
31469      &  'ANUE    ','GAM     ','PE-NUE  ','APEANU  ','EANUNU  ',
31470      &  'E-NUAN  ','3PI0    ','PI+-0   ','PIMUNU  ','PIE-NU  ',
31471      &  'MU+NUE  ','MU-NUE  ','MU+NUE  ','PI+PI0  ','PI++-   ',
31472      &  'PI+00   ','M+P0NU  ','E+P0NU  ','MU-NU   ','PI-0    ',
31473      &  'PI+--   ','PI-00   ','M-P0NU  ','E-P0NU  ','PPI-    ',
31474      &  'NPI0    ','PD-NUE  ','PM-NUE  ','APPI+   ','ANPI0   ',
31475      &  'APE+NU  ','APM+NU  ','PI+PI-  ','PI0PI0  ','NPI-    ',
31476      &  'PPI0    ','NPI+    ','LAGA    ','GAGA    ','GAE+E-  ',
31477      &  'GAGA    ','GAGAP0  ','PI000   ','PI+-0   ','PI+-GA  ',
31478      &  'PI+0    ','PI+-    ','PI00    ','PI-0    ','PI+-0   ',
31479      &  'PI+-    ','PI0GA   ','K+PI0   ','K0PI+   ','KOPI0   ',
31480      &  'K+PI-   ','K-PI0   ','AK0PI-  ','AK0PI0  ','K-PI+   ',
31481      &  'K+PI0   ','K0PI+   ','K0PI0   ','K+PI-   ','K-PI0   ',
31482      &  'K0PI-   ','AK0PI0  ','K-PI+   ','K+PI0   ','K0PI+   ',
31483      &  'K+89P0  ','K08PI+  ','K+RO77  ','K0RO+7  ','K+OM07  ',
31484      &  'K+E055  ','K0PI0   ','K+PI+   ','K089P0  ','K+8PI-  '  /
31485       DATA (ZKNAME(K),K= 86,170) /
31486      &  'K0R077  ','K+R-77  ','K+R-77  ','K0OM07  ','K0E055  ',
31487      &  'K-PI0   ','K0PI-   ','K-89P0  ','AK08P-  ','K-R077  ',
31488      &  'AK0R-7  ','K-OM07  ','K-E055  ','AK0PI0  ','K-PI+   ',
31489      &  'AK08P0  ','K-8PI+  ','AK0R07  ','AK0OM7  ','AK0E05  ',
31490      &  'LA0PI+  ','SI0PI+  ','SI+PI0  ','LA0PI0  ','SI+PI-  ',
31491      &  'SI-PI+  ','LA0PI-  ','SI0PI-  ','NEUAK0  ','PK-     ',
31492      &  'SI+PI-  ','SI0PI0  ','SI-PI+  ','LA0ET0  ','S+1PI-  ',
31493      &  'S-1PI+  ','SO1PI0  ','NEUAK0  ','PK-     ','LA0PI0  ',
31494      &  'LA0OM0  ','LA0RO0  ','SI+RO-  ','SI-RO+  ','SI0RO0  ',
31495      &  'LA0ET0  ','SI0ET0  ','SI+PI-  ','SI-PI+  ','SI0PI0  ',
31496      &  'K0S     ','K0L     ','K0S     ','K0L     ','P PI+   ',
31497      &  'P PI0   ','N PI+   ','P PI-   ','N PI0   ','N PI-   ',
31498      &  'P PI+   ','N*#PI0  ','N*+PI+  ','PRHO+   ','P PI0   ',
31499      &  'N PI+   ','N*#PI-  ','N*+PI0  ','N*0PI+  ','PRHO0   ',
31500      &  'NRHO+   ','P PI-   ','N PI0   ','N*+PI-  ','N*0PI0  ',
31501      &  'N*-PI+  ','PRHO-   ','NRHO0   ','N PI-   ','N*0PI-  ',
31502      &  'N*-PI0  ','NRHO-   ','PETA0   ','N*#PI-  ','N*+PI0  '  /
31503       DATA (ZKNAME(K),K=171,255) /
31504      &  'N*0PI+  ','PRHO0   ','NRHO+   ','NETA0   ','N*+PI-  ',
31505      &  'N*0PI0  ','N*-PI+  ','PRHO-   ','NRHO0   ','P PI0   ',
31506      &  'N PI+   ','N*#PI-  ','N*+PI0  ','N*0PI+  ','PRHO0   ',
31507      &  'NRHO+   ','P PI-   ','N PI0   ','N*+PI-  ','N*0PI0  ',
31508      &  'N*-PI+  ','PRHO-   ','NRHO0   ','P PI0   ','N PI+   ',
31509      &  'PRHO0   ','NRHO+   ','LAMK+   ','S+ K0   ','S0 K+   ',
31510      &  'PETA0   ','P PI-   ','N PI0   ','PRHO-   ','NRHO0   ',
31511      &  'LAMK0   ','S0 K0   ','S- K+   ','NETA/   ','APPI-   ',
31512      &  'APPI0   ','ANPI-   ','APPI+   ','ANPI0   ','ANPI+   ',
31513      &  'APPI-   ','AN*=P0  ','AN*-P-  ','APRHO-  ','APPI0   ',
31514      &  'ANPI-   ','AN*=P+  ','AN*-P0  ','AN*0P-  ','APRHO0  ',
31515      &  'ANRHO-  ','APPI+   ','ANPI0   ','AN*-P+  ','AN*0P0  ',
31516      &  'AN*+P-  ','APRHO+  ','ANRHO0  ','ANPI+   ','AN*0P+  ',
31517      &  'AN*+P0  ','ANRHO+  ','APPI0   ','ANPI-   ','AN*=P+  ',
31518      &  'AN*-P0  ','AN*0P-  ','APRHO0  ','ANRHO-  ','APPI+,  ',
31519      &  'ANPI0   ','AN*-P+  ','AN*0P0  ','AN*+P-  ','APRHO+  ',
31520      &  'ANRHO0  ','PN*014  ','NN*=14  ','PI+0    ','PI+-    '  /
31521       DATA (ZKNAME(K),K=256,340) /
31522      &  'PI-0    ','P+0     ','N++     ','P+-     ','P00     ',
31523      &  'N+0     ','N+-     ','N00     ','P-0     ','N-0     ',
31524      &  'P--     ','PPPI0   ','PNPI+   ','PNPI0   ','PPPI-   ',
31525      &  'NNPI+   ','APPPI0  ','APNPI+  ','ANNPI0  ','ANPPI-  ',
31526      &  'APNPI0  ','APPPI-  ','ANNPI-  ','K+PPI0  ','K+NPI+  ',
31527      &  'K0PPI0  ','K-PPI0  ','K-NPI+  ','AKPPI-  ','AKNPI0  ',
31528      &  'K+NPI0  ','K+PPI-  ','K0PPI0  ','K0NPI+  ','K-NPI0  ',
31529      &  'K-PPI-  ','AKNPI-  ','PAK0    ','SI+PI0  ','SI0PI+  ',
31530      &  'SI+ETA  ','S+1PI0  ','S01PI+  ','NEUK-   ','LA0PI-  ',
31531      &  'SI-OM0  ','LA0RO-  ','SI0RO-  ','SI-RO0  ','SI-ET0  ',
31532      &  'SI0PI-  ','SI-0    ','BLANC   ','BLANC   ','BLANC   ',
31533      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31534      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31535      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31536      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31537      &  'EPI+-   ','EPI00   ','GAPI+-  ','GAGA*   ','K+-     ',
31538      &  'KLKS    ','PI+-0   ','EGA     ','LPI0    ','LPI     '  /
31539       DATA (ZKNAME(K),K=341,425) /
31540      &  'APPI0   ','ANPI-   ','ALAGA   ','ANPI    ','ALPI0   ',
31541      &  'ALPI+   ','LAPI+   ','SI+PI0  ','SI0PI+  ','LAPI0   ',
31542      &  'SI+PI-  ','SI-PI+  ','LAPI-   ','SI-PI0  ','SI0PI-  ',
31543      &  'TE0PI0  ','TE-PI+  ','TE0PI-  ','TE-PI0  ','TE0PI   ',
31544      &  'TE-PI   ','LAK-    ','ALPI-   ','AS-PI0  ','AS0PI-  ',
31545      &  'ALPI0   ','AS+PI-  ','AS-PI+  ','ALPI+   ','AS+PI0  ',
31546      &  'AS0PI+  ','AT0PI0  ','AT+PI-  ','AT0PI+  ','AT+PI0  ',
31547      &  'AT0PI   ','AT+PI   ','ALK+    ','K-PI+   ','K-PI+0  ',
31548      &  'K0PI+-  ','K0PI0   ','K-PI++  ','AK0PI+  ','K+PI--  ',
31549      &  'K0PI-   ','K+PI-   ','K+PI-0  ','AKPI-+  ','AK0PI0  ',
31550      &  'ETAPIF  ','K++-    ','K+AK0   ','ETAPI-  ','K--+    ',
31551      &  'K-K0    ','PI00    ','PI+-    ','GAGA    ','D0PI0   ',
31552      &  'D0GA    ','D0PI+   ','D+PI0   ','DFGA    ','AD0PI-  ',
31553      &  'D-PI0   ','D-GA    ','AD0PI0  ','AD0GA   ','F+GA    ',
31554      &  'F+GA    ','F-GA    ','F-GA    ','PSPI+-  ','PSPI00  ',
31555      &  'PSETA   ','E+E-    ','MUE+-   ','PI+-0   ','M+NN    ',
31556      &  'E+NN    ','RHO+NT  ','PI+ANT  ','K*+ANT  ','M-NN    '  /
31557       DATA (ZKNAME(K),K=426,510) /
31558      &  'E-NN    ','RHO-NT  ','PI-NT   ','K*-NT   ','NUET    ',
31559      &  'ANUET   ','NUEM    ','ANUEM   ','SI+ETA  ','SI+ET*  ',
31560      &  'PAK0    ','TET0K+  ','SI*+ET  ','N*+AK0  ','N*++K-  ',
31561      &  'LAMRO+  ','SI0RO+  ','SI+RO0  ','SI+OME  ','PAK*0   ',
31562      &  'N*+AK*  ','N*++K*  ','SI+AK0  ','TET0PI  ','SI+AK*  ',
31563      &  'TET0RO  ','SI0AK*  ','SI+K*-  ','TET0OM  ','TET-RO  ',
31564      &  'SI*0AK  ','C0+PI+  ','C0+PI0  ','C0+PI-  ','A+GAM   ',
31565      &  'A0GAM   ','TET0AK  ','TET0K*  ','OM-RO+  ','OM-PI+  ',
31566      &  'C1++AK  ','A+PI+   ','C0+AK0  ','A0PI+   ','A+AK0   ',
31567      &  'T0PI+   ','ASI-ET  ','ASI-E*  ','APK0    ','ATET0K  ',
31568      &  'ASI*-E  ','AN*-K0  ','AN*--K  ','ALAMRO  ','ASI0RO  ',
31569      &  'ASI-RO  ','ASI-OM  ','APK*0   ','AN*-K*  ','AN*--K  ',
31570      &  'ASI-K0  ','ATETPI  ','ASI-K*  ','ATETRO  ','ASI0K*  ',
31571      &  'ASI-K*  ','ATE0OM  ','ATE+RO  ','ASI*0K  ','AC-PI-  ',
31572      &  'AC-PI0  ','AC-PI+  ','AA-GAM  ','AA0GAM  ','ATET0K  ',
31573      &  'ATE0K*  ','AOM+RO  ','AOM+PI  ','AC1--K  ','AA-PI-  ',
31574      &  'AC0-K0  ','AA0PI-  ','AA-K0   ','AT0PI-  ','C1++GA  '  /
31575       DATA (ZKNAME(K),K=511,540) /
31576      &  'C1++GA  ','C10GAM  ','S+GAM   ','S0GAM   ','T0GAM   ',
31577      &  'XU++GA  ','XD+GAM  ','XS+GAM  ','A+AKPI  ','T02PI+  ',
31578      &  'C1++2K  ','AC1--G  ','AC1-GA  ','AC10GA  ','AS-GAM  ',
31579      &  'AS0GAM  ','AT0GAM  ','AXU--G  ','AXD-GA  ','AXS-GA  ',
31580      &  'AA-KPI  ','AT02PI  ','AC1--K  ','RH-PI+  ','RH+PI-  ',
31581      &  'RH3PI0  ','RH0PI+  ','RH+PI0  ','RH0PI-  ','RH-PI0  '  /
31582       DATA (ZKNAME(I),I=541,602)/
31583      & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
31584      & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
31585      & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
31586      & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
31587      & 'PI+PI-','K+K-  ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
31588      & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
31589      & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
31590      & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
31591      & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
31592 * Weight of decay channel
31593       DATA (WT(K),K=  1, 85) /
31594      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31595      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31596      &   .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
31597      &   .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
31598      &   .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
31599      &   .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
31600      &   .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
31601      &   .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
31602      &   .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
31603      &   .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
31604      &   .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
31605      &   .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
31606      &   .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
31607      &   .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
31608      &   .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
31609      &   .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
31610      &   .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00  /
31611       DATA (WT(K),K= 86,170) /
31612      &   .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
31613      &   .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
31614      &   .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
31615      &   .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
31616      &   .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
31617      &   .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
31618      &   .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
31619      &   .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
31620      &   .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
31621      &   .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
31622      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
31623      &   .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31624      &   .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31625      &   .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31626      &   .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31627      &   .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31628      &   .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00  /
31629       DATA (WT(K),K=171,255) /
31630      &   .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
31631      &   .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
31632      &   .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
31633      &   .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
31634      &   .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
31635      &   .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
31636      &   .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
31637      &   .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
31638      &   .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31639      &   .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31640      &   .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31641      &   .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31642      &   .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31643      &   .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
31644      &   .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
31645      &   .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
31646      &   .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01  /
31647       DATA (WT(K),K=256,340) /
31648      &   .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
31649      &   .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
31650      &   .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
31651      &   .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
31652      &   .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
31653      &   .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
31654      &   .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
31655      &   .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
31656      &   .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
31657      &   .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
31658      &   .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01,
31659      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31660      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31661      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31662      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31663      &   .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
31664      &   .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01  /
31665       DATA (WT(K),K=341,425) /
31666      &   .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
31667      &   .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
31668      &   .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
31669      &   .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
31670      &   .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
31671      &   .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
31672      &   .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
31673      &   .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
31674      &   .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
31675      &   .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
31676      &   .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
31677      &   .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
31678      &   .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
31679      &   .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
31680      &   .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
31681      &   .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
31682      &   .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00  /
31683       DATA (WT(K),K=426,510) /
31684      &   .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
31685      &   .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
31686      &   .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
31687      &   .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
31688      &   .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
31689      &   .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
31690      &   .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31691      &   .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
31692      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
31693      &   .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
31694      &   .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
31695      &   .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
31696      &   .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
31697      &   .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
31698      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
31699      &   .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
31700      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01  /
31701       DATA (WT(K),K=511,540) /
31702      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31703      &   .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
31704      &   .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31705      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31706      &   .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
31707      &   .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00  /
31708 C
31709       DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
31710      & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
31711      & .125D+00,  0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
31712      & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
31713      & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
31714      & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
31715      & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
31716 * Particle numbers in decay channel
31717       DATA (NZK(K,1),K=  1,170) /
31718      &     1,   2,   3,   4,   5,   6,   7,   1,   2,   4,
31719      &     3,  23,  13,  13,  13,  10,  11,  10,  13,  13,
31720      &    13,  10,   4,  11,  14,  14,  14,  11,   3,   1,
31721      &     8,   1,   1,   2,   9,   2,   2,  13,  23,   8,
31722      &     1,   8,  17,   7,   7,   7,  23,  23,  13,  13,
31723      &    13,  13,  23,  14,  13,  13,  23,  15,  24,  24,
31724      &    15,  16,  25,  25,  16,  15,  24,  24,  15,  16,
31725      &    24,  25,  16,  15,  24,  36,  37,  15,  24,  15,
31726      &    15,  24,  15,  37,  36,  24,  15,  24,  24,  16,
31727      &    24,  38,  39,  16,  25,  16,  16,  25,  16,  39,
31728      &    38,  25,  16,  25,  25,  17,  22,  21,  17,  21,
31729      &    20,  17,  22,   8,   1,  21,  22,  20,  17,  48,
31730      &    50,  49,   8,   1,  17,  17,  17,  21,  20,  22,
31731      &    17,  22,  21,  20,  22,  19,  12,  19,  12,   1,
31732      &     1,   8,   1,   8,   8,   1,  53,  54,   1,   1,
31733      &     8,  53,  54,  55,   1,   8,   1,   8,  54,  55,
31734      &    56,   1,   8,   8,  55,  56,   8,   1,  53,  54  /
31735       DATA (NZK(K,1),K=171,340) /
31736      &    55,   1,   8,   8,  54,  55,  56,   1,   8,   1,
31737      &     8,  53,  54,  55,   1,   8,   1,   8,  54,  55,
31738      &    56,   1,   8,   1,   8,   1,   8,  17,  21,  22,
31739      &     1,   1,   8,   1,   8,  17,  22,  20,   8,   2,
31740      &     2,   9,   2,   9,   9,   2,  67,  68,   2,   2,
31741      &     9,  67,  68,  69,   2,   9,   2,   9,  68,  69,
31742      &    70,   2,   9,   9,  69,  70,   9,   2,   9,  67,
31743      &    68,  69,   2,   9,   2,   9,  68,  69,  70,   2,
31744      &     9,   1,   8,  13,  13,  14,   1,   8,   1,   1,
31745      &     8,   8,   8,   1,   8,   1,   1,   1,   1,   1,
31746      &     8,   2,   2,   9,   9,   2,   2,   9,  15,  15,
31747      &    24,  16,  16,  25,  25,  15,  15,  24,  24,  16,
31748      &    16,  25,   1,  21,  22,  21,  48,  49,   8,  17,
31749      &    20,  17,  22,  20,  20,  22,  20,   0,   0,   0,
31750      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31751      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31752      &    31,  31,  13,   7,  15,  12,  13,  31,  17,  17  /
31753       DATA (NZK(K,1),K=341,510) /
31754      &     2,   9,  18,   9,  18,  18,  17,  21,  22,  17,
31755      &    21,  20,  17,  20,  22,  97,  98,  97,  98,  97,
31756      &    98,  17,  18,  99, 100,  18, 101,  99,  18, 101,
31757      &   100, 102, 103, 102, 103, 102, 103,  18,  16,  16,
31758      &    24,  24,  16,  25,  15,  24,  15,  15,  25,  25,
31759      &    31,  15,  15,  31,  16,  16,  23,  13,   7, 116,
31760      &   116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
31761      &   120, 121, 121, 130, 130, 130,   4,  10,  13,  10,
31762      &     4,  32,  13,  36,  11,   3,  34,  14,  38, 133,
31763      &   134, 135, 136,  21,  21,   1,  97, 104,  54,  53,
31764      &    17,  22,  21,  21,   1,  54,  53,  21,  97,  21,
31765      &    97,  22,  21,  97,  98, 105, 137, 137, 137, 138,
31766      &   139,  97,  97, 109, 109, 140, 138, 137, 139, 138,
31767      &   145,  99,  99,   2, 102, 110,  68,  67,  18, 100,
31768      &    99,  99,   2,  68,  67,  99, 102,  99, 102, 100,
31769      &    99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
31770      &   113, 115, 115, 152, 150, 149, 151, 150, 157, 140  /
31771       DATA (NZK(K,1),K=511,540) /
31772      &   141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
31773      &   140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
31774      &   150, 157, 152,  34,  32,  33,  33,  32,  33,  34  /
31775       DATA (NZK(I,1),I=541,602) /  2, 67, 68, 69,  2,  9,  9, 68, 69,
31776      & 70,  2,  9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
31777      & 14, 189, 23, 13, 15, 24,  36,  38,  37,  39, 194, 195, 196, 197,
31778      & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
31779      & 55, 8, 1, 8, 8, 54, 55, 210/
31780       DATA (NZK(K,2),K=  1,170) /
31781      &     0,   0,   0,   0,   0,   0,   0,   3,   4,   6,
31782      &     5,  23,  14,  11,   3,   5,   5,   5,  23,  13,
31783      &    23,  23,  23,   5,  23,  13,  23,  23,  23,  14,
31784      &    23,   3,  11,  13,  23,   4,  10,  14,  23,  14,
31785      &    23,  13,   7,   7,   4,   7,   7,  23,  14,  14,
31786      &    23,  14,  23,  23,  14,  14,   7,  23,  13,  23,
31787      &    14,  23,  14,  23,  13,  23,  13,  23,  14,  23,
31788      &    14,  23,  13,  23,  13,  23,  13,  33,  32,  35,
31789      &    31,  23,  14,  23,  14,  33,  34,  35,  31,  23,
31790      &    14,  23,  14,  33,  34,  35,  31,  23,  13,  23,
31791      &    13,  33,  32,  35,  31,  13,  13,  23,  23,  14,
31792      &    13,  14,  14,  25,  16,  14,  23,  13,  31,  14,
31793      &    13,  23,  25,  16,  23,  35,  33,  34,  32,  33,
31794      &    31,  31,  14,  13,  23,   0,   0,   0,   0,  13,
31795      &    23,  13,  14,  23,  14,  13,  23,  13,  78,  23,
31796      &    13,  14,  23,  13,  79,  78,  14,  23,  14,  23,
31797      &    13,  80,  79,  14,  14,  23,  80,  31,  14,  23  /
31798       DATA (NZK(K,2),K=171,340) /
31799      &    13,  79,  78,  31,  14,  23,  13,  80,  79,  23,
31800      &    13,  14,  23,  13,  79,  78,  14,  23,  14,  23,
31801      &    13,  80,  79,  23,  13,  33,  32,  15,  24,  15,
31802      &    31,  14,  23,  34,  33,  24,  24,  15,  31,  14,
31803      &    23,  14,  13,  23,  13,  14,  23,  14,  80,  23,
31804      &    14,  13,  23,  14,  79,  80,  13,  23,  13,  23,
31805      &    14,  78,  79,  13,  13,  23,  78,  23,  14,  13,
31806      &    23,  14,  79,  80,  13,  23,  13,  23,  14,  78,
31807      &    79,  62,  61,  23,  14,  23,  13,  13,  13,  23,
31808      &    13,  13,  23,  14,  14,  14,   1,   8,   8,   1,
31809      &     8,   1,   8,   8,   1,   8,   1,   8,   1,   8,
31810      &     1,   1,   8,   1,   8,   8,   1,   1,   8,   8,
31811      &     1,   8,  25,  23,  13,  31,  23,  13,  16,  14,
31812      &    35,  34,  34,  33,  31,  14,  23,   0,   0,   0,
31813      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31814      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31815      &    13,  23,  14,   7,  16,  19,  14,   7,  23,  14  /
31816       DATA (NZK(K,2),K=341,510) /
31817      &    23,  14,   7,  13,  23,  13,  13,  23,  13,  23,
31818      &    14,  13,  14,  23,  14,  23,  13,  14,  23,  14,
31819      &    23,  16,  14,  23,  14,  23,  14,  13,  13,  23,
31820      &    13,  23,  14,  13,  23,  13,  23,  15,  13,  13,
31821      &    13,  23,  13,  13,  14,  14,  14,  14,  14,  23,
31822      &    13,  16,  25,  14,  15,  24,  23,  14,   7,  23,
31823      &     7,  13,  23,   7,  14,  23,   7,  23,   7,   7,
31824      &     7,   7,   7,  13,  23,  31,   3,  11,  14, 135,
31825      &     5, 134, 134, 134, 136,   6, 133, 133, 133,   0,
31826      &     0,   0,   0,  31,  95,  25,  15,  31,  95,  16,
31827      &    32,  32,  33,  35,  39,  39,  38,  25,  13,  39,
31828      &    32,  39,  38,  35,  32,  39,  13,  23,  14,   7,
31829      &     7,  25,  37,  32,  13,  25,  13,  25,  13,  25,
31830      &    13,  31,  95,  24,  16,  31,  24,  15,  34,  34,
31831      &    33,  35,  37,  37,  36,  24,  14,  37,  34,  37,
31832      &    36,  35,  34,  37,  14,  23,  13,   7,   7,  24,
31833      &    39,  34,  14,  24,  14,  24,  14,  24,  14,   7  /
31834       DATA (NZK(K,2),K=511,540) /
31835      &     7,   7,   7,   7,   7,   7,   7,   7,  25,  13,
31836      &    25,   7,   7,   7,   7,   7,   7,   7,   7,   7,
31837      &    24,  14,  24,  13,  14,  23,  13,  23,  14,  23  /
31838       DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
31839      & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
31840      & 14, 14, 23, 14, 16, 25,
31841      & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
31842      & 23, 13, 14, 23,  0 /
31843       DATA (NZK(K,3),K=  1,170) /
31844      &     0,   0,   0,   0,   0,   0,   0,   5,   6,   5,
31845      &     6,  23,  23,   5,   5,   0,   0,   0,   0,  14,
31846      &    23,   5,   5,   0,   0,  14,  23,   5,   5,   0,
31847      &     0,   5,   5,   0,   0,   5,   5,   0,   0,   0,
31848      &     0,   0,   0,   0,   3,   0,   7,  23,  23,   7,
31849      &     0,   0,   0,   0,  23,   0,   0,   0,   0,   0,
31850      &     110*0   /
31851       DATA (NZK(K,3),K=171,340) /
31852      &     80*0,
31853      &     0,   0,   0,   0,   0,   0,  23,  13,  14,  23,
31854      &    23,  14,  23,  23,  23,  14,  23,  13,  23,  14,
31855      &    13,  23,  13,  23,  14,  23,  14,  14,  23,  13,
31856      &    13,  23,  13,  14,  23,  23,  14,  23,  13,  23,
31857      &    14,  14,   0,   0,   0,   0,   0,   0,   0,   0,
31858      &     30*0,
31859      &    14,  23,   7,   0,   0,   0,  23,   0,   0,   0  /
31860       DATA (NZK(K,3),K=341,510) /
31861      &     30*0,
31862      &     0,   0,   0,   0,   0,   0,   0,   0,   0,  23,
31863      &    14,   0,  13,   0,  14,   0,   0,  23,  13,   0,
31864      &     0,  15,   0,   0,  16,   0,   0,   0,   0,   0,
31865      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31866      &     0,   0,   0,  14,  23,   0,   0,   0,  23, 134,
31867      &   134,   0,   0,   0, 133, 133,   0,   0,   0,   0,
31868      &     80*0  /
31869       DATA (NZK(K,3),K=511,540) /
31870      &     0,   0,   0,   0,   0,   0,   0,   0,  13,  13,
31871      &    25,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31872      &    14,  14,  24,   0,   0,   0,   0,   0,   0,   0  /
31873       DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
31874      & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
31875
31876       END
31877
31878 *$ CREATE DT_BDEVAP.FOR
31879 *COPY DT_BDEVAP
31880 *
31881 *=== bdevap ===========================================================*
31882 *
31883       BLOCK DATA DT_BDEVAP
31884
31885 C     INCLUDE '(DBLPRC)'
31886 * DBLPRC.ADD
31887       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31888       SAVE
31889 * (original name: GLOBAL)
31890       PARAMETER ( KALGNM = 2 )
31891       PARAMETER ( ANGLGB = 5.0D-16 )
31892       PARAMETER ( ANGLSQ = 2.5D-31 )
31893       PARAMETER ( AXCSSV = 0.2D+16 )
31894       PARAMETER ( ANDRFL = 1.0D-38 )
31895       PARAMETER ( AVRFLW = 1.0D+38 )
31896       PARAMETER ( AINFNT = 1.0D+30 )
31897       PARAMETER ( AZRZRZ = 1.0D-30 )
31898       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
31899       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
31900       PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
31901       PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
31902       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
31903       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
31904       PARAMETER ( CSNNRM = 2.0D-15 )
31905       PARAMETER ( DMXTRN = 1.0D+08 )
31906       PARAMETER ( ZERZER = 0.D+00 )
31907       PARAMETER ( ONEONE = 1.D+00 )
31908       PARAMETER ( TWOTWO = 2.D+00 )
31909       PARAMETER ( THRTHR = 3.D+00 )
31910       PARAMETER ( FOUFOU = 4.D+00 )
31911       PARAMETER ( FIVFIV = 5.D+00 )
31912       PARAMETER ( SIXSIX = 6.D+00 )
31913       PARAMETER ( SEVSEV = 7.D+00 )
31914       PARAMETER ( EIGEIG = 8.D+00 )
31915       PARAMETER ( ANINEN = 9.D+00 )
31916       PARAMETER ( TENTEN = 10.D+00 )
31917       PARAMETER ( HLFHLF = 0.5D+00 )
31918       PARAMETER ( ONETHI = ONEONE / THRTHR )
31919       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
31920       PARAMETER ( ONEFOU = ONEONE / FOUFOU )
31921       PARAMETER ( THRTWO = THRTHR / TWOTWO )
31922       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
31923       PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
31924       PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
31925       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
31926       PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
31927       PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
31928       PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
31929       PARAMETER ( EULERO = 0.577215664901532860606512      D+00 )
31930       PARAMETER ( EULEXP = 1.781072417990197985236504      D+00 )
31931       PARAMETER ( EULLOG =-0.5495393129816448223376619     D+00 )
31932       PARAMETER ( E1M2EU = 0.8569023337737540831433017     D+00 )
31933       PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
31934       PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
31935       PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
31936       PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
31937       PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
31938       PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
31939       PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
31940       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
31941       PARAMETER ( CLIGHT = 2.99792458         D+10 )
31942       PARAMETER ( AVOGAD = 6.0221367          D+23 )
31943       PARAMETER ( BOLTZM = 1.380658           D-23 )
31944       PARAMETER ( AMELGR = 9.1093897          D-28 )
31945       PARAMETER ( PLCKBR = 1.05457266         D-27 )
31946       PARAMETER ( ELCCGS = 4.8032068          D-10 )
31947       PARAMETER ( ELCMKS = 1.60217733         D-19 )
31948       PARAMETER ( AMUGRM = 1.6605402          D-24 )
31949       PARAMETER ( AMMUMU = 0.113428913        D+00 )
31950       PARAMETER ( AMPRMU = 1.007276470        D+00 )
31951       PARAMETER ( AMNEMU = 1.008664904        D+00 )
31952       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
31953       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
31954       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
31955       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
31956       PARAMETER ( PLABRC = 0.197327053        D+00 )
31957       PARAMETER ( AMELCT = 0.51099906         D-03 )
31958       PARAMETER ( AMUGEV = 0.93149432         D+00 )
31959       PARAMETER ( AMMUON = 0.105658389        D+00 )
31960       PARAMETER ( AMPRTN = 0.93827231         D+00 )
31961       PARAMETER ( AMNTRN = 0.93956563         D+00 )
31962       PARAMETER ( AMDEUT = 1.87561339         D+00 )
31963       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
31964      &                   * 1.D-09 )
31965       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
31966       PARAMETER ( BLTZMN = 8.617385           D-14 )
31967       PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
31968       PARAMETER ( GFOHB3 = 1.16639            D-05 )
31969       PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
31970       PARAMETER ( SIN2TW = 0.2319             D+00 )
31971       PARAMETER ( GEVMEV = 1.0                D+03 )
31972       PARAMETER ( EMVGEV = 1.0                D-03 )
31973       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
31974       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
31975       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
31976       LOGICAL LGBIAS, LGBANA
31977       COMMON /FKGLOB/ LGBIAS, LGBANA
31978 C     INCLUDE '(DIMPAR)'
31979 * DIMPAR.ADD
31980       PARAMETER ( MXXRGN = 5000 )
31981       PARAMETER ( MXXMDF = 82   )
31982       PARAMETER ( MXXMDE = 54   )
31983       PARAMETER ( MFSTCK = 1000 )
31984       PARAMETER ( MESTCK = 100  )
31985       PARAMETER ( NELEMX = 80   )
31986       PARAMETER ( MPDPDX = 8    )
31987       PARAMETER ( ICOMAX = 180  )
31988       PARAMETER ( NSTBIS = 304  )
31989       PARAMETER ( IDMAXP = 220  )
31990       PARAMETER ( IDMXDC = 640  )
31991       PARAMETER ( MKBMX1 = 1    )
31992       PARAMETER ( MKBMX2 = 1    )
31993 C     INCLUDE '(IOUNIT)'
31994 * IOUNIT.ADD
31995       PARAMETER ( LUNIN  =  5 )
31996       PARAMETER ( LUNOUT =  6 )
31997 **sr 19.5. set error output-unit from 15 to 6
31998       PARAMETER ( LUNERR = 6  )
31999       PARAMETER ( LUNBER = 14 )
32000       PARAMETER ( LUNECH =  8 )
32001       PARAMETER ( LUNFLU = 13 )
32002       PARAMETER ( LUNGEO = 16 )
32003       PARAMETER ( LUNPMF = 12 )
32004       PARAMETER ( LUNRAN =  2 )
32005       PARAMETER ( LUNXSC =  9 )
32006       PARAMETER ( LUNDET = 17 )
32007       PARAMETER ( LUNRAY = 10 )
32008       PARAMETER ( LUNRDB =  1 )
32009       PARAMETER ( LUNPGO =  7 )
32010       PARAMETER ( LUNPGS =  4 )
32011       PARAMETER ( LUNSCR =  3 )
32012 *
32013 *----------------------------------------------------------------------*
32014 *                                                                      *
32015 *     Block Data for the EVAPoration routines:                         *
32016 *                                                                      *
32017 *     Created on    20 may 1990    by    Alfredo Ferrari & Paola Sala  *
32018 *                                                   Infn - Milan       *
32019 *                                                                      *
32020 *     Modified from the original version of J.M.Zazula                 *
32021 *     and, for cookcm, from a LAHET block data kindly provided by      *
32022 *     R.E.Prael-LANL                                                   *
32023 *                                                                      *
32024 *     Last change on  20-feb-95    by    Alfredo Ferrari               *
32025 *                                                                      *
32026 *                                                                      *
32027 *----------------------------------------------------------------------*
32028 *
32029 * (original name: COOKCM)
32030       PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 )
32031       LOGICAL LDEFOZ, LDEFON
32032       PARAMETER ( INCOOK = 150, IZCOOK = 98 )
32033       COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN,
32034      &                SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK),
32035      &                PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK)
32036 * (original name: EVA0)
32037       COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
32038      *                FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
32039      *                CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
32040      *                T (4,7), RMASS (297), ALPH (297), BET (297),
32041      *                APRIME (250), IA (6), IZ (6)
32042 * (original name: HETTP)
32043       COMMON /FKHETP/  NHSTP,NBERTP,IOSUB,INSRS
32044 * (original name: HETC7)
32045       COMMON /FKHET7/ COSKS,SINKS, COSTH,SINTH, COSPHI,SINPHI
32046 * (original name: INPFLG)
32047       COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
32048 *
32049       DATA B0   / 8.D+00 /, Y0 / 1.5D+00 /
32050       DATA IANG / 1 /, IFISS / 1 /,  IB0 / 2 /, IGEOM / 0 /
32051       DATA ISTRAG /0/, KEYDK /0/
32052       DATA NBERTP /LUNBER/
32053       DATA COSTH /ONEONE/, SINTH /ZERZER/, COSPHI /ONEONE/,
32054      &     SINPHI/ZERZER/
32055 *  /cookcm/
32056        DATA ( PZCOOK(I),I =  1, IZCOOK ) /
32057      & 0.000D+00, 5.440D+00, 0.000D+00, 2.760D+00, 0.000D+00, 3.340D+00,
32058      & 0.000D+00, 2.700D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.460D+00,
32059      & 0.000D+00, 2.090D+00, 0.000D+00, 1.620D+00, 0.000D+00, 1.620D+00,
32060      & 0.000D+00, 1.830D+00, 0.000D+00, 1.730D+00, 0.000D+00, 1.350D+00,
32061      & 0.000D+00, 1.540D+00, 0.000D+00, 1.280D+00, 2.600D-01, 8.800D-01,
32062      & 1.900D-01, 1.350D+00,-5.000D-02, 1.520D+00,-9.000D-02, 1.170D+00,
32063      & 4.000D-02, 1.240D+00, 2.900D-01, 1.090D+00, 2.600D-01, 1.170D+00,
32064      & 2.300D-01, 1.150D+00,-8.000D-02, 1.350D+00, 3.400D-01, 1.050D+00,
32065      & 2.800D-01, 1.270D+00, 0.000D+00, 1.050D+00, 0.000D+00, 1.000D+00,
32066      & 9.000D-02, 1.200D+00, 2.000D-01, 1.400D+00, 9.300D-01, 1.000D+00,
32067      &-2.000D-01, 1.190D+00, 9.000D-02, 9.700D-01, 0.000D+00, 9.200D-01,
32068      & 1.100D-01, 6.800D-01, 5.000D-02, 6.800D-01,-2.200D-01, 7.900D-01,
32069      & 9.000D-02, 6.900D-01, 1.000D-02, 7.200D-01, 0.000D+00, 4.000D-01,
32070      & 1.600D-01, 7.300D-01, 0.000D+00, 4.600D-01, 1.700D-01, 8.900D-01,
32071      & 0.000D+00, 7.900D-01, 0.000D+00, 8.900D-01, 0.000D+00, 8.100D-01,
32072      &-6.000D-02, 6.900D-01,-2.000D-01, 7.100D-01,-1.200D-01, 7.200D-01,
32073      & 0.000D+00, 7.700D-01/
32074        DATA ( PNCOOK(I),I =  1, 90 ) /
32075      & 0.000D+00, 5.980D+00, 0.000D+00, 2.770D+00, 0.000D+00, 3.160D+00,
32076      & 0.000D+00, 3.010D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.670D+00,
32077      & 0.000D+00, 1.800D+00, 0.000D+00, 1.670D+00, 0.000D+00, 1.860D+00,
32078      & 0.000D+00, 2.040D+00, 0.000D+00, 1.640D+00, 0.000D+00, 1.440D+00,
32079      & 0.000D+00, 1.540D+00, 0.000D+00, 1.300D+00, 0.000D+00, 1.270D+00,
32080      & 0.000D+00, 1.290D+00, 8.000D-02, 1.410D+00,-8.000D-02, 1.500D+00,
32081      &-5.000D-02, 2.240D+00,-4.700D-01, 1.430D+00,-1.500D-01, 1.440D+00,
32082      & 6.000D-02, 1.560D+00, 2.500D-01, 1.570D+00,-1.600D-01, 1.460D+00,
32083      & 0.000D+00, 9.300D-01, 1.000D-02, 6.200D-01,-5.000D-01, 1.420D+00,
32084      & 1.300D-01, 1.520D+00,-6.500D-01, 8.000D-01,-8.000D-02, 1.290D+00,
32085      &-4.700D-01, 1.250D+00,-4.400D-01, 9.700D-01, 8.000D-02, 1.650D+00,
32086      &-1.100D-01, 1.260D+00,-4.600D-01, 1.060D+00, 2.200D-01, 1.550D+00,
32087      &-7.000D-02, 1.370D+00, 1.000D-01, 1.200D+00,-2.700D-01, 9.200D-01,
32088      &-3.500D-01, 1.190D+00, 0.000D+00, 1.050D+00,-2.500D-01, 1.610D+00,
32089      &-2.100D-01, 9.000D-01,-2.100D-01, 7.400D-01,-3.800D-01, 7.200D-01/
32090        DATA ( PNCOOK(I),I = 91, INCOOK ) /
32091      &-3.400D-01, 9.200D-01,-2.600D-01, 9.400D-01, 1.000D-02, 6.500D-01,
32092      &-3.600D-01, 8.300D-01, 1.100D-01, 6.700D-01, 5.000D-02, 1.000D+00,
32093      & 5.100D-01, 1.040D+00, 3.300D-01, 6.800D-01,-2.700D-01, 8.100D-01,
32094      & 9.000D-02, 7.500D-01, 1.700D-01, 8.600D-01, 1.400D-01, 1.100D+00,
32095      &-2.200D-01, 8.400D-01,-4.700D-01, 4.800D-01, 2.000D-02, 8.800D-01,
32096      & 2.400D-01, 5.200D-01, 2.700D-01, 4.100D-01,-5.000D-02, 3.800D-01,
32097      & 1.500D-01, 6.700D-01, 0.000D+00, 6.100D-01, 0.000D+00, 7.800D-01,
32098      & 0.000D+00, 6.700D-01, 0.000D+00, 6.700D-01, 0.000D+00, 7.900D-01,
32099      & 0.000D+00, 6.000D-01, 4.000D-02, 6.400D-01,-6.000D-02, 4.500D-01,
32100      & 5.000D-02, 2.600D-01,-2.200D-01, 3.900D-01, 0.000D+00, 3.900D-01/
32101        DATA ( SZCOOK(I),I =  1, 98) /
32102      & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
32103      & 0.000D+00, 0.000D+00,-1.100D-01,-8.100D-01,-2.910D+00,-4.170D+00,
32104      &-5.720D+00,-7.800D+00,-8.970D+00,-9.700D+00,-1.010D+01,-1.070D+01,
32105      &-1.138D+01,-1.207D+01,-1.255D+01,-1.324D+01,-1.393D+01,-1.471D+01,
32106      &-1.553D+01,-1.637D+01,-1.736D+01,-1.860D+01,-1.870D+01,-1.801D+01,
32107      &-1.787D+01,-1.708D+01,-1.660D+01,-1.675D+01,-1.650D+01,-1.635D+01,
32108      &-1.622D+01,-1.641D+01,-1.689D+01,-1.643D+01,-1.668D+01,-1.673D+01,
32109      &-1.745D+01,-1.729D+01,-1.744D+01,-1.782D+01,-1.862D+01,-1.827D+01,
32110      &-1.939D+01,-1.991D+01,-1.914D+01,-1.826D+01,-1.740D+01,-1.642D+01,
32111      &-1.577D+01,-1.437D+01,-1.391D+01,-1.310D+01,-1.311D+01,-1.143D+01,
32112      &-1.089D+01,-1.075D+01,-1.062D+01,-1.041D+01,-1.021D+01,-9.850D+00,
32113      &-9.470D+00,-9.030D+00,-8.610D+00,-8.130D+00,-7.460D+00,-7.480D+00,
32114      &-7.200D+00,-7.130D+00,-7.060D+00,-6.780D+00,-6.640D+00,-6.640D+00,
32115      &-7.680D+00,-7.890D+00,-8.410D+00,-8.490D+00,-7.880D+00,-6.300D+00,
32116      &-5.470D+00,-4.780D+00,-4.370D+00,-4.170D+00,-4.130D+00,-4.320D+00,
32117      &-4.550D+00,-5.040D+00,-5.280D+00,-6.060D+00,-6.280D+00,-6.870D+00,
32118      &-7.200D+00,-7.740D+00/
32119        DATA ( SNCOOK(I),I =  1, 90 ) /
32120      & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
32121      & 0.000D+00, 0.000D+00, 1.030D+01, 5.660D+00, 6.800D+00, 7.530D+00,
32122      & 7.550D+00, 7.210D+00, 7.440D+00, 8.070D+00, 8.940D+00, 9.810D+00,
32123      & 1.060D+01, 1.139D+01, 1.254D+01, 1.368D+01, 1.434D+01, 1.419D+01,
32124      & 1.383D+01, 1.350D+01, 1.300D+01, 1.213D+01, 1.260D+01, 1.326D+01,
32125      & 1.413D+01, 1.492D+01, 1.552D+01, 1.638D+01, 1.716D+01, 1.755D+01,
32126      & 1.803D+01, 1.759D+01, 1.903D+01, 1.871D+01, 1.880D+01, 1.899D+01,
32127      & 1.846D+01, 1.825D+01, 1.776D+01, 1.738D+01, 1.672D+01, 1.562D+01,
32128      & 1.438D+01, 1.288D+01, 1.323D+01, 1.381D+01, 1.490D+01, 1.486D+01,
32129      & 1.576D+01, 1.620D+01, 1.762D+01, 1.773D+01, 1.816D+01, 1.867D+01,
32130      & 1.969D+01, 1.951D+01, 2.017D+01, 1.948D+01, 1.998D+01, 1.983D+01,
32131      & 2.020D+01, 1.972D+01, 1.987D+01, 1.924D+01, 1.844D+01, 1.761D+01,
32132      & 1.710D+01, 1.616D+01, 1.590D+01, 1.533D+01, 1.476D+01, 1.354D+01,
32133      & 1.263D+01, 1.065D+01, 1.010D+01, 8.890D+00, 1.025D+01, 9.790D+00,
32134      & 1.139D+01, 1.172D+01, 1.243D+01, 1.296D+01, 1.343D+01, 1.337D+01/
32135        DATA ( SNCOOK(I),I = 91, INCOOK ) /
32136      & 1.296D+01, 1.211D+01, 1.192D+01, 1.100D+01, 1.080D+01, 1.042D+01,
32137      & 1.039D+01, 9.690D+00, 9.270D+00, 8.930D+00, 8.570D+00, 8.020D+00,
32138      & 7.590D+00, 7.330D+00, 7.230D+00, 7.050D+00, 7.420D+00, 6.750D+00,
32139      & 6.600D+00, 6.380D+00, 6.360D+00, 6.490D+00, 6.250D+00, 5.850D+00,
32140      & 5.480D+00, 4.530D+00, 4.300D+00, 3.390D+00, 2.350D+00, 1.660D+00,
32141      & 8.100D-01, 4.600D-01,-9.600D-01,-1.690D+00,-2.530D+00,-3.160D+00,
32142      &-1.870D+00,-4.100D-01, 7.100D-01, 1.660D+00, 2.620D+00, 3.220D+00,
32143      & 3.760D+00, 4.100D+00, 4.460D+00, 4.830D+00, 5.090D+00, 5.180D+00,
32144      & 5.170D+00, 5.100D+00, 5.010D+00, 4.970D+00, 5.090D+00, 5.030D+00,
32145      & 4.930D+00, 5.280D+00, 5.490D+00, 5.500D+00, 5.370D+00, 5.300D+00/
32146       DATA LDEFOZ / 53*.FALSE.,25*.TRUE.,7*.FALSE.,13*.TRUE. /
32147       DATA LDEFON / 85*.FALSE.,37*.TRUE.,7*.FALSE.,21*.TRUE. /
32148 *=== End of Block Data Bdevap =========================================*
32149       END
32150
32151 *$ CREATE DT_BDNOPT.FOR
32152 *COPY DT_BDNOPT
32153 *
32154 *=== bdnopt ===========================================================*
32155 *==                                                                    *
32156       BLOCK DATA DT_BDNOPT
32157
32158 C     INCLUDE '(DBLPRC)'
32159 * DBLPRC.ADD
32160       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32161       SAVE
32162 * (original name: GLOBAL)
32163       PARAMETER ( KALGNM = 2 )
32164       PARAMETER ( ANGLGB = 5.0D-16 )
32165       PARAMETER ( ANGLSQ = 2.5D-31 )
32166       PARAMETER ( AXCSSV = 0.2D+16 )
32167       PARAMETER ( ANDRFL = 1.0D-38 )
32168       PARAMETER ( AVRFLW = 1.0D+38 )
32169       PARAMETER ( AINFNT = 1.0D+30 )
32170       PARAMETER ( AZRZRZ = 1.0D-30 )
32171       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
32172       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
32173       PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
32174       PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
32175       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
32176       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
32177       PARAMETER ( CSNNRM = 2.0D-15 )
32178       PARAMETER ( DMXTRN = 1.0D+08 )
32179       PARAMETER ( ZERZER = 0.D+00 )
32180       PARAMETER ( ONEONE = 1.D+00 )
32181       PARAMETER ( TWOTWO = 2.D+00 )
32182       PARAMETER ( THRTHR = 3.D+00 )
32183       PARAMETER ( FOUFOU = 4.D+00 )
32184       PARAMETER ( FIVFIV = 5.D+00 )
32185       PARAMETER ( SIXSIX = 6.D+00 )
32186       PARAMETER ( SEVSEV = 7.D+00 )
32187       PARAMETER ( EIGEIG = 8.D+00 )
32188       PARAMETER ( ANINEN = 9.D+00 )
32189       PARAMETER ( TENTEN = 10.D+00 )
32190       PARAMETER ( HLFHLF = 0.5D+00 )
32191       PARAMETER ( ONETHI = ONEONE / THRTHR )
32192       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
32193       PARAMETER ( ONEFOU = ONEONE / FOUFOU )
32194       PARAMETER ( THRTWO = THRTHR / TWOTWO )
32195       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
32196       PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
32197       PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
32198       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
32199       PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
32200       PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
32201       PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
32202       PARAMETER ( EULERO = 0.577215664901532860606512      D+00 )
32203       PARAMETER ( EULEXP = 1.781072417990197985236504      D+00 )
32204       PARAMETER ( EULLOG =-0.5495393129816448223376619     D+00 )
32205       PARAMETER ( E1M2EU = 0.8569023337737540831433017     D+00 )
32206       PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
32207       PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
32208       PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
32209       PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
32210       PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
32211       PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
32212       PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
32213       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
32214       PARAMETER ( CLIGHT = 2.99792458         D+10 )
32215       PARAMETER ( AVOGAD = 6.0221367          D+23 )
32216       PARAMETER ( BOLTZM = 1.380658           D-23 )
32217       PARAMETER ( AMELGR = 9.1093897          D-28 )
32218       PARAMETER ( PLCKBR = 1.05457266         D-27 )
32219       PARAMETER ( ELCCGS = 4.8032068          D-10 )
32220       PARAMETER ( ELCMKS = 1.60217733         D-19 )
32221       PARAMETER ( AMUGRM = 1.6605402          D-24 )
32222       PARAMETER ( AMMUMU = 0.113428913        D+00 )
32223       PARAMETER ( AMPRMU = 1.007276470        D+00 )
32224       PARAMETER ( AMNEMU = 1.008664904        D+00 )
32225       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
32226       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
32227       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
32228       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
32229       PARAMETER ( PLABRC = 0.197327053        D+00 )
32230       PARAMETER ( AMELCT = 0.51099906         D-03 )
32231       PARAMETER ( AMUGEV = 0.93149432         D+00 )
32232       PARAMETER ( AMMUON = 0.105658389        D+00 )
32233       PARAMETER ( AMPRTN = 0.93827231         D+00 )
32234       PARAMETER ( AMNTRN = 0.93956563         D+00 )
32235       PARAMETER ( AMDEUT = 1.87561339         D+00 )
32236       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
32237      &                   * 1.D-09 )
32238       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
32239       PARAMETER ( BLTZMN = 8.617385           D-14 )
32240       PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
32241       PARAMETER ( GFOHB3 = 1.16639            D-05 )
32242       PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
32243       PARAMETER ( SIN2TW = 0.2319             D+00 )
32244       PARAMETER ( GEVMEV = 1.0                D+03 )
32245       PARAMETER ( EMVGEV = 1.0                D-03 )
32246       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
32247       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
32248       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
32249       LOGICAL LGBIAS, LGBANA
32250       COMMON /FKGLOB/ LGBIAS, LGBANA
32251 C     INCLUDE '(DIMPAR)'
32252 * DIMPAR.ADD
32253       PARAMETER ( MXXRGN = 5000 )
32254       PARAMETER ( MXXMDF = 82   )
32255       PARAMETER ( MXXMDE = 54   )
32256       PARAMETER ( MFSTCK = 1000 )
32257       PARAMETER ( MESTCK = 100  )
32258       PARAMETER ( NELEMX = 80   )
32259       PARAMETER ( MPDPDX = 8    )
32260       PARAMETER ( ICOMAX = 180  )
32261       PARAMETER ( NSTBIS = 304  )
32262       PARAMETER ( IDMAXP = 220  )
32263       PARAMETER ( IDMXDC = 640  )
32264       PARAMETER ( MKBMX1 = 1    )
32265       PARAMETER ( MKBMX2 = 1    )
32266 C     INCLUDE '(IOUNIT)'
32267 * IOUNIT.ADD
32268       PARAMETER ( LUNIN  =  5 )
32269       PARAMETER ( LUNOUT =  6 )
32270 **sr 19.5. set error output-unit from 15 to 6
32271       PARAMETER ( LUNERR = 6  )
32272       PARAMETER ( LUNBER = 14 )
32273       PARAMETER ( LUNECH =  8 )
32274       PARAMETER ( LUNFLU = 13 )
32275       PARAMETER ( LUNGEO = 16 )
32276       PARAMETER ( LUNPMF = 12 )
32277       PARAMETER ( LUNRAN =  2 )
32278       PARAMETER ( LUNXSC =  9 )
32279       PARAMETER ( LUNDET = 17 )
32280       PARAMETER ( LUNRAY = 10 )
32281       PARAMETER ( LUNRDB =  1 )
32282       PARAMETER ( LUNPGO =  7 )
32283       PARAMETER ( LUNPGS =  4 )
32284       PARAMETER ( LUNSCR =  3 )
32285 *
32286 *----------------------------------------------------------------------*
32287 *                                                                      *
32288 *   Created on  20 september 1989    by  Alfredo Ferrari - Infn Milan  *
32289 *                                                                      *
32290 *         Last change on 20-apr-95   by  Alfredo Ferrari               *
32291 *                                                                      *
32292 *----------------------------------------------------------------------*
32293 *
32294 C     INCLUDE '(BLNKCM)'
32295 * BLNKCM.ADD
32296 **sr 17.5. commented since not used here
32297 C     PARAMETER ( NBLNMX = 1100000 )
32298 C     DIMENSION GMSTOR ( NBLNMX ), BRMBRR ( NBLNMX ), BRMEXP ( NBLNMX ),
32299 C    &          BRMSIG ( NBLNMX ), SIGGTT ( KALGNM*NBLNMX ),
32300 C    &          COMSCO ( NBLNMX ), LBSTOR ( KALGNM*NBLNMX )
32301 C     REAL SIGGTT
32302 C     LOGICAL LBSTOR
32303 C     COMMON   NSTOR  ( KALGNM*NBLNMX )
32304 **
32305 **sr 18.5. commented since not used for evap.
32306 C     COMMON / ADDRCM / MBLNMX, KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST,
32307 C    &                  KISBGN, KISLST, KDTBGN, KDTLST, KUBBGN, KUBLST,
32308 C    &                  KUXBGN, KUXLST, KTCBGN, KTCLST, KRNBGN, KRNLST,
32309 C    &                  KYLBGN, KYLLST, KXSBGN, KXSLST, KIHBGN, KIHLST,
32310 C    &                  KINBGN, KINLST, KIEBGN, KIELST, KETBGN, KETLST,
32311 C    &                  KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST,
32312 C    &                  KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST,
32313 C    &                  KWLBGN, KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST,
32314 C    &                  KWSBGN, KWSLST, KNDBGN, KNDLST, KDPBGN, KDPLST,
32315 C    &                  KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN, KBRLST,
32316 C    &                  KTMBGN
32317 **
32318
32319 C     EQUIVALENCE ( NSTOR (1), GMSTOR (1) )
32320 C     EQUIVALENCE ( NSTOR (1), BRMBRR (1) )
32321 C     EQUIVALENCE ( NSTOR (1), BRMEXP (1) )
32322 C     EQUIVALENCE ( NSTOR (1), BRMSIG (1) )
32323 C     EQUIVALENCE ( NSTOR (1), COMSCO (1) )
32324 C     EQUIVALENCE ( NSTOR (1), SIGGTT (1) )
32325 C     EQUIVALENCE ( NSTOR (1), LBSTOR (1) )
32326 C     INCLUDE '(BLNTMP)'
32327 * BLNTMP.ADD
32328 **sr 18.5. commented since not used for evap.
32329 C     COMMON / BLNTMP / KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM,
32330 C    &                  KGCBTM, KGDWTM, KBDWTM, KWLOTM, KWHITM, KWMUTM,
32331 C    &                  KWSHTM, KEXTTM, KSTXTM, KSTNTM, KECTTM, KPCTTM,
32332 C    &                  KLPBTM, NXXRGN
32333 **
32334 C     INCLUDE '(CMMDNR)'
32335 * CMMDNR.ADD
32336 **sr 18.5. commented since not used for evap.
32337 C     LOGICAL LFLDNR
32338 C     COMMON / CMMDNR / DDNEAR, LFLDNR
32339 **
32340 C     INCLUDE '(CTITLE)'
32341 * CTITLE.ADD
32342 **sr 18.5. commented since not used for evap.
32343 C     CHARACTER RUNTIT*80, RUNTIM*32, RUNKEY*10
32344 C     COMMON / CTITLE / RUNTIT, RUNTIM, RUNKEY
32345 C     COMMON / CEXPCK / ITEXPI, ITEXMX
32346 **
32347 C     INCLUDE '(DETECT)'
32348 * DETECT.ADD
32349 **sr 18.5. commented since not used for evap.
32350 C     PARAMETER (NRGNMX = 10)
32351 C     PARAMETER (NDTCMX = 10)
32352 C     PARAMETER (NSCRMX = 10)
32353 C     PARAMETER (NDTBIN = 1024)
32354 C     CHARACTER*10 TITDET,TITSCO
32355 C     LOGICAL LDTCTR
32356 C     COMMON /DETCT/  EDTMIN(NDTCMX), EDTBIN(NDTCMX), EDTCUT(NDTCMX),
32357 C    &                KDTREG(NRGNMX,NDTCMX), KDTDET(NDTCMX,NSCRMX),
32358 C    &                NDTSCO, NDTDET, LDTCTR, IDTREG(MXXRGN),
32359 C    &                KDTSCD(NSCRMX)
32360 C     COMMON /DETCH/  TITDET(NDTCMX), TITSCO(NSCRMX)
32361 **
32362 C     INCLUDE '(DETLOC)'
32363 * DETLOC.ADD
32364 **sr 18.5. commented since not used for evap.
32365 C     PARAMETER (NDTCM2 = 10)
32366 C     COMMON /DETLOC/ ACCUMP (NDTCM2), ACCUMN (NDTCM2),
32367 C    &                ICOINC(NDTCM2), NCLAS
32368 **
32369 C     INCLUDE '(EMGTRN)'
32370 * EMGTRN.ADD
32371 **sr 18.5. commented since not used for evap.
32372 C     LOGICAL LMCSMG
32373 C     COMMON / EMGTRN / UMCSMG, VMCSMG, WMCSMG, LMCSMG
32374 **
32375 C     INCLUDE '(EMSHO)'
32376 * EMSHO.ADD
32377 **sr 18.5. commented since not used for evap.
32378 C     LOGICAL EMFLO, EMFHLO, EMFELO, LIMPRE, LEXPTE
32379 C     COMMON /EMSHO/ EMFETH, EMFPTH, EMFHET, EMFHPT, EMFBIA, EMFLO,
32380 C    &               EMFHLO, EMFELO, LIMPRE, LEXPTE
32381 **
32382 C     INCLUDE '(EPISOR)'
32383 * EPISOR.ADD
32384 **sr 18.5. commented since not used for evap.
32385 C     LOGICAL LUSSRC
32386 C     COMMON/EPISOR/TKESUM,LUSSRC
32387 **
32388 * (original name: FHEAVY,FHEAVC)
32389       PARAMETER ( MXHEAV = 100 )
32390       CHARACTER*8 ANHEAV
32391       COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
32392      &                CZHEAV (MXHEAV), TKHEAV (MXHEAV),
32393      &                PHEAVY (MXHEAV), WHEAVY (MXHEAV),
32394      &                AMHEAV  ( 12 ) , AMNHEA  ( 12 ) ,
32395      &                KHEAVY (MXHEAV), ICHEAV  ( 12 ) ,
32396      &                IBHEAV  ( 12 ) , NPHEAV
32397       COMMON /FKFHVC/ ANHEAV  ( 12 )
32398 * (original name: FINUC)
32399       PARAMETER (MXP=999)
32400       COMMON /FKFINU/ CXR    (MXP), CYR    (MXP), CZR    (MXP),
32401      &                CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
32402      &                TKI    (MXP), PLR    (MXP), WEI    (MXP),
32403      &                TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
32404      &                KPART  (MXP)
32405 C     INCLUDE '(GENTHR)'
32406 * GENTHR.ADD
32407 **sr 18.5. commented since not used for evap.
32408 C     COMMON / GENTHR / PEANCT, PEAPIT, PLDNCT, PTHRSH (NALLWP),
32409 C    &                  PTHDFF (NALLWP), IJNUCR (NALLWP)
32410 **
32411 C     INCLUDE '(LOWNEU)'
32412 * LOWNEU.ADD
32413 **sr 18.5. commented since not used for evap.
32414 C     PARAMETER ( MXGTHN =  15 )
32415 C     PARAMETER ( MXGLWN = 200 )
32416 C     PARAMETER ( MXSHPP =   5 )
32417 C     LOGICAL LCOMPN, LIMPRN, LBIASN, LDOWNN, LRECPR, LLOWWW, LLOWET
32418 C     CHARACTER*10 TITLOW
32419 C     COMMON / LOWNEU / ATOLOW (MXXMDF), WSHPLN (MXGLWN,MXSHPP), EXTWWL,
32420 C    &                  SHPIMP (MXGLWN), EXTETL (MXGLWN), WWAMFL,
32421 C    &                  VLLNTH (MXGTHN,MXXMDF), ABLNTH (MXGTHN,MXXMDF),
32422 C    &                  STLNTH (MXGTHN,MXXMDF), TMRTLN (MXXMDF),
32423 C    &                  TMNMLN (MXXMDF), ICHCPT (MXXMDF),
32424 C    &                  IGTMRT (MXXMDF), NEUMED (MXXMDF),
32425 C    &                  ID1MED (MXXMDF), ID2MED (MXXMDF),
32426 C    &                  ID3MED (MXXMDF), MGTMED (MXXMDF),
32427 C    &                  LCOMPN (MXXMDF), LRECPR (MXXMDF), KPRLOW, NMGP,
32428 C    &                  NMTG  , IGRTHN, LIMPRN, LBIASN, LDOWNN, LLOWWW,
32429 C    &                  LLOWET, ICLMED, IKRBGN, INABGN, IDWBGN, IETBGN,
32430 C    &                  I0XSEC, IDXSEC, ISENAV, ISVELN, ISPNAV, IWWLWB,
32431 C    &                  IWWLWT, IPXBGN, NPXSEC
32432 C     COMMON / CHLWNT / TITLOW (MXXMDF)
32433 **
32434 C     INCLUDE '(LTCLCM)'
32435 * LTCLCM.ADD
32436 **sr 18.5. commented since not used for evap.
32437 C     COMMON / LTCLCM / MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1
32438 **
32439 C     INCLUDE '(MULBOU)'
32440 * MULBOU.ADD
32441 **sr 18.5. commented since not used for evap.
32442 C     LOGICAL LLDA  , LAGAIN, LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR
32443 C     COMMON / MULBOU / UOLD  , VOLD  , WOLD  , UMAG  , VMAG  , WMAG  ,
32444 C    &                  UNORML, VNORML, WNORML, USENSE, VSENSE, WSENSE,
32445 C    &                  TSENSE, DDSENS, DSMALL, NSSENS, LLDA  , LAGAIN,
32446 C    &                  LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR
32447 **
32448 C     INCLUDE '(MULHD)'
32449 * MULHD.ADD
32450 **sr 18.5. commented since not used for evap.
32451 C     PARAMETER ( MXXPT1 = 1 )
32452 C     PARAMETER ( TIMESS = 2.00D+00 )
32453 C     PARAMETER ( TMSRLX = 1.50D+00 )
32454 C     PARAMETER ( EPSINS = 0.15D+00 )
32455 C     PARAMETER ( EPSRLX = 0.50D+00 )
32456 C     PARAMETER ( SQEPSN = 0.3872983346207417 D+00 )
32457 C     PARAMETER ( SQEPSR = 0.7071067811865475 D+00 )
32458 C     PARAMETER ( PARNSI = 1.732050807568877 D+00 * SQEPSN )
32459 C     PARAMETER ( PRNSR0 = 1.732050807568877 D+00 * SQEPSR )
32460 C     PARAMETER ( R0NCMS = 1.20 D+00 )
32461 C     LOGICAL LTOPT, LSRCRH, LNSCRH
32462 C     COMMON / MULHD / BLCC   ( MXXMDF ), BLCCRA ( MXXMDF ),
32463 C    &                 XCC    ( MXXMDF ), ZTILDE ( MXXMDF, 0:MXXPT1 ),
32464 C    &                 ALPZTL ( MXXMDF, 0:MXXPT1 ), RLDU   ( MXXMDF ),
32465 C    &                 ALPZT2 ( MXXMDF, 0:MXXPT1 ), TEFF0  ( MXXMDF ),
32466 C    &                 XR0    ( MXXMDF ), ECUTM  ( MXXMDF, 39, 2 ),
32467 C    &                 ESTEPF ( MXXMDF ), HTHNSZ ( MXXMDF, 39 ),
32468 C    &                 AE1O3  ( MXXMDF ), PARNSR ( MXXMDF ),
32469 C    &                 HEESLI ( MXXMDF ), THMSPR, THMSSC, HMSAMP,
32470 C    &                 HMREJE, LSRCRH ( MXXMDF ), LNSCRH ( MXXMDF ),
32471 C    &                 LTOPT  ( MXXMDF ), NFSCAT
32472 **
32473 * (original name: PAREVT)
32474       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
32475      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
32476       PARAMETER ( NALLWP = 39   )
32477       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
32478      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
32479      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
32480      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
32481 * (original name: RESNUC)
32482       LOGICAL LRNFSS, LFRAGM
32483       COMMON /FKRESN/  AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
32484      &                   ANOW,   ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
32485      &                   ERES,  EKRES, AMNRES, AMMRES,  PTRES,  PXRES,
32486      &                  PYRES,  PZRES, PTRES2,  KTARP,  KTARN, IGREYP,
32487      &                 IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
32488      &                  ICRES,  IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
32489      &                 IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
32490      &                  IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
32491      &                 LFRAGM
32492 C     INCLUDE '(SCOHLP)'
32493 * SCOHLP.ADD
32494 **sr 18.5. commented since not used for evap.
32495 C     LOGICAL LSCZER
32496 C     COMMON / SCOHLP / ISCRNG, JSCRNG, LSCZER
32497 **
32498 C     INCLUDE '(TRACKR)'
32499 * TRACKR.ADD
32500 **sr 18.5. commented since not used for evap.
32501 C     PARAMETER ( MXTRCK = 2500 )
32502 C     LOGICAL LFSSSC
32503 C     COMMON / TRACKR /  XTRACK ( 0:MXTRCK ), YTRACK ( 0:MXTRCK ),
32504 C    &                   ZTRACK ( 0:MXTRCK ), TTRACK   ( MXTRCK ),
32505 C    &                   DTRACK   ( MXTRCK ), ETRACK, PTRACK, WTRACK,
32506 C    &                   ATRACK, CTRACK, AKSHRT, AKLONG, WSCRNG,
32507 C    &                   NTRACK, MTRACK, JTRACK, KTRACK, MMTRCK,
32508 C    &                   LT1TRK, LT2TRK, LTRACK, LLOUSE, LFSSSC
32509 **
32510 C     INCLUDE '(USRBDX)'
32511 * USRBDX.ADD
32512 **sr 18.5. commented since not used for evap.
32513 C     PARAMETER ( MXUSBX = 600 )
32514 C     LOGICAL LUSBDX, LFUSBX, LWUSBX, LLNUSX
32515 C     CHARACTER*10 TITUSX
32516 C     COMMON /USRBX/  EBXLOW(MXUSBX), EBXHGH(MXUSBX), ABXLOW(MXUSBX),
32517 C    &                ABXHGH(MXUSBX), DEBXBN(MXUSBX), DABXBN(MXUSBX),
32518 C    &                AUSBDX(MXUSBX),
32519 C    &                NEBXBN(MXUSBX), NABXBN(MXUSBX), NR1USX(MXUSBX),
32520 C    &                NR2USX(MXUSBX), ITUSBX(MXUSBX), IDUSBX(MXUSBX),
32521 C    &                KBUSBX(MXUSBX), IPUSBX(MXUSBX), IGMUSX(MXUSBX),
32522 C    &                LFUSBX(MXUSBX), LWUSBX(MXUSBX), LLNUSX(MXUSBX),
32523 C    &                NUSRBX, LUSBDX
32524 C     COMMON /USXCH/  TITUSX(MXUSBX)
32525 **
32526 C     INCLUDE '(USRBIN)'
32527 * USRBIN.ADD
32528 **sr 18.5. commented since not used for evap.
32529 C     PARAMETER ( MXUSBN = 100 )
32530 C     LOGICAL LUSBIN, LEVTBN, LNTZER, LUSEVT, LUSTKB, LTRKBN
32531 C     CHARACTER*10 TITUSB
32532 C     COMMON /USRBN/  XLOW  (MXUSBN), XHIGH (MXUSBN), YLOW  (MXUSBN),
32533 C    &                YHIGH (MXUSBN), ZLOW  (MXUSBN), ZHIGH (MXUSBN),
32534 C    &                DXUSBN(MXUSBN), DYUSBN(MXUSBN), DZUSBN(MXUSBN),
32535 C    &                TCUSBN(MXUSBN), BKUSBN(MXUSBN), B2USBN(MXUSBN),
32536 C    &                NXBIN (MXUSBN), NYBIN (MXUSBN), NZBIN (MXUSBN),
32537 C    &                ITUSBN(MXUSBN), IDUSBN(MXUSBN), KBUSBN(MXUSBN),
32538 C    &                IPUSBN(MXUSBN), LEVTBN(MXUSBN), LNTZER(MXUSBN),
32539 C    &                LTRKBN(MXUSBN), NUSRBN, LUSBIN, LUSEVT, LUSTKB
32540 C     COMMON /USRCH/  TITUSB(MXUSBN)
32541 **
32542 C     INCLUDE '(USRSNC)'
32543 * USRSNC.ADD
32544 **sr 18.5. commented since not used for evap.
32545 C     PARAMETER ( MXRSNC = 400 )
32546 C     PARAMETER ( NMZMIN =  -5 )
32547 C     LOGICAL LURSNC
32548 C     CHARACTER*10 TIURSN
32549 C     COMMON /USRSNC/  VURSNC(MXRSNC), IZRHGH(MXRSNC), IMRHGH(MXRSNC),
32550 C    &                 NRURSN(MXRSNC), ITURSN(MXRSNC), KBURSN(MXRSNC),
32551 C    &                 IPURSN(MXRSNC), NURSNC, LURSNC
32552 C     COMMON /USRSCH/  TIURSN(MXRSNC)
32553 C     INCLUDE '(USRTRC)'
32554 * USRTRC.ADD
32555 **sr 18.5. commented since not used for evap.
32556 C     PARAMETER ( MXUSTC = 400 )
32557 C     LOGICAL LUSRTC, LUSTRK, LUSCLL, LLNUTC
32558 C     CHARACTER*10 TITUTC
32559 C     COMMON /USRTC/  ETCLOW(MXUSTC), ETCHGH(MXUSTC), DETCBN(MXUSTC),
32560 C    &                VUSRTC(MXUSTC),
32561 C    &                IUSTRK(MXUSTC), IUSCLL(MXUSTC), NETCBN(MXUSTC),
32562 C    &                NRUSTC(MXUSTC), ITUSTC(MXUSTC), IDUSTC(MXUSTC),
32563 C    &                KBUSTC(MXUSTC), IPUSTC(MXUSTC), IGMUTC(MXUSTC),
32564 C    &                LLNUTC(MXUSTC), NUSRTC, NUSTRK, NUSCLL, LUSRTC,
32565 C    &                LUSTRK, LUSCLL
32566 C     COMMON /USTCH/  TITUTC(MXUSTC)
32567 **
32568 C     INCLUDE '(USRYLD)'
32569 * USRYLD.ADD
32570 **sr 18.5. commented since not used for evap.
32571 C     PARAMETER ( MXUSYL = 500 )
32572 C     LOGICAL LUSRYL, LLNUYL, LSCUYL
32573 C     CHARACTER*10 TITUYL
32574 C     COMMON /USRYL/  EYLLOW(MXUSYL), EYLHGH(MXUSYL), DEYLBN(MXUSYL),
32575 C    &                USNRYL(MXUSYL), SGUSYL(MXUSYL), AYLLOW(MXUSYL),
32576 C    &                AYLHGH(MXUSYL), PUSRYL, UUSRYL, VUSRYL, WUSRYL,
32577 C    &                ETXUYL, ETYUYL, ETZUYL, GAMUYL, SQSUYL, UCMUYL,
32578 C    &                VCMUYL, WCMUYL, IJUSYL, JTUSYL,
32579 C    &                NEYLBN(MXUSYL), NR1UYL(MXUSYL), NR2UYL(MXUSYL),
32580 C    &                IXUSYL(MXUSYL), ITUSYL(MXUSYL), IDUSYL(MXUSYL),
32581 C    &                KBUSYL(MXUSYL), IPUSYL(MXUSYL), IGMUYL(MXUSYL),
32582 C    &                IEUSYL(MXUSYL), IAUSYL(MXUSYL), LLNUYL(MXUSYL),
32583 C    &                NUSRYL, LUSRYL, LSCUYL
32584 C     COMMON /USYCH/  TITUYL(MXUSYL)
32585 **
32586 C     INCLUDE '(WWINDW)'
32587 * WWINDW.ADD
32588 **sr 18.5. commented since not used for evap.
32589 C     PARAMETER ( MXWWSP = 3 )
32590 C     PARAMETER ( WWSPMX = 50.D+00 )
32591 C     LOGICAL LWWNDW, LWWPRM
32592 C     COMMON / WWINDW / ETHWW1 (NALLWP), ETHWW2 (NALLWP),
32593 C    &                  WWEXWD (NALLWP), EXTWWN (NALLWP),
32594 C    &                  IWLBGN, IWHBGN, IWMBGN, LWWNDW, LWWPRM
32595 **
32596
32597 * /blnkcm/
32598 * *** If blank common dimension has to be superseded substitute in the
32599 * *** following two lines the new dimension in real*8 units to Nblnmx
32600 **sr 18.5. commented since not used for evap.
32601 C     PARAMETER (MXDUMM = KALGNM * NBLNMX)
32602 C     DATA KTMBGN / NBLNMX /
32603 C     DATA MBLNMX / MXDUMM /
32604 C     DATA KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST, KISBGN, KISLST,
32605 C    &     KDTBGN, KDTLST, KUBBGN, KUBLST, KUXBGN, KUXLST, KTCBGN,
32606 C    &     KTCLST, KRNBGN, KRNLST, KYLBGN, KYLLST, KXSBGN, KXSLST,
32607 C    &     KIHBGN, KIHLST, KINBGN, KINLST, KIEBGN, KIELST, KETBGN,
32608 C    &     KETLST, KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST,
32609 C    &     KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST, KWLBGN,
32610 C    &     KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST, KWSBGN, KWSLST,
32611 C    &     KDPBGN, KDPLST, KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN,
32612 C    &     KBRLST / 57*0 /
32613
32614 * /blntmp/
32615 **sr 18.5. commented since not used for evap.
32616 C     DATA KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM, KGDWTM,
32617 C    &     KBDWTM, KGCBTM, KWLOTM, KWHITM, KWMUTM, KWSHTM, KEXTTM,
32618 C    &     KSTXTM, KSTNTM, KECTTM, KPCTTM, KLPBTM / 19*0 /
32619
32620 * /cmmdnr/
32621 **sr 18.5. commented since not used for evap.
32622 C     DATA DDNEAR / 0.D+00 /, LFLDNR / .FALSE. /
32623
32624 * /ctitle/
32625 **sr 18.5. commented since not used for evap.
32626 C     DATA RUNTIT (1:40) / '****************************************' /
32627 C     DATA RUNTIT(41:80) / '****************************************' /
32628 C     DATA ITEXPI, ITEXMX / 100000000, 150 /
32629 * /detect/
32630 **sr 18.5. commented since not used for evap.
32631 C     PARAMETER (NNN1 = NRGNMX*NDTCMX)
32632 C     PARAMETER (NNN2 = NSCRMX*NDTCMX)
32633 C     DATA LDTCTR /.FALSE./, NDTSCO /0/, NDTDET /0/
32634 C     DATA EDTMIN/NDTCMX*0.D0/, EDTBIN/NDTCMX*0.D0/, EDTCUT/NDTCMX*0.D0/
32635 C     DATA KDTREG/NNN1*0/, KDTDET/NNN2*0/, KDTSCD/NSCRMX*0/
32636 C     DATA TITDET/NDTCMX*'          '/, TITSCO/NSCRMX*'          '/
32637
32638 * /detloc/
32639 **sr 18.5. commented since not used for evap.
32640 C     DATA ACCUMP /NDTCM2*0.D0/, ACCUMN /NDTCM2*0.D0/, ICOINC /NDTCM2*0/
32641 C     DATA NCLAS /0/
32642
32643 * /emgtrn/
32644 **sr 18.5. commented since not used for evap.
32645 C     DATA LMCSMG / .FALSE. /
32646
32647 * /emsho/
32648 **sr 18.5. commented since not used for evap.
32649 C     DATA LIMPRE, LEXPTE / 2 * .FALSE. /
32650
32651 * /episor/
32652 **sr 18.5. commented since not used for evap.
32653 C     DATA TKESUM / 0.D+00 /, LUSSRC / .FALSE. /
32654
32655 * /fheavy/
32656       DATA AMHEAV / 12 * 0.D+00 /
32657       DATA ANHEAV / 'NEUTRON ', 'PROTON  ', 'DEUTERON', '3-H     ',
32658      &              '3-He    ', '4-He    ', 'H-FRAG-1', 'H-FRAG-2',
32659      &              'H-FRAG-3', 'H-FRAG-4', 'H-FRAG-5', 'H-FRAG-6'/
32660       DATA ICHEAV / 0, 1, 1, 1, 2, 2, 6*0 /,
32661      &     IBHEAV / 1, 1, 2, 3, 3, 4, 6*0 /
32662       DATA NPHEAV / 0 /
32663
32664 * /finuc/
32665       DATA NP / 0 /, TV / 0.D+00 /, TVCMS / 0.D+00 /, TVRECL / 0.D+00/,
32666      &     TVHEAV / 0.D+00 /, TVBIND / 0.D+00 /
32667
32668 * /genthr/
32669 * Up to 20-apr-'95
32670 *     DATA PEANCT, PEAPIT / 2*1.D+00 /
32671 *     DATA PTHRSH / 16*5.D+00,2*2.5D+00,5.D+00,3*2.5D+00,8*5.D+00,
32672 *    &              9*2.5D+00 /
32673 *     DATA PTHDFF / 39*5.D+00 /
32674 *    &              9*2.5D+00 /
32675 * New values:
32676 **sr 18.5. commented since not used for evap.
32677 C     DATA PEANCT, PEAPIT / 1.3D+00, 1.1D+00 /
32678 C     DATA PTHRSH / 12*5.D+00, 2*3.5D+00, 2*5.D+00, 2*2.5D+00, 5.D+00,
32679 C    &              3*2.5D+00, 3.5D+00, 2*5.D+00, 3.5D+00, 4*5.D+00,
32680 C    &              9*2.5D+00 /
32681 C     DATA PTHDFF / 12*5.D+00, 2*3.5D+00, 8*5.D+00, 3.5D+00, 2*5.D+00,
32682 C    &              3.5D+00, 13*5.D+00 /
32683 C     DATA PLDNCT / 0.26D+00 /
32684 C     DATA IJNUCR / 16*1, 2*0, 1, 3*0, 8*1, 9*0 /
32685
32686 * /lowneu/
32687 **sr 18.5. commented since not used for evap.
32688 C     DATA WWAMFL / 10.D+00 /, EXTWWL / 1.D+00 /
32689 C     DATA IWWLWB, IWWLWT / 2 * 100000000 /
32690 C     DATA ICLMED, INABGN, IDWBGN, IETBGN / 4*0 /
32691 C     DATA IGRTHN / 1 /
32692 C     DATA LIMPRN / .FALSE. /, LBIASN / .FALSE. /, LDOWNN / .FALSE. /,
32693 C    &     LLOWWW / .FALSE. /, LLOWET / .FALSE. /
32694
32695 * /ltclcm/
32696 **sr 18.5. commented since not used for evap.
32697 C     DATA MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1 / 6*0 /
32698
32699 * /mulbou/
32700 **sr 18.5. commented since not used for evap.
32701 C     DATA LLDA, LAGAIN, LSTNEW, LARTEF, LSENSE, LNORML, LMGNOR
32702 C    &     / 7 * .FALSE. /
32703 C     DATA TSENSE / AINFNT /, NSSENS / -1 /
32704 C     DATA DSMALL / ANGLGB /
32705
32706 * /mulhd/
32707 **sr 18.5. commented since not used for evap.
32708 C     DATA LTOPT  / MXXMDF * .FALSE. /, NFSCAT / 0 /
32709 C     DATA ESTEPF / MXXMDF * 0.1D+00 /
32710 C     DATA LSRCRH / MXXMDF * .FALSE. /, LNSCRH / MXXMDF * .FALSE. /
32711 C     DATA THMSPR / 0.02D+00 /, THMSSC / 1.D+00 /
32712
32713 * /parevt/
32714       DATA DPOWER /-13.D+00 /, FSPRD0 / 0.6D+00 /, FSHPFN / 0.0D+00 /,
32715      &     RN1GSC /-1.0D+00 /, RN2GSC /-1.0D+00 /
32716       DATA LDIFFR /  .TRUE., .TRUE., 6 * .TRUE., .TRUE., 8 * .TRUE.,
32717      &               .TRUE., 4 * .TRUE., .TRUE., 3 * .TRUE.,
32718      &              4 * .FALSE., 9 * .TRUE./
32719 **sr 17.5.95
32720 * default value for LEVPRT changed (reset sr 25.7.97)
32721 * default value for LHEAVY changed 25.7.97
32722 C     DATA LPOWER / .TRUE.  /, LINCTV / .TRUE.  /, LEVPRT / .TRUE.  /,
32723 C    &     LHEAVY / .FALSE. /, LDEEXG / .TRUE.  /, LGDHPR / .TRUE.  /,
32724 C    &     LPREEX / .TRUE.  /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /,
32725 C    &     LPARWV / .TRUE.  /, LSNGCH / .TRUE.  /, LSCHDF / .TRUE.  /
32726       DATA LPOWER / .TRUE.  /, LINCTV / .TRUE.  /, LEVPRT / .TRUE.  /,
32727      &     LHEAVY / .TRUE.  /, LDEEXG / .TRUE.  /, LGDHPR / .TRUE.  /,
32728      &     LPREEX / .TRUE.  /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /,
32729      &     LPARWV / .TRUE.  /, LSNGCH / .TRUE.  /, LSCHDF / .TRUE.  /
32730 **
32731 **sr 27.5.97
32732 * default value for ILVMOD changed
32733 C     DATA ILVMOD / 0 /, JLVMOD / 1 /, LLVMOD / .TRUE. /
32734       DATA ILVMOD / 1 /, JLVMOD / 1 /, LLVMOD / .TRUE. /
32735 **
32736
32737 * /resnuc/
32738       DATA IPREEH / 0 /, IPRTRI / 0 /, IPRDEU / 0 /, IPR3HE / 0 /,
32739      &     IPR4HE / 0 /
32740       DATA IEVAPL / 0 /, IEVAPH / 0 /, IEVNEU / 0 /, IEVPRO / 0 /,
32741      &     IEVTRI / 0 /, IEVDEU / 0 /, IEV3HE / 0 /, IEV4HE / 0 /,
32742      &     IDEEXG / 0 /
32743       DATA LRNFSS / .FALSE. /
32744
32745 * /scohlp/
32746 **sr 18.5. commented since not used for evap.
32747 C     DATA ISCRNG, JSCRNG / 2*0 /, LSCZER / .FALSE. /
32748
32749 * /trackr/
32750 **sr 18.5. commented since not used for evap.
32751 C     DATA ETRACK /0.D+00/, WTRACK /0.D+00/, ATRACK /0.D+00/,
32752 C    &     CTRACK /0.D+00/, NTRACK /0/, MTRACK /0/, JTRACK /0/
32753
32754 * /usrbin/
32755 **sr 18.5. commented since not used for evap.
32756 C     DATA LUSBIN, LUSEVT, LUSTKB /3*.FALSE./, NUSRBN /0/
32757
32758 * /usrbdx/
32759 **sr 18.5. commented since not used for evap.
32760 C     DATA LUSBDX /.FALSE./, NUSRBX /0/
32761
32762 * /usrsnc/
32763 **sr 18.5. commented since not used for evap.
32764 C     DATA LURSNC /.FALSE./, NURSNC /0/
32765
32766 * /usrtrc/
32767 **sr 18.5. commented since not used for evap.
32768 C     DATA LUSRTC, LUSTRK, LUSCLL / 3*.FALSE. /
32769 C     DATA NUSRTC, NUSTRK, NUSCLL / 3*0 /
32770
32771 * /usryld/
32772 **sr 18.5. commented since not used for evap.
32773 C     DATA LUSRYL / .FALSE./, LSCUYL / .FALSE. /, NUSRYL /0/,
32774 C    &     IJUSYL /0/, JTUSYL /0/
32775 C     DATA PUSRYL, UUSRYL, VUSRYL, WUSRYL / 4*ZERZER /
32776
32777 * /wwindw/
32778 **sr 18.5. commented since not used for evap.
32779 C     DATA IWLBGN, IWHBGN, IWMBGN / 3*0 /
32780 C     DATA LWWPRM / .TRUE. /
32781
32782 *=                                               end*block.bdnopt      *
32783       END
32784
32785 *$ CREATE DT_BDPREE.FOR
32786 *COPY DT_BDPREE
32787 *
32788 *=== bdpree ===========================================================*
32789 *
32790       BLOCK DATA DT_BDPREE
32791
32792 C     INCLUDE '(DBLPRC)'
32793 * DBLPRC.ADD
32794       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32795       SAVE
32796 * (original name: GLOBAL)
32797       PARAMETER ( KALGNM = 2 )
32798       PARAMETER ( ANGLGB = 5.0D-16 )
32799       PARAMETER ( ANGLSQ = 2.5D-31 )
32800       PARAMETER ( AXCSSV = 0.2D+16 )
32801       PARAMETER ( ANDRFL = 1.0D-38 )
32802       PARAMETER ( AVRFLW = 1.0D+38 )
32803       PARAMETER ( AINFNT = 1.0D+30 )
32804       PARAMETER ( AZRZRZ = 1.0D-30 )
32805       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
32806       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
32807       PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
32808       PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
32809       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
32810       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
32811       PARAMETER ( CSNNRM = 2.0D-15 )
32812       PARAMETER ( DMXTRN = 1.0D+08 )
32813       PARAMETER ( ZERZER = 0.D+00 )
32814       PARAMETER ( ONEONE = 1.D+00 )
32815       PARAMETER ( TWOTWO = 2.D+00 )
32816       PARAMETER ( THRTHR = 3.D+00 )
32817       PARAMETER ( FOUFOU = 4.D+00 )
32818       PARAMETER ( FIVFIV = 5.D+00 )
32819       PARAMETER ( SIXSIX = 6.D+00 )
32820       PARAMETER ( SEVSEV = 7.D+00 )
32821       PARAMETER ( EIGEIG = 8.D+00 )
32822       PARAMETER ( ANINEN = 9.D+00 )
32823       PARAMETER ( TENTEN = 10.D+00 )
32824       PARAMETER ( HLFHLF = 0.5D+00 )
32825       PARAMETER ( ONETHI = ONEONE / THRTHR )
32826       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
32827       PARAMETER ( ONEFOU = ONEONE / FOUFOU )
32828       PARAMETER ( THRTWO = THRTHR / TWOTWO )
32829       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
32830       PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
32831       PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
32832       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
32833       PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
32834       PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
32835       PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
32836       PARAMETER ( EULERO = 0.577215664901532860606512      D+00 )
32837       PARAMETER ( EULEXP = 1.781072417990197985236504      D+00 )
32838       PARAMETER ( EULLOG =-0.5495393129816448223376619     D+00 )
32839       PARAMETER ( E1M2EU = 0.8569023337737540831433017     D+00 )
32840       PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
32841       PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
32842       PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
32843       PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
32844       PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
32845       PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
32846       PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
32847       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
32848       PARAMETER ( CLIGHT = 2.99792458         D+10 )
32849       PARAMETER ( AVOGAD = 6.0221367          D+23 )
32850       PARAMETER ( BOLTZM = 1.380658           D-23 )
32851       PARAMETER ( AMELGR = 9.1093897          D-28 )
32852       PARAMETER ( PLCKBR = 1.05457266         D-27 )
32853       PARAMETER ( ELCCGS = 4.8032068          D-10 )
32854       PARAMETER ( ELCMKS = 1.60217733         D-19 )
32855       PARAMETER ( AMUGRM = 1.6605402          D-24 )
32856       PARAMETER ( AMMUMU = 0.113428913        D+00 )
32857       PARAMETER ( AMPRMU = 1.007276470        D+00 )
32858       PARAMETER ( AMNEMU = 1.008664904        D+00 )
32859       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
32860       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
32861       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
32862       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
32863       PARAMETER ( PLABRC = 0.197327053        D+00 )
32864       PARAMETER ( AMELCT = 0.51099906         D-03 )
32865       PARAMETER ( AMUGEV = 0.93149432         D+00 )
32866       PARAMETER ( AMMUON = 0.105658389        D+00 )
32867       PARAMETER ( AMPRTN = 0.93827231         D+00 )
32868       PARAMETER ( AMNTRN = 0.93956563         D+00 )
32869       PARAMETER ( AMDEUT = 1.87561339         D+00 )
32870       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
32871      &                   * 1.D-09 )
32872       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
32873       PARAMETER ( BLTZMN = 8.617385           D-14 )
32874       PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
32875       PARAMETER ( GFOHB3 = 1.16639            D-05 )
32876       PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
32877       PARAMETER ( SIN2TW = 0.2319             D+00 )
32878       PARAMETER ( GEVMEV = 1.0                D+03 )
32879       PARAMETER ( EMVGEV = 1.0                D-03 )
32880       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
32881       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
32882       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
32883       LOGICAL LGBIAS, LGBANA
32884       COMMON /FKGLOB/ LGBIAS, LGBANA
32885 C     INCLUDE '(DIMPAR)'
32886 * DIMPAR.ADD
32887       PARAMETER ( MXXRGN = 5000 )
32888       PARAMETER ( MXXMDF = 82   )
32889       PARAMETER ( MXXMDE = 54   )
32890       PARAMETER ( MFSTCK = 1000 )
32891       PARAMETER ( MESTCK = 100  )
32892       PARAMETER ( NALLWP = 39   )
32893       PARAMETER ( NELEMX = 80   )
32894       PARAMETER ( MPDPDX = 8    )
32895       PARAMETER ( ICOMAX = 180  )
32896       PARAMETER ( NSTBIS = 304  )
32897       PARAMETER ( IDMAXP = 220  )
32898       PARAMETER ( IDMXDC = 640  )
32899       PARAMETER ( MKBMX1 = 1    )
32900       PARAMETER ( MKBMX2 = 1    )
32901 C     INCLUDE '(IOUNIT)'
32902 * IOUNIT.ADD
32903       PARAMETER ( LUNIN  =  5 )
32904       PARAMETER ( LUNOUT =  6 )
32905 **sr 19.5. set error output-unit from 15 to 6
32906       PARAMETER ( LUNERR = 6  )
32907       PARAMETER ( LUNBER = 14 )
32908       PARAMETER ( LUNECH =  8 )
32909       PARAMETER ( LUNFLU = 13 )
32910       PARAMETER ( LUNGEO = 16 )
32911       PARAMETER ( LUNPMF = 12 )
32912       PARAMETER ( LUNRAN =  2 )
32913       PARAMETER ( LUNXSC =  9 )
32914       PARAMETER ( LUNDET = 17 )
32915       PARAMETER ( LUNRAY = 10 )
32916       PARAMETER ( LUNRDB =  1 )
32917       PARAMETER ( LUNPGO =  7 )
32918       PARAMETER ( LUNPGS =  4 )
32919       PARAMETER ( LUNSCR =  3 )
32920 *
32921 *----------------------------------------------------------------------*
32922 *                                                                      *
32923 *     Created on 16 september 1991 by    Alfredo Ferrari & Paola Sala  *
32924 *                                                   Infn - Milan       *
32925 *                                                                      *
32926 *     Last change on 03-feb-94     by    Alfredo Ferrari               *
32927 *                                                                      *
32928 *                                                                      *
32929 *----------------------------------------------------------------------*
32930 *
32931 * (original name: CMPISG,CHPISG)
32932       PARAMETER ( TPPPI0 = 0.279656044337515D+00 )
32933       PARAMETER ( TNNPI0 = 0.279642680857450D+00 )
32934       PARAMETER ( TPPPIP = 0.292295207182790D+00 )
32935       PARAMETER ( TPPDEP = 0.287514778898469D+00 )
32936       PARAMETER ( TNNPIM = 0.286723140900975D+00 )
32937       PARAMETER ( TNNDEM = 0.281949292916434D+00 )
32938       PARAMETER ( TPNPI0 = 0.279456888147740D+00 )
32939       PARAMETER ( TPNDE0 = 0.274693916135245D+00 )
32940       PARAMETER ( TPNPIP = 0.292086756473890D+00 )
32941       PARAMETER ( TNPPI0 = 0.279842093144975D+00 )
32942       PARAMETER ( TNPDE0 = 0.275072555824202D+00 )
32943       PARAMETER ( TNPPIP = 0.292489370554958D+00 )
32944       PARAMETER ( PIRSMX = 1.2D+00 )
32945       PARAMETER ( NPIREA = 10 )
32946       PARAMETER ( NPIRTA = 68 )
32947       PARAMETER ( NPIRLN = 21 )
32948       PARAMETER ( NPIRLG = NPIRTA - NPIRLN )
32949       PARAMETER ( NPISIS = NPIRLN + 20 )
32950       PARAMETER ( NPISEX = NPIRLN + 21 )
32951       PARAMETER ( NPIIMN = 14 )
32952       PARAMETER ( NPIIRC =  6 )
32953       PARAMETER ( DELWLL = 0.035D+00 )
32954       CHARACTER CHPIRE*8
32955       LOGICAL LDLRES
32956       COMMON /FKCMPI/ PMNPIS, PMMPIS, PISPIS, PEXPIS, PMXPIS, DPPISG,
32957      &                RTPISG, AMNPIS, AMMPIS, AISPIS, AEXPIS, AMXPIS,
32958      &                ARPISG, BPISLO (NPIRLN:NPIRTA,NPIREA),
32959      &                CPISLO (NPIRLN:NPIRTA,NPIREA), PPITHR (NPIREA),
32960      &                SPISLO (NPIRLN:NPIRTA,NPIREA), APITHR (NPIREA),
32961      &                SGPIIN (NPIIMN:NPIRTA,NPIIRC), RHPICR (1:5)   ,
32962      &                SGPICU (0:20,NPIRTA,NPIREA)  , SGRTRS (NPIREA),
32963      &                SGPIDF (0:20,NPIRTA,NPIREA)  , BRREIN (NPIREA),
32964      &                SGPIIS (NPIRTA,NPIREA)       , BRREOU (NPIREA),
32965      &                BRD3OU (2,2,-1:2), BRDEOU (2,-1:2),
32966      &                SGABSR (2,2,4)   , PRRSDL,
32967      &                IPIREA (2,2,3:5) , IPIINE (2,3:5)    , NPIRVR ,
32968      &                KPIIRE (2,NPIREA), KPIORE (2,NPIREA) ,
32969      &                JSTOKP (5), KPTOJS (23), ITTRRS (3:5), LDLRES
32970       COMMON /FKCHPI/ CHPIRE (NPIREA)
32971       DIMENSION SG2BRS (2,2), SGABSW (2,2), SG3BRS (2,2,2)
32972       EQUIVALENCE ( SG2BRS   (1,1), SGABSR (1,1,1) )
32973       EQUIVALENCE ( SGABSW   (1,1), SGABSR (1,1,2) )
32974       EQUIVALENCE ( SG3BRS (1,1,1), SGABSR (1,1,3) )
32975 * (original name: FRBKCM)
32976       PARAMETER ( MXFFBK =     6 )
32977       PARAMETER ( MXZFBK =     9 )
32978       PARAMETER ( MXNFBK =    10 )
32979       PARAMETER ( MXAFBK =    16 )
32980       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
32981       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
32982       PARAMETER ( NXAFBK = MXAFBK + 1 )
32983       PARAMETER ( MXPSST =   300 )
32984       PARAMETER ( MXPSFB = 41000 )
32985       LOGICAL LFRMBK, LNCMSS
32986       COMMON /FKFRBK/  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
32987      &          EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
32988      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
32989      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
32990      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
32991      &          IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
32992      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
32993      &          IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
32994      &          IFBFRB, NBUFBK, LFRMBK, LNCMSS
32995 * (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII)
32996       PARAMETER ( PI     = PIPIPI )
32997       PARAMETER ( PISQ   = PIPISQ )
32998       PARAMETER ( SKTOHL = 0.5456645846610345D+00 )
32999       PARAMETER ( RZNUCL = 1.12        D+00 )
33000       PARAMETER ( RMSPRO = 0.8         D+00 )
33001       PARAMETER ( R0PROT = RMSPRO / SQRT12  )
33002       PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT
33003      &          / R0PROT )
33004       PARAMETER ( RLLE04 = RZNUCL )
33005       PARAMETER ( RLLE16 = RZNUCL )
33006       PARAMETER ( RLGT16 = RZNUCL )
33007       PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 )
33008       PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 )
33009       PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 )
33010       PARAMETER ( SKLE04 = 1.4D+00 )
33011       PARAMETER ( SKLE16 = 1.9D+00 )
33012       PARAMETER ( SKGT16 = 2.4D+00 )
33013       PARAMETER ( HLLE04 = SKTOHL * SKLE04 )
33014       PARAMETER ( HLLE16 = SKTOHL * SKLE16 )
33015       PARAMETER ( HLGT16 = SKTOHL * SKGT16 )
33016       PARAMETER ( ALPHA0 = 0.1D+00 )
33017       PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 )
33018       PARAMETER ( GAMSK0 = 0.9D+00 )
33019       PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 )
33020       PARAMETER ( POTME0 = 0.6666666666666667D+00 )
33021       PARAMETER ( POTBA0 = 1.D+00 )
33022       PARAMETER ( PNFRAT = 1.533D+00 )
33023       PARAMETER ( RADPIM = 0.035D+00 )
33024       PARAMETER ( RDPMHL = 14.D+00   )
33025       PARAMETER ( APMRST = 4.D+00 / 44.D+00 )
33026       PARAMETER ( APMPRO = 1.D+00 / 6.D+00 )
33027       PARAMETER ( APPPRO = 5.D+00 / 6.D+00 )
33028       PARAMETER ( AP0PFS = 0.5D+00 )
33029       PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 )
33030       PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 )
33031       PARAMETER ( XPAUCO = 1.88495407241652 D+00 )
33032       PARAMETER ( MXSCIN = 50     )
33033       LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY,
33034      &        LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC
33035       COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260),
33036      &                RADTAB (2:260), SKITAB (2:260), HALTAB (2:260),
33037      &                SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260),
33038      &                CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260),
33039      &                PFRTAB (2:260)
33040       COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP,
33041      &                ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO,
33042      &                RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR,
33043      &                YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN,
33044      &                RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM,
33045      &                PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2,
33046      &                PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT,
33047      &                BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2,
33048      &                YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3,
33049      &                XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC,
33050      &                SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ,
33051      &                R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE,
33052      &                PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY,
33053      &                EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ,
33054      &                PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM,
33055      &                EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3,
33056      &                PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM,
33057      &                BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN
33058       COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2),
33059      &                RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN,
33060      &                EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF,
33061      &                BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC,
33062      &                WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES,
33063      &                POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND,
33064      &                BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4),
33065      &                SIGPAB (3), SIGNAB (3), HHLP   (2), FORTOT (2),
33066      &                FPNBLC, DPNBLC, FFTFLG, IFTFLG,
33067      &                IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2,
33068      &                KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3,
33069      &                NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM,
33070      &                IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ,
33071      &                LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC
33072       COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT
33073       COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN),
33074      &                YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN),
33075      &                AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX,
33076      &                NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN),
33077      &                NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN),
33078      &                ISCTYP (0:MXSCIN), NUSCIN, NEXPEM,
33079      &                LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH,
33080      &                LNCDCY, LNUSCT
33081       DIMENSION AWSTAB (2:260), SIGMAB (3)
33082       EQUIVALENCE ( DEFPRO, DEFNUC (1) )
33083       EQUIVALENCE ( DEFNEU, DEFNUC (2) )
33084       EQUIVALENCE ( RHOIPP, RHONCP (1) )
33085       EQUIVALENCE ( RHOINP, RHONCP (2) )
33086       EQUIVALENCE ( RHOIP2, RHONC2 (1) )
33087       EQUIVALENCE ( RHOIN2, RHONC2 (2) )
33088       EQUIVALENCE ( RHOIP3, RHONC3 (1) )
33089       EQUIVALENCE ( RHOIN3, RHONC3 (2) )
33090       EQUIVALENCE ( RHOIPT, RHONCT (1) )
33091       EQUIVALENCE ( RHOINT, RHONCT (2) )
33092       EQUIVALENCE ( OMALHL, SK3PAR )
33093       EQUIVALENCE ( ALPHAL, HABPAR )
33094       EQUIVALENCE ( ALPTAB (2), AWSTAB (2) )
33095       EQUIVALENCE ( SIGMPE, SIGMPR (1) )
33096       EQUIVALENCE ( SIGMPC, SIGMPR (2) )
33097       EQUIVALENCE ( SIGMPI, SIGMPR (3) )
33098       EQUIVALENCE ( SIGMPA, SIGMPR (4) )
33099       EQUIVALENCE ( SIGMNE, SIGMNU (1) )
33100       EQUIVALENCE ( SIGMNC, SIGMNU (2) )
33101       EQUIVALENCE ( SIGMNI, SIGMNU (3) )
33102       EQUIVALENCE ( SIGMNA, SIGMNU (4) )
33103       EQUIVALENCE ( SIGMA2, SIGPAB (1) )
33104       EQUIVALENCE ( SIGMA3, SIGPAB (2) )
33105       EQUIVALENCE ( SIGMAS, SIGPAB (3) )
33106       EQUIVALENCE ( SIGPAB (1), SIGMAB (1) )
33107 * (original name: NUCLEV)
33108       LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL
33109       COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2),
33110      &                DEFMAG (2), ENNCLV (160,2), RANCLV (160,2),
33111      &                CUMRAD (0:160,2), RUSNUC (2),
33112      &                ENPLVL (114), ENNLVL(164), JUSNUC (160,2),
33113      &                NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2),
33114      &                NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2),
33115      &                JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8),
33116      &                MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2),
33117      &                NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL,
33118      &                LFLVSL, LRLVSL, LEQSBL
33119       DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8),
33120      &          MGSSPR (19) , MGSSNE (25)
33121       EQUIVALENCE ( RUSNUC (1), RUSPRO )
33122       EQUIVALENCE ( RUSNUC (2), RUSNEU )
33123       EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) )
33124       EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) )
33125       EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) )
33126       EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) )
33127       EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) )
33128       EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) )
33129       EQUIVALENCE ( NTANUC (1), NTAPRO )
33130       EQUIVALENCE ( NTANUC (2), NTANEU )
33131       EQUIVALENCE ( NAVNUC (1), NAVPRO )
33132       EQUIVALENCE ( NAVNUC (2), NAVNEU )
33133       EQUIVALENCE ( NLSNUC (1), NLSPRO )
33134       EQUIVALENCE ( NLSNUC (2), NLSNEU )
33135       EQUIVALENCE ( NCONUC (1), NCOPRO )
33136       EQUIVALENCE ( NCONUC (2), NCONEU )
33137       EQUIVALENCE ( NSKNUC (1), NSKPRO )
33138       EQUIVALENCE ( NSKNUC (2), NSKNEU )
33139       EQUIVALENCE ( NHANUC (1), NHAPRO )
33140       EQUIVALENCE ( NHANUC (2), NHANEU )
33141       EQUIVALENCE ( NUSNUC (1), NUSPRO )
33142       EQUIVALENCE ( NUSNUC (2), NUSNEU )
33143       EQUIVALENCE ( NACNUC (1), NACPRO )
33144       EQUIVALENCE ( NACNUC (2), NACNEU )
33145       EQUIVALENCE ( JMXNUC (1), JMXPRO )
33146       EQUIVALENCE ( JMXNUC (2), JMXNEU )
33147       EQUIVALENCE ( MAGNUC (1), MAGPRO )
33148       EQUIVALENCE ( MAGNUC (2), MAGNEU )
33149 * (original name: PARNUC)
33150       PARAMETER ( PIGRK  = PIPIPI )
33151       PARAMETER ( ALEVEL = 8.D-03 )
33152       PARAMETER ( RCNUCL = 1.12D+00 )
33153       PARAMETER ( R0SIG  = 1.3D+00 )
33154       PARAMETER ( R0SIGK = 1.5D+00 )
33155       PARAMETER ( RCOULB = 1.5D+00 )
33156       PARAMETER ( COULBH = 0.88235D-03 )
33157       PARAMETER ( RHONU0 = 0.75D+00 / PIGRK / RCNUCL / RCNUCL / RCNUCL )
33158       PARAMETER ( TAUFO0 = 10.0D+00 )
33159       PARAMETER ( EKEEXP = 0.03D+00 )
33160       PARAMETER ( EKREXP = 0.05D+00 )
33161       PARAMETER ( EKEMNM = 0.01D+00 )
33162       PARAMETER ( NCPMX = 120 )
33163       COMMON /FKPARN/ EKORI , PXORI , PYORI , PZORI , PTORI , TAUFOR,
33164      &                ENNUC  (NCPMX), PNUCL  (NCPMX), EKFNUC (NCPMX),
33165      &                XSTNUC (NCPMX), YSTNUC (NCPMX), ZSTNUC (NCPMX),
33166      &                PXNUCL (NCPMX), PYNUCL (NCPMX), PZNUCL (NCPMX),
33167      &                RSTNUC (NCPMX), FREEPA (NCPMX), CRRPAN (NCPMX),
33168      &                CRRPAP (NCPMX), BSTNUC (NCPMX), AGENUC (NCPMX),
33169      &                TAUFPA (NCPMX), RHNUCL(NCPMX,2), BNDGAV, DEFMIN,
33170      &                KPNUCL (NCPMX), KRFNUC (NCPMX), ILINUC (NCPMX),
33171      &                INUCTS (NCPMX), ISFNUC (NCPMX), KPORI , IBORI ,
33172      &                IBNUCL, NPNUC , NNUCTS
33173 *
33174       DATA LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH / 6*.FALSE. /
33175       DATA POTBAR / POTBA0 /, POTMES / POTME0 /, WLLRES / 0.D+00 /
33176       DATA JUSNUC / 320 * 0 /, INUCLV / 1 /, IEVPRE / 0 /
33177       DATA MAGNUM / 2, 8, 20, 28, 50, 82, 126, 160 /
33178       DATA LPREEQ / .FALSE. /
33179 * /cmpisg/
33180       DATA JSTOKP / 1, 8, 13, 14, 23 /
33181       DATA KPTOJS / 1, 6*0, 2, 4*0, 3, 4, 8*0, 5 /
33182       DATA CHPIRE / 'PI+PPI+P','PI-PPI-P','PI-PPI0N','PI0PPI0P',
33183      &              'PI0PPI+N','PI-NPI-N','PI+NPI+N','PI+NPI0P',
33184      &              'PI0NPI0N','PI0NPI-P' /
33185       DATA KPIIRE / 13, 1, 14, 1, 14, 1, 23, 1, 23, 1, 14, 8,
33186      &              13, 8, 13, 8, 23, 8, 23, 8 /
33187       DATA KPIORE / 13, 1, 14, 1, 23, 8, 23, 1, 13, 8, 14, 8,
33188      &              13, 8, 23, 1, 23, 8, 14, 1 /
33189       DATA IPIREA / 1, 0, 7, 8, 2, 3, 6, 0, 4, 5, 9, 10 /
33190       DATA IPIINE / 1, 2, 3, 4, 5, 6 /
33191 * /frbkcm/
33192       DATA LFRMBK / .FALSE. /
33193       DATA NBUFBK /   500  /
33194       DATA EXMXFB / 80.0 D+00 /
33195       DATA R0FRBK / 1.18 D+00 /
33196       DATA R0CFBK / 2.173D+00 /
33197       DATA C1CFBK / 6.103D-03 /
33198       DATA C2CFBK / 9.443D-03 /
33199 * /parnuc/
33200       DATA TAUFOR / TAUFO0 /
33201 *=== End of Block Data Bdpree =========================================*
33202       END
33203
33204 *$ CREATE DT_XHOINI.FOR
33205 *COPY DT_XHOINI
33206 *
33207 *====phoini============================================================*
33208 *
33209       SUBROUTINE DT_XHOINI
33210 C     SUBROUTINE DT_PHOINI
33211
33212       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33213       SAVE
33214       PARAMETER ( LINP = 10 ,
33215      &            LOUT = 6 ,
33216      &            LDAT = 9 )
33217
33218       RETURN
33219       END
33220
33221 *$ CREATE DT_XVENTB.FOR
33222 *COPY DT_XVENTB
33223 *
33224 *====eventb============================================================*
33225 *
33226       SUBROUTINE DT_XVENTB(NCSY,IREJ)
33227 C     SUBROUTINE DT_EVENTB(NCSY,IREJ)
33228
33229       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33230       SAVE
33231       PARAMETER ( LINP = 10 ,
33232      &            LOUT = 6 ,
33233      &            LDAT = 9 )
33234
33235       WRITE(LOUT,1000)
33236  1000 FORMAT(1X,'EVENTB:   PHOJET-package requested but not linked!')
33237       STOP
33238
33239       END
33240
33241 *$ CREATE DT_XVENT.FOR
33242 *COPY DT_XVENT
33243 *
33244 *===event==============================================================*
33245 *
33246       SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
33247 C     SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
33248
33249       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33250       SAVE
33251
33252       DIMENSION PP(4),PT(4)
33253
33254       RETURN
33255       END
33256
33257 *$ CREATE DT_XOHISX.FOR
33258 *COPY DT_XOHISX
33259 *
33260 *===pohisx=============================================================*
33261 *
33262       SUBROUTINE DT_XOHISX(I,X)
33263 C     SUBROUTINE POHISX(I,X)
33264
33265       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33266       SAVE
33267
33268       RETURN
33269       END
33270
33271 *$ CREATE PHO_LHIST.FOR
33272 *COPY PHO_LHIST
33273 *
33274 *===poluhi=============================================================*
33275 *
33276       SUBROUTINE PHO_LHIST(I,X)
33277 **
33278
33279       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33280       SAVE
33281
33282       RETURN
33283       END
33284
33285 *$ CREATE PDFSET.FOR
33286 *COPY PDFSET
33287 *
33288 C**********************************************************************
33289 C
33290 C   dummy subroutines, remove to link PDFLIB
33291 C
33292 C**********************************************************************
33293       SUBROUTINE PDFSET(PARAM,VALUE)
33294       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33295       DIMENSION PARAM(20),VALUE(20)
33296       CHARACTER*20 PARAM
33297       END
33298
33299 *$ CREATE STRUCTM.FOR
33300 *COPY STRUCTM
33301 *
33302       SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
33303       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33304       END
33305
33306 *$ CREATE STRUCTP.FOR
33307 *COPY STRUCTP
33308 *
33309       SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
33310       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33311       END
33312
33313 *$ CREATE DT_DIQBRK.FOR
33314 *COPY DT_DIQBRK
33315 *
33316 *===diqbrk=============================================================*
33317 *
33318       SUBROUTINE DT_XIQBRK
33319 C     SUBROUTINE DT_DIQBRK
33320
33321       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33322       SAVE
33323
33324       STOP 'diquark-breaking not implemeted !'
33325
33326       RETURN
33327       END
33328
33329 *$ CREATE DT_ELHAIN.FOR
33330 *COPY DT_ELHAIN
33331 *
33332 *===elhain=============================================================*
33333 *
33334       SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
33335
33336 ************************************************************************
33337 * Elastic hadron-hadron scattering.                                    *
33338 * This is a revised version of the original.                           *
33339 * This version dated 03.04.98 is written by S. Roesler                 *
33340 ************************************************************************
33341
33342       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33343       SAVE
33344       PARAMETER ( LINP = 10 ,
33345      &            LOUT = 6 ,
33346      &            LDAT = 9 )
33347       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
33348      &           TINY10=1.0D-10)
33349
33350       PARAMETER (ENNTHR = 3.5D0)
33351       PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
33352      &           BLOWB=0.05D0,BHIB=0.2D0,
33353      &           BLOWM=0.1D0, BHIM=2.0D0)
33354
33355 * particle properties (BAMJET index convention)
33356       CHARACTER*8  ANAME
33357       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33358      &                IICH(210),IIBAR(210),K1(210),K2(210)
33359 * final state from HADRIN interaction
33360       PARAMETER (MAXFIN=10)
33361       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
33362      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
33363
33364 C     DATA TSLOPE /10.0D0/
33365
33366       IREJ = 0
33367
33368     1 CONTINUE
33369
33370       PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
33371       EKIN = ELAB-AAM(IP)
33372 *   kinematical quantities in cms of the hadrons
33373       AMP2 = AAM(IP)**2
33374       AMT2 = AAM(IT)**2
33375       S    = AMP2+AMT2+TWO*ELAB*AAM(IT)
33376       ECM  = SQRT(S)
33377       ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
33378       PCM  = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
33379
33380 * nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
33381       IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
33382      &     ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
33383 *   TSAMCS treats pp and np only, therefore change pn into np and
33384 *   nn into pp
33385          IF (IT.EQ.1) THEN
33386             KPROJ = IP
33387          ELSE
33388             KPROJ = 8
33389             IF (IP.EQ.8) KPROJ = 1
33390          ENDIF
33391          CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
33392          T = TWO*PCM**2*(CTCMS-ONE)
33393
33394 * very crude treatment otherwise: sample t from exponential dist.
33395       ELSE
33396 *   momentum transfer t
33397          TMAX = TWO*TWO*PCM**2
33398          RR = (PLAB-PLOWH)/(PHIH-PLOWH)
33399          IF (IIBAR(IP).NE.0) THEN
33400             TSLOPE = BLOWB+RR*(BHIB-BLOWB)
33401          ELSE
33402             TSLOPE = BLOWM+RR*(BHIM-BLOWM)
33403          ENDIF
33404          FMAX = EXP(-TSLOPE*TMAX)-ONE
33405          R = DT_RNDM(RR)
33406          T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
33407          IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
33408       ENDIF
33409
33410 *   target hadron in Lab after scattering
33411       ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
33412       PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
33413       IF (PLRH(2).LE.TINY10) THEN
33414 C        WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
33415          GOTO 1
33416       ENDIF
33417 *   projectile hadron in Lab after scattering
33418       ELRH(1) = ELAB+AAM(IT)-ELRH(2)
33419       PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
33420 *   scattering angle of projectile in Lab
33421       CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
33422       STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
33423       CALL DT_DSFECF(SPLABP,CPLABP)
33424 *   direction cosines of projectile in Lab
33425       CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
33426      &                          CXRH(1),CYRH(1),CZRH(1))
33427 *   scattering angle of target in Lab
33428       PLLABT = PLAB-CTLABP*PLRH(1)
33429       CTLABT = PLLABT/PLRH(2)
33430       STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
33431 *   direction cosines of target in Lab
33432       CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
33433      &                            CXRH(2),CYRH(2),CZRH(2))
33434 *   fill /HNFSPA/
33435       IRH = 2
33436       ITRH(1) = IP
33437       ITRH(2) = IT
33438
33439       RETURN
33440       END
33441
33442 *$ CREATE DT_TSAMCS.FOR
33443 *COPY DT_TSAMCS
33444 *
33445 *===tsamcs=============================================================*
33446 *
33447       SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
33448
33449 ************************************************************************
33450 * Sampling of cos(theta) for nucleon-proton scattering according to    *
33451 * hetkfa2/bertini parametrization.                                     *
33452 * This is a revised version of the original (HJM 24/10/88)             *
33453 * This version dated 28.10.95 is written by S. Roesler                 *
33454 ************************************************************************
33455
33456       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33457       SAVE
33458       PARAMETER ( LINP = 10 ,
33459      &            LOUT = 6 ,
33460      &            LDAT = 9 )
33461       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
33462      &           TINY10=1.0D-10)
33463
33464       DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
33465       DIMENSION PDCI(60),PDCH(55)
33466
33467       DATA (DCLIN(I),I=1,80) /
33468      &     5.000D-01,  1.000D+00,  0.000D+00,  1.000D+00,  0.000D+00,
33469      &     4.993D-01,  9.881D-01,  5.963D-02,  9.851D-01,  5.945D-02,
33470      &     4.936D-01,  8.955D-01,  5.224D-01,  8.727D-01,  5.091D-01,
33471      &     4.889D-01,  8.228D-01,  8.859D-01,  7.871D-01,  8.518D-01,
33472      &     4.874D-01,  7.580D-01,  1.210D+00,  7.207D-01,  1.117D+00,
33473      &     4.912D-01,  6.969D-01,  1.516D+00,  6.728D-01,  1.309D+00,
33474      &     5.075D-01,  6.471D-01,  1.765D+00,  6.667D-01,  1.333D+00,
33475      &     5.383D-01,  6.054D-01,  1.973D+00,  7.059D-01,  1.176D+00,
33476      &     5.397D-01,  5.990D-01,  2.005D+00,  7.023D-01,  1.191D+00,
33477      &     5.336D-01,  6.083D-01,  1.958D+00,  6.959D-01,  1.216D+00,
33478      &     5.317D-01,  6.075D-01,  1.962D+00,  6.897D-01,  1.241D+00,
33479      &     5.300D-01,  6.016D-01,  1.992D+00,  6.786D-01,  1.286D+00,
33480      &     5.281D-01,  6.063D-01,  1.969D+00,  6.786D-01,  1.286D+00,
33481      &     5.280D-01,  5.960D-01,  2.020D+00,  6.667D-01,  1.333D+00,
33482      &     5.273D-01,  5.920D-01,  2.040D+00,  6.604D-01,  1.358D+00,
33483      &     5.273D-01,  5.862D-01,  2.069D+00,  6.538D-01,  1.385D+00/
33484       DATA (DCLIN(I),I=81,160) /
33485      &     5.223D-01,  5.980D-01,  2.814D+00,  6.538D-01,  1.385D+00,
33486      &     5.202D-01,  5.969D-01,  2.822D+00,  6.471D-01,  1.412D+00,
33487      &     5.183D-01,  5.881D-01,  2.883D+00,  6.327D-01,  1.469D+00,
33488      &     5.159D-01,  5.866D-01,  2.894D+00,  6.250D-01,  1.500D+00,
33489      &     5.133D-01,  5.850D-01,  2.905D+00,  6.170D-01,  1.532D+00,
33490      &     5.106D-01,  5.833D-01,  2.917D+00,  6.087D-01,  1.565D+00,
33491      &     5.084D-01,  5.801D-01,  2.939D+00,  6.000D-01,  1.600D+00,
33492      &     5.063D-01,  5.763D-01,  2.966D+00,  5.909D-01,  1.636D+00,
33493      &     5.036D-01,  5.730D-01,  2.989D+00,  5.814D-01,  1.674D+00,
33494      &     5.014D-01,  5.683D-01,  3.022D+00,  5.714D-01,  1.714D+00,
33495      &     4.986D-01,  5.641D-01,  3.051D+00,  5.610D-01,  1.756D+00,
33496      &     4.964D-01,  5.580D-01,  3.094D+00,  5.500D-01,  1.800D+00,
33497      &     4.936D-01,  5.573D-01,  3.099D+00,  5.431D-01,  1.827D+00,
33498      &     4.909D-01,  5.509D-01,  3.144D+00,  5.313D-01,  1.875D+00,
33499      &     4.885D-01,  5.512D-01,  3.142D+00,  5.263D-01,  1.895D+00,
33500      &     4.857D-01,  5.437D-01,  3.194D+00,  5.135D-01,  1.946D+00/
33501       DATA (DCLIN(I),I=161,195) /
33502      &     4.830D-01,  5.353D-01,  3.253D+00,  5.000D-01,  2.000D+00,
33503      &     4.801D-01,  5.323D-01,  3.274D+00,  4.915D-01,  2.034D+00,
33504      &     4.770D-01,  5.228D-01,  3.341D+00,  4.767D-01,  2.093D+00,
33505      &     4.738D-01,  5.156D-01,  3.391D+00,  4.643D-01,  2.143D+00,
33506      &     4.701D-01,  5.010D-01,  3.493D+00,  4.444D-01,  2.222D+00,
33507      &     4.672D-01,  4.990D-01,  3.507D+00,  4.375D-01,  2.250D+00,
33508      &     4.634D-01,  4.856D-01,  3.601D+00,  4.194D-01,  2.323D+00/
33509
33510       DATA PDCI /
33511      &     4.400D+02,  1.896D-01,  1.931D-01,  1.982D-01,  1.015D-01,
33512      &     1.029D-01,  4.180D-02,  4.228D-02,  4.282D-02,  4.350D-02,
33513      &     2.204D-02,  2.236D-02,  5.900D+02,  1.433D-01,  1.555D-01,
33514      &     1.774D-01,  1.000D-01,  1.128D-01,  5.132D-02,  5.600D-02,
33515      &     6.158D-02,  6.796D-02,  3.660D-02,  3.820D-02,  6.500D+02,
33516      &     1.192D-01,  1.334D-01,  1.620D-01,  9.527D-02,  1.141D-01,
33517      &     5.283D-02,  5.952D-02,  6.765D-02,  7.878D-02,  4.796D-02,
33518      &     6.957D-02,  8.000D+02,  4.872D-02,  6.694D-02,  1.152D-01,
33519      &     9.348D-02,  1.368D-01,  6.912D-02,  7.953D-02,  9.577D-02,
33520      &     1.222D-01,  7.755D-02,  9.525D-02,  1.000D+03,  3.997D-02,
33521      &     5.456D-02,  9.804D-02,  8.084D-02,  1.208D-01,  6.520D-02,
33522      &     8.233D-02,  1.084D-01,  1.474D-01,  9.328D-02,  1.093D-01/
33523
33524       DATA PDCH /
33525      &     1.000D+03,  9.453D-02,  9.804D-02,  8.084D-02,  1.208D-01,
33526      &     6.520D-02,  8.233D-02,  1.084D-01,  1.474D-01,  9.328D-02,
33527      &     1.093D-01,  1.400D+03,  1.072D-01,  7.450D-02,  6.645D-02,
33528      &     1.136D-01,  6.750D-02,  8.580D-02,  1.110D-01,  1.530D-01,
33529      &     1.010D-01,  1.350D-01,  2.170D+03,  4.004D-02,  3.013D-02,
33530      &     2.664D-02,  5.511D-02,  4.240D-02,  7.660D-02,  1.364D-01,
33531      &     2.300D-01,  1.670D-01,  2.010D-01,  2.900D+03,  1.870D-02,
33532      &     1.804D-02,  1.320D-02,  2.970D-02,  2.860D-02,  5.160D-02,
33533      &     1.020D-01,  2.400D-01,  2.250D-01,  3.370D-01,  4.400D+03,
33534      &     1.196D-03,  8.784D-03,  1.517D-02,  2.874D-02,  2.488D-02,
33535      &     4.464D-02,  8.330D-02,  2.008D-01,  2.360D-01,  3.567D-01/
33536
33537       DATA (DCHN(I),I=1,90) /
33538      &     4.770D-01,  4.750D-01,  4.715D-01,  4.685D-01,  4.650D-01,
33539      &     4.610D-01,  4.570D-01,  4.550D-01,  4.500D-01,  4.450D-01,
33540      &     4.405D-01,  4.350D-01,  4.300D-01,  4.250D-01,  4.200D-01,
33541      &     4.130D-01,  4.060D-01,  4.000D-01,  3.915D-01,  3.840D-01,
33542      &     3.760D-01,  3.675D-01,  3.580D-01,  3.500D-01,  3.400D-01,
33543      &     3.300D-01,  3.200D-01,  3.100D-01,  3.000D-01,  2.900D-01,
33544      &     2.800D-01,  2.700D-01,  2.600D-01,  2.500D-01,  2.400D-01,
33545      &     2.315D-01,  2.240D-01,  2.150D-01,  2.060D-01,  2.000D-01,
33546      &     1.915D-01,  1.850D-01,  1.780D-01,  1.720D-01,  1.660D-01,
33547      &     1.600D-01,  1.550D-01,  1.500D-01,  1.450D-01,  1.400D-01,
33548      &     1.360D-01,  1.320D-01,  1.280D-01,  1.250D-01,  1.210D-01,
33549      &     1.180D-01,  1.150D-01,  1.120D-01,  1.100D-01,  1.070D-01,
33550      &     1.050D-01,  1.030D-01,  1.010D-01,  9.900D-02,  9.700D-02,
33551      &     9.550D-02,  9.480D-02,  9.400D-02,  9.200D-02,  9.150D-02,
33552      &     9.100D-02,  9.000D-02,  8.990D-02,  8.900D-02,  8.850D-02,
33553      &     8.750D-02,  8.700D-02,  8.650D-02,  8.550D-02,  8.500D-02,
33554      &     8.499D-02,  8.450D-02,  8.350D-02,  8.300D-02,  8.250D-02,
33555      &     8.150D-02,  8.100D-02,  8.030D-02,  8.000D-02,  7.990D-02/
33556       DATA (DCHN(I),I=91,143) /
33557      &     7.980D-02,  7.950D-02,  7.900D-02,  7.860D-02,  7.800D-02,
33558      &     7.750D-02,  7.650D-02,  7.620D-02,  7.600D-02,  7.550D-02,
33559      &     7.530D-02,  7.500D-02,  7.499D-02,  7.498D-02,  7.480D-02,
33560      &     7.450D-02,  7.400D-02,  7.350D-02,  7.300D-02,  7.250D-02,
33561      &     7.230D-02,  7.200D-02,  7.100D-02,  7.050D-02,  7.020D-02,
33562      &     7.000D-02,  6.999D-02,  6.995D-02,  6.993D-02,  6.991D-02,
33563      &     6.990D-02,  6.870D-02,  6.850D-02,  6.800D-02,  6.780D-02,
33564      &     6.750D-02,  6.700D-02,  6.650D-02,  6.630D-02,  6.600D-02,
33565      &     6.550D-02,  6.525D-02,  6.510D-02,  6.500D-02,  6.499D-02,
33566      &     6.498D-02,  6.496D-02,  6.494D-02,  6.493D-02,  6.490D-02,
33567      &     6.488D-02,  6.485D-02,  6.480D-02/
33568
33569       DATA DCHNA /
33570      &     6.300D+02,  7.810D-02,  1.421D-01,  1.979D-01,  2.479D-01,
33571      &     3.360D-01,  5.400D-01,  7.236D-01,  1.000D+00,  1.540D+03,
33572      &     2.225D-01,  3.950D-01,  5.279D-01,  6.298D-01,  7.718D-01,
33573      &     9.405D-01,  9.835D-01,  1.000D+00,  2.560D+03,  2.625D-01,
33574      &     4.550D-01,  5.963D-01,  7.020D-01,  8.380D-01,  9.603D-01,
33575      &     9.903D-01,  1.000D+00,  3.520D+03,  4.250D-01,  6.875D-01,
33576      &     8.363D-01,  9.163D-01,  9.828D-01,  1.000D+00,  1.000D+00,
33577      &     1.000D+00/
33578
33579       DATA DCHNB /
33580      &     6.300D+02,  3.800D-02,  7.164D-02,  1.275D-01,  2.171D-01,
33581      &     3.227D-01,  4.091D-01,  5.051D-01,  6.061D-01,  7.074D-01,
33582      &     8.434D-01,  1.000D+00,  2.040D+03,  1.200D-01,  2.115D-01,
33583      &     3.395D-01,  5.295D-01,  7.251D-01,  8.511D-01,  9.487D-01,
33584      &     9.987D-01,  1.000D+00,  1.000D+00,  1.000D+00,  2.200D+03,
33585      &     1.344D-01,  2.324D-01,  3.754D-01,  5.674D-01,  7.624D-01,
33586      &     8.896D-01,  9.808D-01,  1.000D+00,  1.000D+00,  1.000D+00,
33587      &     1.000D+00,  2.850D+03,  2.330D-01,  4.130D-01,  6.610D-01,
33588      &     9.010D-01,  9.970D-01,  1.000D+00,  1.000D+00,  1.000D+00,
33589      &     1.000D+00,  1.000D+00,  1.000D+00,  3.500D+03,  3.300D-01,
33590      &     5.450D-01,  7.950D-01,  1.000D+00,  1.000D+00,  1.000D+00,
33591      &     1.000D+00,  1.000D+00,  1.000D+00,  1.000D+00,  1.000D+00/
33592
33593       CST = ONE
33594       IF (EKIN.GT.3.5D0) RETURN
33595 C
33596       IF(KPROJ.EQ.8) GOTO 101
33597       IF(KPROJ.EQ.1) GOTO 102
33598 C*                                             INVALID REACTION
33599       WRITE(LOUT,'(A,I5/A)')
33600      &        ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
33601      &        ' COS(THETA) = 1D0 RETURNED'
33602       RETURN
33603 C-------------------------------- NP ELASTIC SCATTERING----------
33604 101   CONTINUE
33605       IF (EKIN.GT.0.740D0)GOTO 1000
33606       IF (EKIN.LT.0.300D0)THEN
33607 C                                 EKIN .LT. 300 MEV
33608          IDAT=1
33609       ELSE
33610 C                                 300 MEV < EKIN < 740 MEV
33611          IDAT=6
33612       END IF
33613 C
33614       ENER=EKIN
33615       IE=INT(ABS(ENER/0.020D0))
33616       UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
33617 C                                            FORWARD/BACKWARD DECISION
33618       K=IDAT+5*IE
33619       BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
33620       IF (DT_RNDM(CST).LT.BWFW)THEN
33621          VALUE2=-1D0
33622          K=K+1
33623       ELSE
33624          VALUE2=1D0
33625          K=K+3
33626       END IF
33627 C
33628       COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
33629       RND=DT_RNDM(COEF)
33630 C
33631       IF(RND.LT.COEF)THEN
33632          CST=DT_RNDM(RND)
33633          CST=CST*VALUE2
33634       ELSE
33635          R1=DT_RNDM(CST)
33636          R2=DT_RNDM(R1)
33637          R3=DT_RNDM(R2)
33638          R4=DT_RNDM(R3)
33639 C
33640          IF(VALUE2.GT.0.0)THEN
33641             CST=MAX(R1,R2,R3,R4)
33642             GOTO 1500
33643          ELSE
33644             R5=DT_RNDM(R4)
33645 C
33646             IF (IDAT.EQ.1)THEN
33647                CST=-MAX(R1,R2,R3,R4,R5)
33648             ELSE
33649                R6=DT_RNDM(R5)
33650                R7=DT_RNDM(R6)
33651                CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
33652             END IF
33653 C
33654          END IF
33655 C
33656       END IF
33657 C
33658       GOTO 1500
33659 C
33660 C********                                EKIN  .GT.  0.74 GEV
33661 C
33662 1000  ENER=EKIN - 0.66D0
33663 C     IE=ABS(ENER/0.02)
33664       IE=INT(ENER/0.02D0)
33665       EMEV=EKIN*1D3
33666 C
33667       UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
33668       K=IE
33669       BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
33670       RND=DT_RNDM(BWFW)
33671 C                                        FORWARD NEUTRON
33672       IF (RND.GE.BWFW)THEN
33673          DO 1200 K=10,36,9
33674            IF (DCHNA(K).GT.EMEV) THEN
33675               UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
33676               UNIV=DT_RNDM(UNIVE)
33677               DO 1100 I=1,8
33678                  II=K+I
33679                  P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
33680 C
33681                  IF (P.GT.UNIV)THEN
33682                     UNIV=DT_RNDM(UNIVE)
33683                     FLTI=DBLE(I)-UNIV
33684                     GOTO(290,290,290,290,330,340,350,360) I
33685                  END IF
33686  1100         CONTINUE
33687            END IF
33688  1200    CONTINUE
33689 C
33690       ELSE
33691 C                                        BACKWARD NEUTRON
33692          DO 1400 K=13,60,12
33693             IF (DCHNB(K).GT.EMEV) THEN
33694                UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
33695                UNIV=DT_RNDM(UNIVE)
33696                DO 1300 I=1,11
33697                  II=K+I
33698                  P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
33699 C
33700                  IF (P.GT.UNIV)THEN
33701                    UNIV=DT_RNDM(P)
33702                    FLTI=DBLE(I)-UNIV
33703                    GOTO(120,120,140,150,160,160,180,190,200,210,220) I
33704                  END IF
33705  1300          CONTINUE
33706             END IF
33707  1400    CONTINUE
33708       END IF
33709 C
33710 120   CST=1.0D-2*FLTI-1.0D0
33711       GOTO 1500
33712 140   CST=2.0D-2*UNIV-0.98D0
33713       GOTO 1500
33714 150   CST=4.0D-2*UNIV-0.96D0
33715       GOTO 1500
33716 160   CST=6.0D-2*FLTI-1.16D0
33717       GOTO 1500
33718 180   CST=8.0D-2*UNIV-0.80D0
33719       GOTO 1500
33720 190   CST=1.0D-1*UNIV-0.72D0
33721       GOTO 1500
33722 200   CST=1.2D-1*UNIV-0.62D0
33723       GOTO 1500
33724 210   CST=2.0D-1*UNIV-0.50D0
33725       GOTO 1500
33726 220   CST=3.0D-1*(UNIV-1.0D0)
33727       GOTO 1500
33728 C
33729 290   CST=1.0D0-2.5d-2*FLTI
33730       GOTO 1500
33731 330   CST=0.85D0+0.5D-1*UNIV
33732       GOTO 1500
33733 340   CST=0.70D0+1.5D-1*UNIV
33734       GOTO 1500
33735 350   CST=0.50D0+2.0D-1*UNIV
33736       GOTO 1500
33737 360   CST=0.50D0*UNIV
33738 C
33739 1500  RETURN
33740 C
33741 C-----------------------------------  PP ELASTIC SCATTERING -------
33742 C
33743  102  CONTINUE
33744       EMEV=EKIN*1D3
33745 C
33746       IF (EKIN.LE.0.500D0) THEN
33747          RND=DT_RNDM(EMEV)
33748          CST=2.0D0*RND-1.0D0
33749          RETURN
33750 C
33751       ELSEIF (EKIN.LT.1.0D0) THEN
33752          DO 2200 K=13,60,12
33753             IF (PDCI(K).GT.EMEV) THEN
33754                UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
33755                UNIV=DT_RNDM(UNIVE)
33756                SUM=0
33757                DO 2100 I=1,11
33758                  II=K+I
33759                  SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
33760 C
33761                  IF (UNIV.LT.SUM)THEN
33762                    UNIV=DT_RNDM(SUM)
33763                    FLTI=DBLE(I)-UNIV
33764                    GOTO(55,55,55,60,60,65,65,65,65,70,70) I
33765                  END IF
33766  2100          CONTINUE
33767             END IF
33768  2200    CONTINUE
33769       ELSE
33770          DO 2400 K=12,55,11
33771             IF (PDCH(K).GT.EMEV) THEN
33772               UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
33773               UNIV=DT_RNDM(UNIVE)
33774               SUM=0.0D0
33775               DO 2300 I=1,10
33776                 II=K+I
33777                 SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
33778 C
33779                 IF (UNIV.LT.SUM)THEN
33780                   UNIV=DT_RNDM(SUM)
33781                   FLTI=UNIV+DBLE(I)
33782                   GOTO(50,55,60,60,65,65,65,65,70,70) I
33783                 END IF
33784  2300         CONTINUE
33785             END IF
33786  2400    CONTINUE
33787       END IF
33788 C
33789 50    CST=0.4D0*UNIV
33790       GOTO 2500
33791 55    CST=0.2D0*FLTI
33792       GOTO 2500
33793 60    CST=0.3D0+0.1D0*FLTI
33794       GOTO 2500
33795 65    CST=0.6D0+0.04D0*FLTI
33796       GOTO 2500
33797 70    CST=0.78D0+0.02D0*FLTI
33798 C
33799 2500  CONTINUE
33800       IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
33801 C
33802       RETURN
33803       END
33804
33805 *$ CREATE DT_DHADRI.FOR
33806 *COPY DT_DHADRI
33807 *
33808 *===dhadri=============================================================*
33809 *
33810       SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
33811
33812       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33813       SAVE
33814
33815       PARAMETER ( LINP = 10 ,
33816      &            LOUT = 6 ,
33817      &            LDAT = 9 )
33818 C
33819 C-----------------------------
33820 C*** INPUT VARIABLES LIST:
33821 C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
33822 C*** GEV/C LABORATORY MOMENTUM REGION
33823 C*** N    - PROJECTILE HADRON INDEX
33824 C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
33825 C*** ELAB - LABORATORY ENERGY OF N (GEV)
33826 C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
33827 C*** ITTA - TARGET NUCLEON INDEX
33828 C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
33829 C  IR COUNTS THE NUMBER OF PRODUCED PARTICLES
33830 C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
33831 C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
33832 C*** RESPECT., UNITS (GEV/C AND GEV)
33833 C----------------------------
33834
33835       COMMON /HNGAMR/ REDU,AMO,AMM(15)
33836       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33837       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33838      &                NRK(2,268),NURE(30,2)
33839 * particle properties (BAMJET index convention),
33840 * (dublicate of DTPART for HADRIN)
33841       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33842      &                K1H(110),K2H(110)
33843       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33844       COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
33845      &                ITS(149),IS
33846       COMMON /HNDRUN/ RUNTES,EFTES
33847 * particle properties (BAMJET index convention)
33848       CHARACTER*8  ANAME
33849       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33850      &                IICH(210),IIBAR(210),K1(210),K2(210)
33851 * final state from HADRIN interaction
33852       PARAMETER (MAXFIN=10)
33853       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
33854      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
33855
33856       DIMENSION ITPRF(110)
33857       DATA NNN/0/
33858       DATA UMODA/0./
33859       DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
33860       LOWP=0
33861       IF (N.LE.0.OR.N.GE.111)N=1
33862       IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
33863         GOTO 280
33864 *       WRITE (6,1000)
33865 *    +  ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
33866 *       STOP
33867 *1000   FORMAT (3(5H ****/),A,2I4,3(5H ****/))
33868 *    +  45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
33869       ENDIF
33870       IATMPT=0
33871       IF (ABS(PLAB-5.0D0).LT.4.99999D0)                        GO TO 20
33872 C     IF(IPRI.GE.1) WRITE (6,1010) PLAB
33873 C     STOP
33874  1010 FORMAT ( '  PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
33875      + ALLOWED REGION, PLAB=',1E15.5)
33876
33877    20 CONTINUE
33878       UMODAT=N*1.11111D0+ITTA*2.19291D0
33879       IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
33880       UMODA=UMODAT
33881    30 IATMPT=0
33882       LOWP=LOWP+1
33883    40 CONTINUE
33884       IMACH=0
33885       REDU=2.0D0
33886       IF (LOWP.GT.20) THEN
33887 C        WRITE(LOUT,*) ' jump 1'
33888          GO TO 280
33889       ENDIF
33890       NNN=N
33891       IF (NNN.EQ.N)                                             GO TO 50
33892       RUNTES=0.0D0
33893       EFTES=0.0D0
33894    50 CONTINUE
33895       IS=1
33896       IRH=0
33897       IST=1
33898       NSTAB=23
33899       IRE=NURE(N,1)
33900       IF(ITTA.GT.1) IRE=NURE(N,2)
33901 C
33902 C-----------------------------
33903 C*** IE,AMT,ECM,SI DETERMINATION
33904 C----------------------------
33905       CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
33906       IANTH=-1
33907 **sr
33908 C     IF (AMH(1).NE.0.93828D0) IANTH=1
33909       IF (AMH(1).NE.0.9383D0) IANTH=1
33910 **
33911       IF (IANTH.GE.0) SI=1.0D0
33912       ECMMH=ECM
33913 C
33914 C-----------------------------
33915 C    ENERGY INDEX
33916 C  IRE CHARACTERIZES THE REACTION
33917 C  IE IS THE ENERGY INDEX
33918 C----------------------------
33919       IF (SI.LT.1.D-6) THEN
33920 C        WRITE(LOUT,*) ' jump 2'
33921          GO TO 280
33922       ENDIF
33923       IF (N.LE.NSTAB)                                           GO TO 60
33924       RUNTES=RUNTES+1.0D0
33925       IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
33926  1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
33927       IF(IBARH(N).EQ.1) N=8
33928       IF(IBARH(N).EQ.-1)  N=9
33929    60 CONTINUE
33930       IMACH=IMACH+1
33931 **sr 19.2.97: loop for direct channel suppression
33932 C     IF (IMACH.GT.10) THEN
33933       IF (IMACH.GT.1000) THEN
33934 **
33935 C        WRITE(LOUT,*) ' jump 3'
33936          GO TO 280
33937       ENDIF
33938       ECM =ECMMH
33939       AMN2=AMN**2
33940       AMT2=AMT**2
33941       ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM    )
33942       IF(ECMN.LE.AMN) ECMN=AMN
33943       PCMN=SQRT(ECMN**2-AMN2)
33944       GAM=(ELAB+AMT)/ECM
33945       BGAM=PLAB/ECM
33946       IF (IANTH.GE.0) ECM=2.1D0
33947 C
33948 C-----------------------------
33949 C*** RANDOM CHOICE OF REACTION CHANNEL
33950 C----------------------------
33951       IST=0
33952       VV=DT_RNDM(AMN2)
33953       VV=VV-1.D-17
33954 C
33955 C-----------------------------
33956 C***  PLACE REDUCED VERSION
33957 C----------------------------
33958       IIEI=IEII(IRE)
33959       IDWK=IEII(IRE+1)-IIEI
33960       IIWK=IRII(IRE)
33961       IIKI=IKII(IRE)
33962 C
33963 C-----------------------------
33964 C***  SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
33965 C----------------------------
33966       HECM=ECM
33967       HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
33968       IF (HUMO.LT.ECM) ECM=HUMO
33969 C
33970 C-----------------------------
33971 C*** INTERPOLATION PREPARATION
33972 C----------------------------
33973       ECMO=UMO(IE)
33974       ECM1=UMO(IE-1)
33975       DECM=ECMO-ECM1
33976       DEC=ECMO-ECM
33977 C
33978 C-----------------------------
33979 C*** RANDOM LOOP
33980 C----------------------------
33981       IK=0
33982       WKK=0.0D0
33983       WICOR=0.0D0
33984    70 IK=IK+1
33985       IWK=IIWK+(IK-1)*IDWK+IE-IIEI
33986       WOK=WK(IWK)
33987       WDK=WOK-WK(IWK-1)
33988 C
33989 C-----------------------------
33990 C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
33991 C    GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
33992 C    CONTRIBUTE
33993 C----------------------------
33994       IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
33995       WICO=WOK*1.23459876D0+WDK*1.735218469D0
33996       IF (WICO.EQ.WICOR)                                        GO TO 70
33997       IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
33998       WICOR=WICO
33999 C
34000 C-----------------------------
34001 C*** INTERPOLATION IN CHANNEL WEIGHTS
34002 C----------------------------
34003       EKLIM=-THRESH(IIKI+IK)
34004       IELIM=IDT_IEFUND(EKLIM,IRE)
34005       DELIM=UMO(IELIM)+EKLIM
34006      *+1.D-16
34007       DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
34008       IF (DELIM*DELIM-DETE*DETE) 90,90,80
34009    80 DECC=DELIM
34010                                                                GO TO 100
34011    90 DECC=DECM
34012   100 CONTINUE
34013       WKK=WOK-WDK*DEC/(DECC+1.D-9)
34014 C
34015 C-----------------------------
34016 C*** RANDOM CHOICE
34017 C----------------------------
34018 C
34019       IF (VV.GT.WKK)                                            GO TO 70
34020 C
34021 C***IK IS THE REACTION CHANNEL
34022 C----------------------------
34023       INRK=IKII(IRE)+IK
34024       ECM=HECM
34025       I1001 =0
34026 C
34027   110 CONTINUE
34028       IT1=NRK(1,INRK)
34029       AM1=DT_DAMG(IT1)
34030       IT2=NRK(2,INRK)
34031       AM2=DT_DAMG(IT2)
34032       AMS=AM1+AM2
34033       I1001=I1001+1
34034       IF (I1001.GT.50)                                          GO TO 60
34035 C
34036       IF (IT2*AMS.GT.IT2*ECM)                                  GO TO 110
34037       IT11=IT1
34038       IT22=IT2
34039       IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
34040       AM11=AM1
34041       AM22=AM2
34042       IF (IT2.GT.0)                                            GO TO 120
34043 **sr 19.2.97: supress direct channel for pp-collisions
34044       IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
34045          RR = DT_RNDM(AM11)
34046          IF (RR.LE.0.75D0) GOTO 60
34047       ENDIF
34048 **
34049 C
34050 C-----------------------------
34051 C  INCLUSION OF DIRECT RESONANCES
34052 C  RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE  IT1
34053 C------------------------
34054       KZ1=K1H(IT1)
34055       IST=IST+1
34056       IECO=0
34057       ECO=ECM
34058       GAM=(ELAB+AMT)/ECO
34059       BGAM=PLAB/ECO
34060       CXS(1)=CX
34061       CYS(1)=CY
34062       CZS(1)=CZ
34063                                                                GO TO 170
34064   120 CONTINUE
34065       WW=DT_RNDM(ECO)
34066       IF(WW.LT. 0.5D0)                                         GO TO 130
34067       IT1=IT22
34068       IT2=IT11
34069       AM1=AM22
34070       AM2=AM11
34071   130 CONTINUE
34072 C
34073 C-----------------------------
34074 C   THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
34075       IBN=IBARH(N)
34076       IB1=IBARH(IT1)
34077       IT11=IT1
34078       IT22=IT2
34079       AM11=AM1
34080       AM22=AM2
34081       IF(IB1.EQ.IBN)                                           GO TO 140
34082       IT1=IT22
34083       IT2=IT11
34084       AM1=AM22
34085       AM2=AM11
34086   140 CONTINUE
34087 C-----------------------------
34088 C***IT1,IT2 ARE THE CREATED PARTICLES
34089 C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
34090 C------------------------
34091       CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
34092      *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
34093       IST=IST+1
34094       ITS(IST)=IT1
34095       AMM(IST)=AM1
34096 C
34097 C-----------------------------
34098 C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
34099 C----------------------------
34100       CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
34101      &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34102       IST=IST+1
34103       ITS(IST)=IT2
34104       AMM(IST)=AM2
34105       CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
34106      *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34107   150 CONTINUE
34108 C
34109 C-----------------------------
34110 C***TEST   STABLE OR UNSTABLE
34111 C----------------------------
34112       IF(ITS(IST).GT.NSTAB)                                    GO TO 160
34113       IRH=IRH+1
34114 C
34115 C-----------------------------
34116 C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
34117 C----------------------------
34118 C*    IF (REDU.LT.0.D0) GO TO 1009
34119       ITRH(IRH)=ITS(IST)
34120       PLRH(IRH)=PLS(IST)
34121       CXRH(IRH)=CXS(IST)
34122       CYRH(IRH)=CYS(IST)
34123       CZRH(IRH)=CZS(IST)
34124       ELRH(IRH)=ELS(IST)
34125       IST=IST-1
34126       IF(IST.GE.1)                                             GO TO 150
34127                                                                GO TO 260
34128   160 CONTINUE
34129 C
34130 C  RANDOM CHOICE OF DECAY CHANNELS
34131 C----------------------------
34132 C
34133       IT=ITS(IST)
34134       ECO=AMM(IST)
34135       GAM=ELS(IST)/ECO
34136       BGAM=PLS(IST)/ECO
34137       IECO=0
34138       KZ1=K1H(IT)
34139   170 CONTINUE
34140       IECO=IECO+1
34141       VV=DT_RNDM(GAM)
34142       VV=VV-1.D-17
34143       IIK=KZ1-1
34144   180 IIK=IIK+1
34145       IF (VV.GT.WTI(IIK))                                      GO TO 180
34146 C
34147 C  IIK IS THE DECAY CHANNEL
34148 C----------------------------
34149       IT1=NZKI(IIK,1)
34150       I310=0
34151   190 CONTINUE
34152       I310=I310+1
34153       AM1=DT_DAMG(IT1)
34154       IT2=NZKI(IIK,2)
34155       AM2=DT_DAMG(IT2)
34156       IF (IT2-1.LT.0)                                          GO TO 240
34157       IT3=NZKI(IIK,3)
34158       AM3=DT_DAMG(IT3)
34159       AMS=AM1+AM2+AM3
34160 C
34161 C  IF  IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
34162 C----------------------------
34163       IF (IECO.LE.10)                                          GO TO 200
34164       IATMPT=IATMPT+1
34165       IF(IATMPT.GT.3) THEN
34166 C        WRITE(LOUT,*) ' jump 4'
34167          GO TO 280
34168       ENDIF
34169                                                                 GO TO 40
34170   200 CONTINUE
34171       IF (I310.GT.50)                                          GO TO 170
34172       IF (AMS.GT.ECO)                                          GO TO 190
34173 C
34174 C  FOR THE DECAY CHANNEL
34175 C  IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM  IT
34176 C----------------------------
34177       IF (REDU.LT.0.D0)                                        GO TO 30
34178       ITWTHC=0
34179       REDU=2.0D0
34180       IF(IT3.EQ.0)                                             GO TO 220
34181   210 CONTINUE
34182       ITWTH=1
34183       CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
34184      *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
34185                                                                GO TO 230
34186   220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
34187      &COD2,COF2,SIF2,AM1,AM2)
34188       ITWTH=-1
34189       IT3=0
34190   230 CONTINUE
34191       ITWTHC=ITWTHC+1
34192       IF (REDU.GT.0.D0)                                        GO TO 240
34193       REDU=2.0D0
34194       IF (ITWTHC.GT.100)                                        GO TO 30
34195       IF (ITWTH) 220,220,210
34196   240 CONTINUE
34197       ITS(IST  )=IT1
34198       IF (IT2-1.LT.0)                                          GO TO 250
34199       ITS(IST+1)  =IT2
34200       ITS(IST+2)=IT3
34201       RX=CXS(IST)
34202       RY=CYS(IST)
34203       RZ=CZS(IST)
34204       AMM(IST)=AM1
34205       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
34206      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34207       IST=IST+1
34208       AMM(IST)=AM2
34209       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
34210      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34211       IF (IT3.LE.0)                                            GO TO 250
34212       IST=IST+1
34213       AMM(IST)=AM3
34214       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
34215      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34216   250 CONTINUE
34217                                                                GO TO 150
34218   260 CONTINUE
34219   270 CONTINUE
34220       RETURN
34221   280 CONTINUE
34222 C
34223 C----------------------------
34224 C
34225 C   ZERO CROSS SECTION CASE
34226 C----------------------------
34227 C
34228       IRH=1
34229       ITRH(1)=N
34230       CXRH(1)=CX
34231       CYRH(1)=CY
34232       CZRH(1)=CZ
34233       ELRH(1)=ELAB
34234       PLRH(1)=PLAB
34235       RETURN
34236       END
34237
34238 *$ CREATE DT_RUNTT.FOR
34239 *COPY DT_RUNTT
34240 *
34241 *===runtt==============================================================*
34242 *
34243       BLOCK DATA DT_RUNTT
34244
34245       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34246       SAVE
34247
34248       COMMON /HNDRUN/ RUNTES,EFTES
34249
34250       DATA RUNTES,EFTES /100.D0,100.D0/
34251
34252       END
34253
34254 *$ CREATE DT_NONAME.FOR
34255 *COPY DT_NONAME
34256 *
34257 *===noname=============================================================*
34258 *
34259       BLOCK DATA DT_NONAME
34260
34261       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34262       SAVE
34263
34264 * slope parameters for HADRIN interactions
34265       COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
34266       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34267
34268 C     DATAS     DATAS    DATAS      DATAS     DATAS
34269 C******          *********
34270       DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
34271      &           207, 224, 241, 252, 268 /
34272       DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
34273      &           220, 241, 262, 279, 296 /
34274       DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
34275      &           3364, 3507, 4011, 4368, 4725, 4912, 5184/
34276
34277 C
34278 C     MASSES FOR THE SLOPE B(M) IN GEV
34279 C     SLOPE B(M) FOR AN MESONIC SYSTEM
34280 C     SLOPE B(M) FOR A BARYONIC SYSTEM
34281
34282 *
34283       DATA SM,BBM,BBB/  0.8D0, 0.85D0,  0.9D0, 0.95D0, 1.D0,
34284      &     1.05D0,  1.1D0, 1.15D0,  1.2D0, 1.25D0,
34285      &      1.3D0,  1.35D0, 1.4D0,  1.45D0,  1.5D0,
34286      &     1.55D0,  1.6D0,  1.65D0, 1.7D0,   1.75D0,
34287      &      1.8D0,  1.85D0, 1.9D0,  1.95D0,  2.D0,
34288      &     15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
34289      &    12.35D0, 11.7D0, 10.85D0, 10.D0,  9.15D0,
34290      &      8.3D0,  7.8D0,  7.3D0,  7.25D0,  7.2D0,
34291      &     6.95D0,  6.7D0,  6.6D0,  6.5D0,   6.3D0,
34292      &      6.1D0,  5.85D0, 5.6D0,  5.35D0,  5.1D0,
34293      &      15.D0,   15.D0, 15.D0,  15.D0,   15.D0, 15.D0, 15.D0,
34294      &     14.2D0,  13.4D0, 12.6D0,
34295      &     11.8D0, 11.2D0, 10.6D0,  9.8D0,    9.D0,
34296      &     8.25D0,  7.5D0, 6.25D0,  5.D0,    4.5D0, 5*4.D0 /
34297 *
34298       END
34299
34300 *$ CREATE DT_DAMG.FOR
34301 *COPY DT_DAMG
34302 *
34303 *===damg===============================================================*
34304 *
34305       DOUBLE PRECISION FUNCTION DT_DAMG(IT)
34306
34307       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34308       SAVE
34309
34310 * particle properties (BAMJET index convention),
34311 * (dublicate of DTPART for HADRIN)
34312       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34313      &                K1H(110),K2H(110)
34314
34315       DIMENSION GASUNI(14)
34316       DATA GASUNI/
34317      *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
34318      *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
34319       DATA GAUNO/2.352D0/
34320       DATA GAUNON/2.4D0/
34321       DATA IO/14/
34322       DATA NSTAB/23/
34323
34324       I=1
34325       IF (IT.LE.0)                                              GO TO 30
34326       IF (IT.LE.NSTAB)                                          GO TO 20
34327       DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
34328       VV=DT_RNDM(DGAUNI)
34329       VV=VV*2.0D0-1.0D0+1.D-16
34330    10 CONTINUE
34331       VO=GASUNI(I)
34332       I=I+1
34333       V1=GASUNI(I)
34334       IF (VV.GT.V1)                                             GO TO 10
34335       UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
34336      &      (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
34337       DAM=GAH(IT)*UNIGA/GAUNO
34338       AAM=AMH(IT)+DAM
34339       DT_DAMG=AAM
34340       RETURN
34341    20 CONTINUE
34342       DT_DAMG=AMH(IT)
34343       RETURN
34344    30 CONTINUE
34345       DT_DAMG=0.0D0
34346       RETURN
34347       END
34348
34349 *$ CREATE DT_DCALUM.FOR
34350 *COPY DT_DCALUM
34351 *
34352 *===dcalum=============================================================*
34353 *
34354       SUBROUTINE DT_DCALUM(N,ITTA)
34355
34356       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34357       SAVE
34358
34359 C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
34360
34361 * particle properties (BAMJET index convention),
34362 * (dublicate of DTPART for HADRIN)
34363       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34364      &                K1H(110),K2H(110)
34365       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34366       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34367       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34368      &                NRK(2,268),NURE(30,2)
34369
34370       IRE=NURE(N,ITTA/8+1)
34371       IEO=IEII(IRE)+1
34372       IEE=IEII(IRE +1)
34373       AM1=AMH(N   )
34374       AM12=AM1**2
34375       AM2=AMH(ITTA)
34376       AM22=AM2**2
34377       DO 10 IE=IEO,IEE
34378         PLAB2=PLABF(IE)**2
34379         ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
34380         UMO(IE)=ELAB
34381    10 CONTINUE
34382       IKO=IKII(IRE)+1
34383       IKE=IKII(IRE +1)
34384       UMOO=UMO(IEO)
34385       DO 30 IK=IKO,IKE
34386         IF(NRK(2,IK).GT.0)                                      GO TO 30
34387         IKI=NRK(1,IK)
34388         AMSS=5.0D0
34389         K11=K1H(IKI)
34390         K22=K2H(IKI)
34391         DO 20 IK1=K11,K22
34392           IN=NZKI(IK1,1)
34393           AMS=AMH(IN)
34394           IN=NZKI(IK1,2)
34395           IF(IN.GT.0)AMS=AMS+AMH(IN)
34396           IN=NZKI(IK1,3)
34397           IF(IN.GT.0) AMS=AMS+AMH(IN)
34398           IF (AMS.LT.AMSS) AMSS=AMS
34399    20   CONTINUE
34400         IF(UMOO.LT.AMSS) UMOO=AMSS
34401         THRESH(IK)=UMOO
34402    30 CONTINUE
34403       RETURN
34404       END
34405
34406 *$ CREATE DT_DCHANH.FOR
34407 *COPY DT_DCHANH
34408 *
34409 *===dchanh=============================================================*
34410 *
34411       SUBROUTINE DT_DCHANH
34412
34413       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34414       SAVE
34415
34416       PARAMETER ( LINP = 10 ,
34417      &            LOUT = 6 ,
34418      &            LDAT = 9 )
34419 * particle properties (BAMJET index convention),
34420 * (dublicate of DTPART for HADRIN)
34421       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34422      &                K1H(110),K2H(110)
34423       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34424       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34425       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34426      &                NRK(2,268),NURE(30,2)
34427
34428       DIMENSION HWT(460),HWK(40),SI(5184)
34429       EQUIVALENCE (WK(1),SI(1))
34430 C--------------------
34431 C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
34432 C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
34433 C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
34434 C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
34435 C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
34436 C--------------------------
34437       IREG=16
34438       DO 90 IRE=1,IREG
34439         IWKO=IRII(IRE)
34440         IEE=IEII(IRE+1)-IEII(IRE)
34441         IKE=IKII(IRE+1)-IKII(IRE)
34442         IEO=IEII(IRE)+1
34443         IIKA=IKII(IRE)
34444 *   modifications to suppress elestic scattering  24/07/91
34445         DO 80 IE=1,IEE
34446           SIS=1.D-14
34447           SINORC=0.0D0
34448           DO 10 IK=1,IKE
34449             IWK=IWKO+IEE*(IK-1)+IE
34450             IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
34451             SIS=SIS+SI(IWK)*SINORC
34452    10     CONTINUE
34453           SIIN(IEO+IE-1)=SIS
34454           SIO=0.D0
34455           IF (SIS.GE.1.D-12)                                    GO TO 20
34456           SIS=1.D0
34457           SIO=1.D0
34458    20     CONTINUE
34459           SINORC=0.0D0
34460           DO 30 IK=1,IKE
34461             IWK=IWKO+IEE*(IK-1)+IE
34462             IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
34463             SIO=SIO+SI(IWK)*SINORC/SIS
34464             HWK(IK)=SIO
34465    30     CONTINUE
34466           DO 40 IK=1,IKE
34467             IWK=IWKO+IEE*(IK-1)+IE
34468    40     WK(IWK)=HWK(IK)
34469           IIKI=IKII(IRE)
34470           DO 70 IK=1,IKE
34471             AM111=0.D0
34472             INRK1=NRK(1,IIKI+IK)
34473             IF (INRK1.GT.0) AM111=AMH(INRK1)
34474             AM222=0.D0
34475             INRK2=NRK(2,IIKI+IK)
34476             IF (INRK2.GT.0) AM222=AMH(INRK2)
34477             THRESH(IIKI+IK)=AM111 +AM222
34478             IF (INRK2-1.GE.0)                                   GO TO 60
34479             INRKK=K1H(INRK1)
34480             AMSS=5.D0
34481             INRKO=K2H(INRK1)
34482             DO 50 INRK1=INRKK,INRKO
34483               INZK1=NZKI(INRK1,1)
34484               INZK2=NZKI(INRK1,2)
34485               INZK3=NZKI(INRK1,3)
34486               IF (INZK1.LE.0.OR.INZK1.GT.110)                   GO TO 50
34487               IF (INZK2.LE.0.OR.INZK2.GT.110)                   GO TO 50
34488               IF (INZK3.LE.0.OR.INZK3.GT.110)                   GO TO 50
34489 C     WRITE (6,310)INRK1,INZK1,INZK2,INZK3
34490  1000 FORMAT (4I10)
34491               AMS=AMH(INZK1)+AMH(INZK2)
34492               IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
34493               IF (AMSS.GT.AMS) AMSS=AMS
34494    50       CONTINUE
34495             AMS=AMSS
34496             IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
34497             THRESH(IIKI+IK)=AMS
34498    60       CONTINUE
34499    70     CONTINUE
34500    80   CONTINUE
34501    90 CONTINUE
34502       DO 100 J=1,460
34503   100 HWT(J)=0.D0
34504       DO 120 I=1,110
34505         IK1=K1H(I)
34506         IK2=K2H(I)
34507         HV=0.D0
34508         IF (IK2.GT.460)IK2=460
34509         IF (IK1.LE.0)IK1=1
34510         DO 110 J=IK1,IK2
34511           HV=HV+WTI(J)
34512           HWT(J)=HV
34513           JI=J
34514   110   CONTINUE
34515         IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
34516  1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
34517   120 CONTINUE
34518       DO 130 J=1,460
34519   130 WTI(J)=HWT(J)
34520       RETURN
34521       END
34522
34523 *$ CREATE DT_DHADDE.FOR
34524 *COPY DT_DHADDE
34525 *
34526 *===dhadde=============================================================*
34527 *
34528       SUBROUTINE DT_DHADDE
34529
34530       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34531       SAVE
34532
34533 * particle properties (BAMJET index convention)
34534       CHARACTER*8  ANAME
34535       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
34536      &                IICH(210),IIBAR(210),K1(210),K2(210)
34537 * HADRIN: decay channel information
34538       PARAMETER (IDMAX9=602)
34539       CHARACTER*8 ZKNAME
34540       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
34541 * particle properties (BAMJET index convention),
34542 * (dublicate of DTPART for HADRIN)
34543       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34544      &                K1H(110),K2H(110)
34545       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34546 * decay channel information for HADRIN
34547       COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
34548      &                K1Z(16),K2Z(16),WTZ(153),II22,
34549      &                NZK1(153),NZK2(153),NZK3(153)
34550
34551       DATA IRETUR/0/
34552
34553       IRETUR=IRETUR+1
34554       AMH(31)=0.48D0
34555       IF (IRETUR.GT.1) RETURN
34556       DO 10 I=1,94
34557         AMH(I)   = AAM(I)
34558         GAH(I)   = GA(I)
34559         TAUH(I)  = TAU(I)
34560         ICHH(I)  = IICH(I)
34561         IBARH(I) = IIBAR(I)
34562         K1H(I)   = K1(I)
34563         K2H(I)   = K2(I)
34564    10 CONTINUE
34565 **sr
34566 C     AMH(1)=0.93828D0
34567       AMH(1)=0.9383D0
34568 **
34569       AMH(2)=AMH(1)
34570       DO 20 I=26,30
34571         K1H(I)=452
34572         K2H(I)=452
34573    20 CONTINUE
34574       DO 30 I=1,307
34575         WTI(I)    = WT(I)
34576         NZKI(I,1) = NZK(I,1)
34577         NZKI(I,2) = NZK(I,2)
34578         NZKI(I,3) = NZK(I,3)
34579    30 CONTINUE
34580       DO 40 I=1,16
34581         L=I+94
34582         AMH(L)=AMZ(I)
34583         GAH( L)=GAZ(I)
34584         TAUH( L)=TAUZ(I)
34585         ICHH( L)=ICHZ(I)
34586         IBARH( L)=IBARZ(I)
34587         K1H( L)=K1Z(I)
34588         K2H( L)=K2Z(I)
34589    40 CONTINUE
34590       DO 50 I=1,153
34591         L=I+307
34592         WTI(L)    = WTZ(I)
34593         NZKI(L,3) = NZK3(I)
34594         NZKI(L,2) = NZK2(I)
34595         NZKI(L,1) = NZK1(I)
34596    50 CONTINUE
34597       RETURN
34598       END
34599
34600 *$ CREATE IDT_IEFUND.FOR
34601 *COPY IDT_IEFUND
34602 *
34603 *===iefund=============================================================*
34604 *
34605       INTEGER FUNCTION IDT_IEFUND(PL,IRE)
34606
34607       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34608       SAVE
34609
34610 C*****IEFUN CALCULATES A MOMENTUM INDEX
34611
34612       PARAMETER ( LINP = 10 ,
34613      &            LOUT = 6 ,
34614      &            LDAT = 9 )
34615       COMMON /HNDRUN/ RUNTES,EFTES
34616       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34617       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34618      &                NRK(2,268),NURE(30,2)
34619
34620       IPLA=IEII(IRE)+1
34621      *+1
34622       IPLE=IEII(IRE+1)
34623       IF (PL.LT.0.)                                             GO TO 30
34624       DO 10 I=IPLA,IPLE
34625         J=I-IPLA+1
34626         IF (PL.LE.PLABF(I))                                     GO TO 60
34627    10 CONTINUE
34628       I=IPLE
34629       IF ( EFTES.GT.40.D0)                                      GO TO 20
34630       EFTES=EFTES+1.0D0
34631       WRITE(LOUT,1000)PL,J
34632    20 CONTINUE
34633                                                                 GO TO 70
34634    30 CONTINUE
34635       DO 40 I=IPLA,IPLE
34636         J=I-IPLA+1
34637         IF (-PL.LE.UMO(I))                                      GO TO 60
34638    40 CONTINUE
34639       I=IPLE
34640       IF ( EFTES.GT.40.D0)                                      GO TO 50
34641       EFTES=EFTES+1.0D0
34642       WRITE(LOUT,1000)PL,I
34643    50 CONTINUE
34644    60 CONTINUE
34645    70 CONTINUE
34646       IDT_IEFUND=I
34647       RETURN
34648  1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
34649      +7H IEFUN=,I5)
34650       END
34651
34652 *$ CREATE DT_DSIGIN.FOR
34653 *COPY DT_DSIGIN
34654 *
34655 *===dsigin=============================================================*
34656 *
34657       SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
34658
34659       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34660       SAVE
34661
34662 * particle properties (BAMJET index convention),
34663 * (dublicate of DTPART for HADRIN)
34664       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34665      &                K1H(110),K2H(110)
34666       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34667       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34668      &                NRK(2,268),NURE(30,2)
34669
34670       IE=IDT_IEFUND(PLAB,IRE)
34671       IF (IE.LE.IEII(IRE)) IE=IE+1
34672       AMT=AMH(ITAR)
34673       AMN=AMH(N)
34674       AMN2=AMN*AMN
34675       AMT2=AMT*AMT
34676       ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
34677 C*** INTERPOLATION PREPARATION
34678       ECMO=UMO(IE)
34679       ECM1=UMO(IE-1)
34680       DECM=ECMO-ECM1
34681       DEC=ECMO-ECM
34682       IIKI=IKII(IRE)+1
34683       EKLIM=-THRESH(IIKI)
34684       WOK=SIIN(IE)
34685       WDK=WOK-SIIN(IE-1)
34686       IF (ECM.GT.ECMO) WDK=0.0D0
34687 C*** INTERPOLATION IN CHANNEL WEIGHTS
34688       IELIM=IDT_IEFUND(EKLIM,IRE)
34689       DELIM=UMO(IELIM)+EKLIM
34690      *+1.D-16
34691       DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
34692       IF (DELIM*DELIM-DETE*DETE) 20,20,10
34693    10 DECC=DELIM
34694                                                                 GO TO 30
34695    20 DECC=DECM
34696    30 CONTINUE
34697       WKK=WOK-WDK*DEC/(DECC+1.D-9)
34698       IF (WKK.LT.0.0D0) WKK=0.0D0
34699       SI=WKK+1.D-12
34700       IF (-EKLIM.GT.ECM) SI=1.D-14
34701       RETURN
34702       END
34703
34704 *$ CREATE DT_DTCHOI.FOR
34705 *COPY DT_DTCHOI
34706 *
34707 *===dtchoi=============================================================*
34708 *
34709       SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
34710
34711       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34712       SAVE
34713
34714 C     ****************************
34715 C     TCHOIC CALCULATES A RANDOM VALUE
34716 C     FOR THE FOUR-MOMENTUM-TRANSFER T
34717 C     ****************************
34718
34719 * particle properties (BAMJET index convention),
34720 * (dublicate of DTPART for HADRIN)
34721       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34722      &                K1H(110),K2H(110)
34723 * slope parameters for HADRIN interactions
34724       COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
34725
34726       AMA=AM1
34727       AMB=AM2
34728       IF (I.GT.30.AND.II.GT.30)                                 GO TO 20
34729       III=II
34730       AM3=AM2
34731       IF (I.LE.30)                                              GO TO 10
34732       III=I
34733       AM3=AM1
34734    10 CONTINUE
34735                                                                 GO TO 30
34736    20 CONTINUE
34737       III=II
34738       AM3=AM2
34739       IF (AMA.LE.AMB)                                           GO TO 30
34740       III=I
34741       AM3=AM1
34742    30 CONTINUE
34743       IB=IBARH(III)
34744       AMA=AM3
34745       K=INT((AMA-0.75D0)/0.05D0)
34746       IF (K-2.LT.0) K=1
34747       IF (K-26.GE.0) K=25
34748       IF (IB)50,40,50
34749    40 BM=BBM(K)
34750                                                                 GO TO 60
34751    50 BM=BBB(K)
34752    60 CONTINUE
34753 C     NORMALIZATION
34754       TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1  **2
34755       TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1  **2
34756       VB=DT_RNDM(TMIN)
34757 **sr test
34758 C     IF (VB.LT.0.2D0) BM=BM*0.1
34759 C    **0.5
34760       BM = BM*5.05D0
34761 **
34762       TMI=BM*TMIN
34763       TMA=BM*TMAX
34764       ETMA=0.D0
34765       IF (ABS(TMA).GT.120.D0)                                   GO TO 70
34766       ETMA=EXP(TMA)
34767    70 CONTINUE
34768       AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
34769 C*** RANDOM CHOICE OF THE T - VALUE
34770       R=DT_RNDM(TMI)
34771       T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
34772       RETURN
34773       END
34774
34775 *$ CREATE DT_DTWOPA.FOR
34776 *COPY DT_DTWOPA
34777 *
34778 *===dtwopa=============================================================*
34779 *
34780       SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
34781      &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
34782
34783       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34784       SAVE
34785
34786 C     ******************************************************
34787 C     QUASI TWO PARTICLE PRODUCTION
34788 C     TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
34789 C     FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
34790 C     IN THE CM - SYSTEM
34791 C     COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
34792 C     SPHERICAL COORDINATES
34793 C     ******************************************************
34794
34795 * particle properties (BAMJET index convention),
34796 * (dublicate of DTPART for HADRIN)
34797       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34798      &                K1H(110),K2H(110)
34799
34800       AMA=AM1
34801       AMB=AM2
34802       AMA2=AMA*AMA
34803       E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
34804       E2=UMOO - E1
34805       IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
34806       AMTE=(E1-AMA)*(E1+AMA)
34807       AMTE=AMTE+1.D-18
34808       P1=SQRT(AMTE)
34809       P2=P1
34810 C     / P2 / = / P1 /  BUT OPPOSITE DIRECTIONS
34811 C     DETERMINATION  OF  THE ANGLES
34812 C     COS(THETA1)=COD1      COS(THETA2)=COD2
34813 C     SIN(PHI1)=SIF1        SIN(PHI2)=SIF2
34814 C     COS(PHI1)=COF1        COS(PHI2)=COF2
34815 C     PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
34816       CALL DT_DSFECF(COF1,SIF1)
34817       COF2=-COF1
34818       SIF2=-SIF1
34819 C     CALCULATION OF THETA1
34820       CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
34821       COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
34822       IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
34823       COD2=-COD1
34824       RETURN
34825       END
34826
34827 *$ CREATE DT_ZK.FOR
34828 *COPY DT_ZK
34829 *
34830 *===zk=================================================================*
34831 *
34832       BLOCK DATA DT_ZK
34833
34834       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34835       SAVE
34836
34837 * decay channel information for HADRIN
34838       COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
34839      &                K1Z(16),K2Z(16),WTZ(153),II22,
34840      &                NZK1(153),NZK2(153),NZK3(153)
34841 * decay channel information for HADRIN
34842       CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
34843       COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
34844
34845 *     Particle masses in GeV                                           *
34846       DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
34847      &          2*1.7D0, 3*0.D0/
34848 *     Resonance width Gamma in GeV                                     *
34849       DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
34850 *     Mean life time in seconds                                        *
34851       DATA TAUZ / 16*0.D0 /
34852 *     Charge of particles and resonances                               *
34853       DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
34854 *     Baryonic charge                                                  *
34855       DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
34856 *     First number of decay channels used for resonances               *
34857 *     and decaying particles                                           *
34858       DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
34859      &          3*460/
34860 *     Last number of decay channels used for resonances                *
34861 *     and decaying particles                                           *
34862       DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
34863      &          3*460/
34864 *     Weight of decay channel                                          *
34865       DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
34866      & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
34867      & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
34868      & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
34869      & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
34870      & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
34871      & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
34872      & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
34873      & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
34874      & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
34875      & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
34876      & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
34877      & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
34878      & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
34879      & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
34880      & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
34881      & .05D0, .65D0, 9*1.D0 /
34882 *     Particle numbers in decay channel                                *
34883       DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
34884      & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
34885      & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
34886      & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
34887      & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
34888      & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
34889      & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
34890      & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
34891       DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
34892      & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
34893      & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
34894      & 4*33, 32, 3*35,  2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
34895      & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
34896      & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
34897      & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
34898      & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
34899      & 1, 8, 1, 8, 1, 9*0 /
34900       DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
34901      & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
34902      & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
34903      & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
34904      & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
34905      & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
34906 *     Particle  names                                                  *
34907       DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS  ',' PAP  ',' PAN  ',
34908      & 'APN', 'DEO   ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
34909      & 3*'BLANK' /
34910 *     Name of decay channel                                            *
34911       DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
34912      & 'ANNPI0','APPPI0','ANPPI-'/
34913       DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K-  ','K0AK0 ',
34914      & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET  ','&0R0  ','P-R+  ',
34915      & 'P+R-  ','POOM  ',' ETET ','ETSP0 ','R0ET  ',' R0R0 ','R+R-  ',
34916      & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
34917      & 'P+R-R0','R0OM  ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
34918      & 'P+R-OM','OMOM  ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
34919      & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
34920      & 'OMOMOM',
34921      & ' P+PO ','P+POPO','P+P+P-','P+ET  ','P0R+  ','P+R0  ','ETSP+ ',
34922      & 'R+ET  ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
34923      & 'P+R-R+','R+OM  ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
34924      & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
34925      & 'P-PO  ','P-POPO','P-P-P+','P-ET  ','POR-  ','P-R0  ','ETSP- ',
34926      & 'R-ET  ','R-R0  ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
34927       DATA ZKNAM6/'P+R-R-','R-OM  ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
34928      & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
34929      & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO  ','LPI+  ',
34930      & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
34931      & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
34932      & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
34933      & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
34934      & 9*'BLANK'/
34935 *=                                               end*block.zk      *
34936       END
34937
34938 *$ CREATE DT_BLKD43.FOR
34939 *COPY DT_BLKD43
34940 *
34941 *===blkd43=============================================================*
34942 *
34943       BLOCK DATA DT_BLKD43
34944
34945       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34946       SAVE
34947
34948 *
34949 *=== reac =============================================================*
34950 *
34951 *----------------------------------------------------------------------*
34952 *                                                                      *
34953 *     Created on 10 december 1991  by    Alfredo Ferrari & Paola Sala  *
34954 *                                                   Infn - Milan       *
34955 *                                                                      *
34956 *     Last change on 10-dec-91     by    Alfredo Ferrari               *
34957 *                                                                      *
34958 *     This is the original common reac of Hadrin                       *
34959 *                                                                      *
34960 *----------------------------------------------------------------------*
34961 *
34962       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34963      &                NRK(2,268),NURE(30,2)
34964
34965       DIMENSION
34966      & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
34967      & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
34968      & SPIKP1(315), SPIKPU(278), SPIKPV(372),
34969      & SPIKPW(278), SPIKPX(372), SPIKP4(315),
34970      & SPIKP5(187), SPIKP6(289),
34971      & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
34972      & SPIKP9(143), SPIKP0(169), SPKPV(143),
34973      & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
34974      & SANPEL(84) , SPIKPF(273),
34975      & SPKP15(187), SPKP16(272),
34976      & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
34977      & NURELN(60)
34978 *
34979        DIMENSION NRKLIN(532)
34980        EQUIVALENCE (NRK(1,1), NRKLIN(1))
34981        EQUIVALENCE (   UMO(  1),  UMOPI(1)), (   UMO( 93),  UMOKC(1))
34982        EQUIVALENCE (   UMO(161),   UMOP(1)), (   UMO(200),   UMON(1))
34983        EQUIVALENCE (   UMO(263),  UMOK0(1))
34984        EQUIVALENCE ( PLABF(  1),  PLAPI(1)), ( PLABF( 93),  PLAKC(1))
34985        EQUIVALENCE ( PLABF(161),   PLAP(1)), ( PLABF(200),   PLAN(1))
34986        EQUIVALENCE ( PLABF(263),  PLAK0(1))
34987        EQUIVALENCE (   WK(   1), SPIKP1(1)), (   WK( 316), SPIKPU(1))
34988        EQUIVALENCE (   WK( 594), SPIKPV(1)), (   WK( 966), SPIKPW(1))
34989        EQUIVALENCE (   WK(1244), SPIKPX(1)), (   WK(1616), SPIKP4(1))
34990        EQUIVALENCE (   WK(1931), SPIKP5(1)), (   WK(2118), SPIKP6(1))
34991        EQUIVALENCE (   WK(2407), SKMPEL(1)), (   WK(2509), SPIKP7(1))
34992        EQUIVALENCE (   WK(2798), SKMNEL(1)), (   WK(2866), SPIKP8(1))
34993        EQUIVALENCE (   WK(3053), SPIKP9(1)), (   WK(3196), SPIKP0(1))
34994        EQUIVALENCE (   WK(3365),  SPKPV(1)), (   WK(3508), SAPPEL(1))
34995        EQUIVALENCE (   WK(3613), SPIKPE(1)), (   WK(4012), SAPNEL(1))
34996        EQUIVALENCE (   WK(4096), SPIKPZ(1)), (   WK(4369), SANPEL(1))
34997        EQUIVALENCE (   WK(4453), SPIKPF(1)), (   WK(4726), SPKP15(1))
34998        EQUIVALENCE (   WK(4913), SPKP16(1))
34999        EQUIVALENCE (NRK(1,1), NRKLIN(1))
35000        EQUIVALENCE (NRKLIN(   1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
35001        EQUIVALENCE (NRKLIN( 297),  NRKP(1)), (NRKLIN( 367),  NRKN(1))
35002        EQUIVALENCE (NRKLIN( 483), NRKK0(1))
35003        EQUIVALENCE (NURE(1,1), NURELN(1))
35004 *
35005 **** pi- p data                                                        *
35006 **** pi+ n data                                                        *
35007       DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
35008      & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
35009      & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
35010      & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
35011      & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
35012      & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
35013      & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
35014      & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
35015      & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
35016      & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
35017       DATA PLAKC /
35018      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35019      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35020      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35021      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35022      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35023      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35024      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35025      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35026      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35027      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35028      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35029      & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
35030       DATA PLAK0 /
35031      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35032      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35033      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35034      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35035      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35036      & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
35037 *                 pp   pn   np   nn                                    *
35038       DATA PLAP /
35039      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35040      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35041      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35042      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35043      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35044      & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
35045 *    app   apn   anp   ann                                             *
35046       DATA PLAN /
35047      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
35048      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35049      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35050      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
35051      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35052      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35053      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
35054      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35055      & 3.43D0, 3.75D0, 4.07D0, 4.43D0  /
35056       DATA SIIN / 296*0.D0 /
35057       DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
35058      & 1.557D0,1.615D0,1.6435D0,
35059      & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
35060      & 2.286D0,2.366D0,2.482D0,2.56D0,
35061      & 2.735D0,2.90D0,
35062      &             1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
35063      & 1.496D0,1.527D0,1.557D0,
35064      & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
35065      & 2.071D0,2.159D0,2.286D0,2.366D0,
35066      & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
35067      &             1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
35068      & 1.496D0,1.527D0,1.557D0,
35069      & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
35070      & 2.071D0,2.159D0,2.286D0,2.366D0,
35071      & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
35072      &                   1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
35073      & 1.557D0,1.615D0,1.6435D0,
35074      & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
35075      & 2.286D0,2.366D0,2.482D0,2.56D0,
35076      &  2.735D0, 2.90D0/
35077       DATA UMOKC/ 1.44D0,
35078      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35079      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35080      & 3.1D0,1.44D0,
35081      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35082      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35083      & 3.1D0,1.44D0,
35084      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35085      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35086      & 3.1D0,1.44D0,
35087      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35088      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35089      &  3.1D0/
35090       DATA UMOK0/ 1.44D0,
35091      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35092      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35093      & 3.1D0,1.44D0,
35094      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35095      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35096      &  3.1D0/
35097 *                 pp   pn   np   nn                                    *
35098       DATA UMOP/
35099      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35100      & 3.D0,3.1D0,3.2D0,
35101      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35102      & 3.D0,3.1D0,3.2D0,
35103      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35104      & 3.D0,3.1D0,3.2D0/
35105 *    app   apn   anp   ann                                             *
35106       DATA UMON /
35107      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35108      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35109      & 3.D0,3.1D0,3.2D0,
35110      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35111      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35112      & 3.D0,3.1D0,3.2D0,
35113      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35114      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35115      &  3.D0,3.1D0,3.2D0/
35116 **** reaction channel state particles                                  *
35117       DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
35118      & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
35119      & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
35120      & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
35121      & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
35122      & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
35123      & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
35124      & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
35125      & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
35126      & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
35127       DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
35128      & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
35129      & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
35130      & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
35131      & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
35132      & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
35133      & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
35134      & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
35135 *                                                                      *
35136 *   k0 p   k0 n   ak0 p   ak/ n                                        *
35137 *                                                                      *
35138       DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
35139      & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13,   22, 13, 21, 23,
35140      & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
35141      & 53, 47, 1, 103, 0, 93, 0/
35142 *   pp  pn   np   nn                                                   *
35143       DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
35144      & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
35145      & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
35146      & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
35147 *     app   apn   anp   ann                                            *
35148       DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
35149      & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
35150      & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
35151      & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
35152      & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
35153      & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
35154      & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
35155 **** channel cross section                                             *
35156       DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
35157      & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
35158      & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
35159      & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
35160      & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
35161      &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
35162      & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
35163      & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
35164      &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
35165      & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
35166      & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
35167      & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
35168      & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
35169      & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
35170      & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
35171      & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
35172      & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
35173      & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
35174      & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
35175      & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
35176 **** pi+ n data                                                        *
35177       DATA SPIKPU/   0.D0, 25.D0, 13.D0,  11.D0, 10.5D0, 14.D0,  20.D0,
35178      & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
35179      & 10.D0, 10.D0, 9.5D0,  9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
35180      & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0,   5.5D0,  4.8D0,
35181      & 4.2D0, 7.5D0, 3.4D0,  2.5D0, 2.5D0, 2.1D0, 1.4D0,   1.D0,   .8D0,
35182      &  .6D0, .46D0,  .3D0, .2D0, .15D0, .13D0, 11*0.D0,  .95D0,  .65D0,
35183      & .48D0, .35D0,  .2D0, .18D0, .17D0, .16D0,  .15D0,   .1D0,  .09D0,
35184      & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0,  .2D0,   .1D0,
35185      & .08D0, .06D0, .045D0,   .03D0, .02D0, .01D0,      .005D0, .003D0,
35186      & 12*0.D0, .3D0, .24D0,   .18D0, .15D0, .13D0,  .12D0, .11D0, .1D0,
35187      & .09D0,  .08D0, .05D0,   .04D0, .03D0,  0.D0, 0.16D0, .7D0, 1.3D0,
35188      & 3.1D0,  4.5D0,  2.D0, 18*0.D0, 3*.0D0,  0.D0, 0.D0, 4.0D0, 11.D0,
35189      & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0,  1.5D0, .9D0, .55D0,
35190      &  .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0,   2.25D0, 3.3D0,
35191      & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
35192      & .64D0,  1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0,  4.4D0,   3.D0, 1.8D0,
35193      &  .9D0, .53D0, .28D0,      10*0.D0, 2*0.D0,  .25D0,  .82D0,
35194      & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0,  5.7D0, 3.9D0, 2.35D0, 1.15D0,
35195      & .69D0, .37D0, 10*0.D0,     7*0.D0,   .0D0, .34D0,  1.5D0, 3.47D0,
35196      & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0,  .3D0,  .15D0, 6*0.D0/
35197 *
35198       DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
35199      & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
35200      & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
35201      & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
35202      & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
35203      & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
35204      & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
35205      & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
35206      & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
35207      & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
35208      & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
35209      & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
35210      & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
35211      & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
35212      & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
35213      & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
35214      & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
35215      & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
35216      & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
35217      & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
35218 **** pi- p data                                                        *
35219       DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
35220      & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
35221      & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
35222      & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
35223      & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
35224      & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
35225      & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
35226      & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
35227      & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
35228      & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
35229      & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
35230      & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
35231      & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
35232      & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
35233      & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
35234      & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
35235      & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
35236      & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
35237      & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
35238 *
35239       DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
35240      & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
35241      & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
35242      & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
35243      & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
35244      & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
35245      & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
35246      & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
35247      & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
35248      & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
35249      & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
35250      & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
35251      & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
35252      & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
35253      & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
35254      & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
35255      & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
35256      & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
35257      & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
35258      & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
35259 **** pi- n data                                                        *
35260       DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
35261      & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
35262      & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
35263      & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
35264      & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
35265      & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
35266      & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
35267      & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
35268      & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
35269      & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
35270      & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
35271      & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
35272      & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
35273      & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
35274      & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
35275      & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
35276      & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
35277      & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
35278      & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
35279      & 3.3D0, 5.4D0, 7.D0 /
35280 **** k+  p data                                                        *
35281       DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
35282      & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
35283      & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
35284      & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
35285      & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
35286      & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35287      & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
35288      & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
35289      & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
35290      & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
35291      & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0,
35292      & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0,
35293      & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
35294 **** k+  n data                                                        *
35295       DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
35296      & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
35297      & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
35298      & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
35299      & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
35300      & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
35301      & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
35302      & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
35303      & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
35304      & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
35305      & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
35306      & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
35307      & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
35308      & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
35309      & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
35310      & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
35311      & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
35312      & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
35313      & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
35314 **** k-  p data                                                        *
35315       DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
35316      &     7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
35317      &    0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
35318      &    .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
35319      &    0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
35320      &    .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
35321      &    0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
35322      &    .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
35323      &    0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
35324      &    .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
35325      &    0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
35326      &    .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
35327       DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
35328      & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
35329      & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
35330      & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
35331      & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,  3*0.D0, 1.0D0, 3.03D0,
35332      & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
35333      & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
35334      & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
35335      & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
35336      & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
35337      & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
35338      & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
35339      & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
35340      & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
35341      & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
35342      & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
35343      & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
35344      & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
35345      & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
35346      & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
35347      & 10*0.D0/
35348 ***** k- n data                                                        *
35349       DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
35350      &        3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
35351      &        0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
35352      &        1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
35353      &        0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
35354      &        .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
35355      &        0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
35356      &       .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
35357       DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
35358      &  14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
35359      &  1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
35360      &  3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
35361      &  1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
35362      &  3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
35363      &  1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
35364      &  7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
35365      &  .39D0, .22D0, .07D0, 0.D0,
35366      &  6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
35367      &  4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
35368      &  10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
35369      &  13*0.D0, .1D0, .3D0, .7D0, 1.D0,
35370      &  13*0.D0, .1D0, .3D0, .7D0, 1.D0,
35371      &  9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
35372      &  5.10D0, 5.44D0, 5.3D0,
35373      &  4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
35374 *****  p p data                                                        *
35375       DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35376      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35377      &              0.D0, 3.6D0, 1.7D0, 10*0.D0,
35378      &              .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
35379      &              11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
35380      &              .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
35381      &              2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
35382      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35383      &              16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
35384      &              10*0.D0, 4.3D0, 7.6D0, 9.D0,
35385      &              10*0.D0, 1.7D0, 2.6D0, 3.D0,
35386      &              6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
35387      &              6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
35388      &              1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
35389      &              10*0.D0, 1.9D0, 4.1D0, 5.2D0/
35390 *****  p n data                                                        *
35391       DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35392      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35393      &              0.D0, 1.8D0, .2D0,  12*0.D0,
35394      &              3.2D0, 6.05D0, 9.9D0, 5.1D0,
35395      &              3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
35396      &              2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
35397      &              3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
35398      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35399      &              16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
35400      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35401      &              16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
35402      &              10*0.D0, .7D0, 5.1D0, 8.D0,
35403      &              10*0.D0, .7D0, 5.1D0, 8.D0,
35404      &              10*.0D0, .3D0, 2.8D0, 4.7D0,
35405      &              10*.0D0, .3D0, 2.8D0, 4.7D0,
35406      &              7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
35407      &              7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
35408      &              5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
35409 *   nn - data                                                          *
35410 *                                                                      *
35411       DATA SPKPV/  0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35412      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35413      &              0.D0, 3.6D0, 1.7D0, 12*0.D0,
35414      &              8.7D0, 17.7D0, 18.8D0, 15.9D0,
35415      &              11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
35416      &              .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
35417      &              2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
35418      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
35419      &              11.D0, 5.5D0, 3.5D0,
35420      &              10*0.D0, 4.3D0, 7.6D0, 9.D0,
35421      &              10*0.D0, 1.7D0, 2.6D0, 3.D0,
35422      &              6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
35423      &              6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
35424      &              1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
35425      &              10*0.D0, 1.9D0, 4.1D0, 5.2D0/
35426 ****************   ap - p - data                                       *
35427       DATA SAPPEL/ 0.D0,  176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
35428      &  50.D0,  50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
35429      &  25.D0,  22.D0, 21.D0, 20.D0, 18.D0, 17.D0,  11*0.D0,
35430      &  .05D0,  .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
35431      &  0.D0,  1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
35432      &  .1D0,  .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
35433      &  0.D0,  55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
35434      &  10.D0,  7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
35435      &  1.55D0,  1.3D0, .95D0, .75D0,
35436      &  0.D0,  3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
35437      &  .25D0,  .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35438      & .01D0,  .008D0, .006D0, .005D0/
35439       DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35440      & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35441      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
35442      & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
35443      & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
35444      & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
35445      & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
35446      & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
35447      & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
35448      & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0,
35449      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35450      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35451      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35452      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
35453      & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
35454      & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
35455      & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
35456      & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
35457      & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
35458      & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
35459 ****************   ap - n - data                                       *
35460       DATA SAPNEL/
35461      & 0.D0,  176.D0, 160.D0, 105.D0, 75.D0,  68.D0, 65.D0,
35462      & 50.D0, 50.D0,  43.D0,  42.D0,  40.5D0, 35.D0, 30.D0,  28.D0,
35463      & 25.D0, 22.D0,  21.D0,  20.D0,  18.D0,  17.D0, 11*0.D0,
35464      & .05D0, .15D0, .18D0,  .2D0,    .2D0,  .3D0,  .4D0,   .6D0,  .7D0,
35465      & .85D0,  0.D0,  1.D0,  .9D0,    .46D0, .3D0,  .23D0, .18D0, .16D0,
35466      & .14D0,  .1D0, .08D0, .05D0,    .02D0, .015D0, 4*.011D0, 3*.005D0,
35467      & 0.D0,  3.3D0,  3.D0, 1.5D0,     1.D0, .7D0,  .4D0,  .35D0, .4D0,
35468      & .25D0, .18D0, .08D0, .04D0,    .03D0, .023D0, .016D0, .014D0,
35469      & .01D0, .008D0, .006D0, .005D0 /
35470        DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35471      &  84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35472      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
35473      & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35474      & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
35475      & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
35476      & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
35477      & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35478      & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35479      & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35480      & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
35481      & 4.9D0, 8.5D0,  15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
35482      & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
35483      & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
35484 *                                                                      *
35485 *                                                                      *
35486 ****************   an - p - data                                       *
35487 *                                                                      *
35488       DATA SANPEL/
35489      & 0.D0,  176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
35490      & 50.D0, 43.D0,  42.D0,  40.5D0, 35.D0, 30.D0, 28.D0,
35491      & 25.D0, 22.D0,  21.D0,  20.D0,  18.D0, 17.D0, 11*0.D0, .05D0,
35492      & .15D0, .18D0,   .2D0,   .2D0,   .3D0,  .4D0, .6D0,   .7D0, .85D0,
35493      & 0.D0,   1.D0,   .9D0,  .46D0,  .3D0,  .23D0, .18D0, .16D0, .14D0,
35494      & .1D0,  .08D0,  .05D0,  .02D0, .015D0, 4*.011D0, 3*.005D0,
35495      & 0.D0,  3.3D0,  3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
35496      & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35497      & .01D0, .008D0, .006D0, .005D0 /
35498       DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35499      & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35500      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
35501      & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35502      & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
35503      & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
35504      & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
35505      & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35506      & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35507      & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35508      & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
35509      & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
35510      & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
35511      & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
35512 ****  ko - n - data                                                    *
35513       DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
35514      &      6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
35515      &      0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
35516      &    3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
35517      &     1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35518      &    3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
35519      &     1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35520      &    4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
35521      &     1.4D0, 1.2D0, 1.05D0, .9D0, .66D0,  .5D0,
35522      &    7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
35523      &   11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
35524      &    4.85D0, 4.9D0,
35525      &   10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
35526      &    6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
35527      &    2.85D0, 2.35D0, 2.01D0, 1.8D0,
35528      &   12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
35529      &   12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0  /
35530 **** ako - p - data                                                    *
35531       DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
35532      & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
35533      & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
35534      & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
35535      & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
35536      & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
35537      & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
35538      & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
35539      & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
35540      & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
35541      & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
35542      & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
35543      & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
35544      & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
35545      & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
35546      & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
35547      & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
35548      & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
35549      & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
35550      & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
35551      & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
35552       DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
35553      & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
35554 *=                                               end*block.blkdt3      *
35555       END
35556
35557 *$ CREATE DT_QEL_POL.FOR
35558 *COPY DT_QEL_POL
35559 *
35560 *===qel_pol============================================================*
35561 *
35562       SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
35563
35564       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35565       SAVE
35566
35567       CALL DT_MASS_INI
35568       CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
35569
35570       RETURN
35571       END
35572
35573 *$ CREATE DT_GEN_QEL.FOR
35574 *COPY DT_GEN_QEL
35575 C==================================================================
35576 C   Generation of  a Quasi-Elastic neutrino scattering
35577 C==================================================================
35578 *
35579 *===gen_qel============================================================*
35580 *
35581       SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
35582
35583 C...Generate a quasi-elastic   neutrino/antineutrino
35584 C.  Interaction on a nuclear target
35585 C.  INPUT  : LTYP = neutrino type (1,...,6)
35586 C.           ENU (GeV) = neutrino energy
35587 C----------------------------------------------------
35588
35589       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35590       SAVE
35591
35592       PARAMETER ( LINP = 10 ,
35593      &            LOUT = 6 ,
35594      &            LDAT = 9 )
35595       PARAMETER (MAXLND=4000)
35596       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
35597 * nuclear potential
35598       LOGICAL LFERMI
35599       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
35600      &                EBINDP(2),EBINDN(2),EPOT(2,210),
35601      &                ETACOU(2),ICOUL,LFERMI
35602 * steering flags for qel neutrino scattering modules
35603       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
35604 **sr - removed (not needed)
35605 C     COMMON /CBAD/  LBAD, NBAD
35606 C     COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
35607 **
35608
35609       DIMENSION PI(3),PO(3)
35610 CJR+
35611       DATA ININU/0/
35612 CJR-
35613 C     REAL*8 DBETA(3)
35614 C     REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
35615       DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
35616       DATA AMN  /0.93827231D0, 0.93956563D0/
35617       DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
35618       DATA INIPRI/0/
35619
35620 C     DATA PFERMI/0.22D0/
35621 CGB+...Binding Energy
35622       DATA EBIND/0.008D0/
35623 CGB-...
35624
35625       ININU=ININU+1
35626       IF(ININU.EQ.1)NDSIG=0
35627       LBAD = 0
35628       enu0=enu
35629 c      write(*,*) enu0
35630 C...Lepton mass
35631       AML = AML0(LTYP)       !  massa leptoni
35632       AML2 = AML**2          !  massa leptoni **2
35633 C...Particle labels (LUND)
35634       N = 5
35635       K(1,1) = 21
35636       K(2,1) = 21
35637       K(3,1) = 21
35638       K(3,3) = 1
35639       K(4,1) = 1
35640       K(4,3) = 1
35641       K(5,1) = 1
35642       K(5,3) = 2
35643       K0 = (LTYP-1)/2          !  2
35644       K1 = LTYP/2              !  2
35645       KA = 12 + 2*K0           !  16
35646       IS = -1 + 2*LTYP - 4*K1  !  -1 +10 -8 = 1
35647       K(1,2) = IS*KA
35648       K(4,2) = IS*(KA-1)
35649       K(3,2) = IS*24
35650       LNU = 2 - LTYP + 2*K1    !  2 - 5 + 2 = - 1
35651       IF (LNU .EQ. 2)  THEN
35652         K(2,2) = 2212
35653         K(5,2) = 2112
35654         AMI = AMN(1)
35655         AMF = AMN(2)
35656 CJR+
35657         PFERMI=PFERMN(2)
35658 CJR-
35659       ELSE
35660         K(2,2) = 2112
35661         K(5,2) = 2212
35662         AMI = AMN(2)
35663         AMF = AMN(1)
35664 CJR+
35665         PFERMI=PFERMP(2)
35666 CJR-
35667       ENDIF
35668       AMI2 = AMI**2
35669       AMF2 = AMF**2
35670
35671       DO IGB=1,5
35672         P(3,IGB) = 0.
35673         P(4,IGB) = 0.
35674         P(5,IGB) = 0.
35675       END DO
35676
35677       NTRY = 0
35678 CGB+...
35679       EFMAX  = SQRT(PFERMI**2 + AMI2) -AMI             ! max. Fermi Energy
35680       ENWELL = EFMAX + EBIND ! depth of nuclear potential well
35681 CGB-...
35682
35683   100 CONTINUE
35684
35685 C...4-momentum initial lepton
35686       P(1,5) = 0.     ! massa
35687       P(1,4) = ENU0    ! energia
35688       P(1,1) = 0.     ! px
35689       P(1,2) = 0.     ! py
35690       P(1,3) = ENU0    ! pz
35691
35692 C     PF = PFERMI*PYR(0)**(1./3.)
35693 c       write(23,*) PYR(0)
35694 c      write(*,*) 'Pfermi=',PF
35695 c      PF = 0.
35696       NTRY=NTRY+1
35697 C     IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
35698       IF (NTRY .GT. 500)  THEN
35699         LBAD = 1
35700         WRITE (LOUT,1001)  NBAD, ENU
35701         RETURN
35702       ENDIF
35703 C     CT = -1. + 2.*PYR(0)
35704 c      CT = -1.
35705 C     ST =  SQRT(1.-CT*CT)
35706 C     F = 2.*3.1415926*PYR(0)
35707 c      F = 0.
35708
35709 C     P(2,4) = SQRT(PF*PF + MI2) - EBIND  ! energia
35710 C     P(2,1) = PF*ST*COS(F)               ! px
35711 C     P(2,2) = PF*ST*SIN(F)               ! py
35712 C     P(2,3) = PF*CT                      ! pz
35713 C     P(2,5) = SQRT(P(2,4)**2-PF*PF)      ! massa
35714        P(2,1) = P21
35715        P(2,2) = P22
35716        P(2,3) = P23
35717        P(2,4) = P24
35718        P(2,5) = P25
35719       beta1=-p(2,1)/p(2,4)
35720       beta2=-p(2,2)/p(2,4)
35721       beta3=-p(2,3)/p(2,4)
35722       N=2
35723 C      WRITE(6,*)' before transforming into target rest frame'
35724       CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
35725 C      print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
35726       N=5
35727
35728       phi11=atan(p(1,2)/p(1,3))
35729       pi(1)=p(1,1)
35730       pi(2)=p(1,2)
35731       pi(3)=p(1,3)
35732
35733       CALL DT_TESTROT(PI,Po,PHI11,1)
35734       DO ll=1,3
35735         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35736       END DO
35737 c        WRITE(*,*) po
35738       p(1,1)=po(1)
35739       p(1,2)=po(2)
35740       p(1,3)=po(3)
35741       phi12=atan(p(1,1)/p(1,3))
35742
35743       pi(1)=p(1,1)
35744       pi(2)=p(1,2)
35745       pi(3)=p(1,3)
35746       CALL DT_TESTROT(Pi,Po,PHI12,2)
35747       DO ll=1,3
35748         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35749       END DO
35750 c        WRITE(*,*) po
35751       p(1,1)=po(1)
35752       p(1,2)=po(2)
35753       p(1,3)=po(3)
35754
35755       enu=p(1,4)
35756
35757 C...Kinematical limits in Q**2
35758 c      S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) !            ????
35759       S = P(2,5)**2 + 2.*ENU*P(2,5)
35760       SQS = SQRT(S)                          ! E centro massa
35761       IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
35762       ELF = (S-AMF2+AML2)/(2.*SQS)           ! energia leptone finale p
35763       PSTAR = (S-P(2,5)**2)/(2.*SQS)       ! p* neutrino nel c.m.
35764       PLF = SQRT(ELF**2-AML2)               ! 3-momento leptone finale
35765       Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)    ! + o -
35766       Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)    ! according con cos(theta)
35767       IF (Q2MIN .LT. 0.)   Q2MIN = 0.      ! ??? non fisico
35768
35769 C...Generate Q**2
35770       DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
35771   200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
35772       DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
35773       IF (DSIG .LT.  DSIGMAX*PYR(0)) GOTO 200
35774       CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
35775       NDSIG=NDSIG+1
35776 C     WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
35777 C    &Q2,Q2min,Q2MAX,DSIGEV
35778
35779 C...c.m. frame. Neutrino along z axis
35780       DETOT = (P(1,4)) + (P(2,4)) ! e totale
35781       DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
35782       DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
35783       DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
35784 c      WRITE(*,*)
35785 c      WRITE(*,*)
35786 C      WRITE(*,*) 'Input values laboratory frame'
35787       N=2
35788
35789       CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
35790
35791       N=5
35792 c      STHETA = ULANGL(P(1,3),P(1,1))
35793 c      write(*,*) 'stheta' ,stheta
35794 c      stheta=0.
35795 c      CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
35796 c      WRITE(*,*)
35797 c      WRITE(*,*)
35798 C      WRITE(*,*) 'Output values cm frame'
35799 C...Kinematic in c.m. frame
35800       CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
35801       STSTAR = SQRT(1.-CTSTAR**2)
35802       PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
35803       P(4,5) = AML                  ! massa leptone
35804       P(4,4) = ELF                 ! e leptone
35805       P(4,3) = PLF*CTSTAR          ! px
35806       P(4,1) = PLF*STSTAR*COS(PHI) ! py
35807       P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
35808
35809       P(5,5) = AMF                  ! barione
35810       P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
35811       P(5,3) = -P(4,3)             ! px
35812       P(5,1) = -P(4,1)             ! py
35813       P(5,2) = -P(4,2)             ! pz
35814
35815       P(3,5) = -Q2
35816       P(3,1) = P(1,1)-P(4,1)
35817       P(3,2) = P(1,2)-P(4,2)
35818       P(3,3) = P(1,3)-P(4,3)
35819       P(3,4) = P(1,4)-P(4,4)
35820
35821 C...Transform back to laboratory  frame
35822 C      WRITE(*,*) 'before going back to nucl rest frame'
35823 c      CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
35824       N=5
35825
35826       CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
35827
35828 C      WRITE(*,*) 'Now back in nucl rest frame'
35829       IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
35830
35831 c********************************************
35832
35833       DO kw=1,5
35834         pi(1)=p(kw,1)
35835         pi(2)=p(kw,2)
35836         pi(3)=p(kw,3)
35837         CALL DT_TESTROT(Pi,Po,PHI12,3)
35838         DO ll=1,3
35839           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35840         END DO
35841         p(kw,1)=po(1)
35842         p(kw,2)=po(2)
35843         p(kw,3)=po(3)
35844       END DO
35845 c********************************************
35846
35847       DO kw=1,5
35848         pi(1)=p(kw,1)
35849         pi(2)=p(kw,2)
35850         pi(3)=p(kw,3)
35851         CALL DT_TESTROT(Pi,Po,PHI11,4)
35852         DO ll=1,3
35853           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35854         END DO
35855         p(kw,1)=po(1)
35856         p(kw,2)=po(2)
35857         p(kw,3)=po(3)
35858       END DO
35859
35860 c********************************************
35861
35862 C      WRITE(*,*) 'Now back in lab frame'
35863
35864       CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
35865
35866 CGB+...
35867 C...test (on final momentum of nucleon) if Fermi-blocking
35868 C...is operating
35869       ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
35870      &  - P(5,5)
35871       IF (ENUCL.LT. EFMAX) THEN
35872         IF(INIPRI.LT.10)THEN
35873           INIPRI=INIPRI+1
35874 C         WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
35875 C...the interaction is not possible due to Pauli-Blocking and
35876 C...it must be resampled
35877         ENDIF
35878         GOTO 100
35879       ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
35880         IF(INIPRI.LT.10)THEN
35881           INIPRI=INIPRI+1
35882 C     WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
35883         ENDIF
35884 C                      Reject (J:R) here all these events
35885 C                      are otherwise rejected in dpmjet
35886         GOTO 100
35887 C...the interaction is possible, but the nucleon remains inside
35888 C...the nucleus. The nucleus is therefore left excited.
35889 C...We treat this case as a nucleon with 0 kinetic energy.
35890 C       P(5,5) = AMF
35891 C       P(5,4) = AMF
35892 C       P(5,1) = 0.
35893 C       P(5,2) = 0.
35894 C       P(5,3) = 0.
35895       ELSE IF (ENUCL.GE.ENWELL) THEN
35896 C     WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
35897 C...the interaction is possible, the nucleon can exit the nucleus
35898 C...but the nuclear well depth must be subtracted. The nucleus could be
35899 C...left in an excited state.
35900         Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
35901 C       P(5,4) = ENUCL-ENWELL + AMF
35902         Pnucl = SQRT(P(5,4)**2-AMF**2)
35903 C...The 3-momentum is scaled assuming that the direction remains
35904 C...unaffected
35905         P(5,1) = P(5,1) * Pnucl/Pstart
35906         P(5,2) = P(5,2) * Pnucl/Pstart
35907         P(5,3) = P(5,3) * Pnucl/Pstart
35908 C     WRITE(6,*)' qel new P(5,4) ',P(5,4)
35909       ENDIF
35910 CGB-...
35911       DSIGSU=DSIGSU+DSIGEV
35912
35913          GA=P(4,4)/P(4,5)
35914          BGX=P(4,1)/P(4,5)
35915          BGY=P(4,2)/P(4,5)
35916          BGZ=P(4,3)/P(4,5)
35917 *
35918          DBETB(1)=BGX/GA
35919          DBETB(2)=BGY/GA
35920          DBETB(3)=BGZ/GA
35921          IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
35922
35923             CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
35924
35925          ENDIF
35926 c
35927 C      PRINT*,' FINE   EVENTO '
35928       enu=enu0
35929       RETURN
35930
35931  1001 FORMAT(2X, 'DT_GEN_QEL   : event rejected ', I5,  G10.3)
35932       END
35933
35934 *$ CREATE DT_MASS_INI.FOR
35935 *COPY DT_MASS_INI
35936 C====================================================================
35937 C.  Masses
35938 C====================================================================
35939 *
35940 *===mass_ini===========================================================*
35941 *
35942       SUBROUTINE DT_MASS_INI
35943 C...Initialize  the kinematics for the quasi-elastic cross section
35944
35945       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35946       SAVE
35947
35948 * particle masses used in qel neutrino scattering modules
35949       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
35950      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
35951      &                EMPROTSQ,EMNEUTSQ,EMNSQ
35952
35953       EML(1) = 0.51100D-03   ! e-
35954       EML(2) = EML(1)        ! e+
35955       EML(3) = 0.105659D0      ! mu-
35956       EML(4) = EML(3)        ! mu+
35957       EML(5) = 1.7777D0        ! tau-
35958       EML(6) = EML(5)        ! tau+
35959       EMPROT = 0.93827231D0    ! p
35960       EMNEUT = 0.93956563D0    ! n
35961       EMPROTSQ = EMPROT**2
35962       EMNEUTSQ = EMNEUT**2
35963       EMN = (EMPROT + EMNEUT)/2.
35964       EMNSQ = EMN**2
35965       DO J=1,3
35966         J0 = 2*(J-1)
35967         EMN1(J0+1) = EMNEUT
35968         EMN1(J0+2) = EMPROT
35969         EMN2(J0+1) = EMPROT
35970         EMN2(J0+2) = EMNEUT
35971       ENDDO
35972       DO J=1,6
35973         EMLSQ(J) = EML(J)**2
35974         ETQE(J)  = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
35975       ENDDO
35976       RETURN
35977       END
35978
35979 *$ CREATE DT_DSQEL_Q2.FOR
35980 *COPY DT_DSQEL_Q2
35981 *
35982 *===dsqel_q2===========================================================*
35983 *
35984       DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
35985
35986 C...differential cross section for  Quasi-Elastic scattering
35987 C.       nu + N -> l + N'
35988 C.  From Llewellin Smith  Phys.Rep.  3C, 261, (1971).
35989 C.
35990 C.  INPUT :  JTYP = 1,...,6    nu_e, ...., nubar_tau
35991 C.           ENU (GeV) =  Neutrino energy
35992 C.           Q2  (GeV**2) =  (Transfer momentum)**2
35993 C.
35994 C.  OUTPUT : DSQEL_Q2  = differential  cross section :
35995 C.                       dsigma/dq**2  (10**-38 cm+2/GeV**2)
35996 C------------------------------------------------------------------
35997
35998       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35999       SAVE
36000
36001 * particle masses used in qel neutrino scattering modules
36002       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
36003      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
36004      &                EMPROTSQ,EMNEUTSQ,EMNSQ
36005 **sr - removed (not needed)
36006 C     COMMON /CAXIAL/ FA0, AXIAL2
36007 **
36008
36009       DIMENSION SS(6)
36010       DATA C0 /0.17590D0 /  ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
36011       DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
36012       DATA AXIAL2 /1.03D0/  ! to be checked
36013
36014       FA0=-1.253D0
36015       CSI = 3.71D0                   !  ???
36016       GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2   ! G_e(q**2)
36017       GVM = (1.D0+CSI)*GVE           ! G_m (q**2)
36018       X = Q2/(EMN*EMN)     ! emn=massa barione
36019       XA = X/4.D0
36020       FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
36021       FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
36022       FA = FA0/(1.D0 + Q2/AXIAL2)**2
36023       FFA = FA*FA
36024       FFV1 = FV1*FV1
36025       FFV2 = FV2*FV2
36026       RM = EMLSQ(JTYP)/(EMN*EMN)            ! emlsq(jtyp)
36027       A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
36028       A2 = -RM * ((FV1 + FV2)**2 +  FFA)
36029       AA = (XA+0.25D0*RM)*(A1 + A2)
36030       BB = -X*FA*(FV1 + FV2)
36031       CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
36032       SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
36033       DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU)  !
36034       IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
36035
36036       RETURN
36037       END
36038
36039 *$ CREATE DT_PREPOLA.FOR
36040 *COPY DT_PREPOLA
36041 *
36042 *===prepola============================================================*
36043 *
36044       SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
36045
36046       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36047       SAVE
36048 c
36049 c By G. Battistoni and E. Scapparone (sept. 1997)
36050 c According to:
36051 c     Albright & Jarlskog, Nucl Phys B84 (1975) 467
36052 c
36053 c
36054       PARAMETER (MAXLND=4000)
36055       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
36056       COMMON /QNPOL/ POLARX(4),PMODUL
36057 * particle masses used in qel neutrino scattering modules
36058       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
36059      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
36060      &                EMPROTSQ,EMNEUTSQ,EMNSQ
36061 * steering flags for qel neutrino scattering modules
36062       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
36063 **sr - removed (not needed)
36064 C     COMMON /CAXIAL/ FA0, AXIAL2
36065 C     COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
36066 C    &        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
36067 **
36068       REAL*8 POL(4,4),BB2(3)
36069       DIMENSION SS(6)
36070 C     DATA C0 /0.17590D0 /  ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
36071       DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
36072 **sr uncommented since common block CAXIAL is now commented
36073       DATA AXIAL2 /1.03D0/  ! to be checked
36074 **
36075
36076       RML=P(4,5)
36077       RMM=0.93960D+00
36078       FM2 = RMM**2
36079       MPI = 0.135D+00
36080       OLDQ2=Q2
36081       FA0=-1.253D+00
36082       CSI = 3.71D+00                      !
36083       GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2   ! G_e(q**2)
36084       GVM = (1.D0+CSI)*GVE           ! G_m (q**2)
36085       X = Q2/(EMN*EMN)     ! emn=massa barione
36086       XA = X/4.D0
36087       FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
36088       FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
36089       FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
36090       FFA = FA*FA
36091       FFV1 = FV1*FV1
36092       FFV2 = FV2*FV2
36093       FP=2.D0*FA*RMM/(MPI**2 + Q2)
36094       RM = EMLSQ(JTYP)/(EMN*EMN)            ! emlsq(jtyp)
36095       A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
36096       A2 = -RM * ((FV1 + FV2)**2 +  FFA)
36097       AA = (XA+0.25D+00*RM)*(A1 + A2)
36098       BB = -X*FA*(FV1 + FV2)
36099       CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
36100       SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
36101
36102       OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2   )  ! articolo di ll...-smith
36103       OMEGA2=4.D+00*CC
36104       OMEGA3=2.D+00*FA*(FV1+FV2)
36105       OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
36106      1     (Q2/FM2))*FP**2)
36107       OMEGA5=OMEGA2
36108       OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
36109       WW1=2.D+00*OMEGA1*EMN**2
36110       WW2=2.D+00*OMEGA2*EMN**2
36111       WW3=2.D+00*OMEGA3*EMN**2
36112       WW4=2.D+00*OMEGA4*EMN**2
36113       WW5=2.D+00*OMEGA5*EMN**2
36114
36115       DO I=1,3
36116         BB2(I)=-P(4,I)/P(4,4)
36117       END DO
36118 c      WRITE(*,*)
36119 c      WRITE(*,*)
36120 c      WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
36121       N=5
36122       CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
36123 * NOW PARTICLES ARE IN THE SCATTERED LEPTON  REST FRAME
36124 c      WRITE(*,*)
36125 c      WRITE(*,*)
36126 c      WRITE(*,*) 'Prepola: now in lepton rest frame'
36127       EE=ENU
36128       QM2=Q2+RML**2
36129       U=Q2/(2.*RMM)
36130       FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
36131      +     (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
36132      +     ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
36133
36134       FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
36135      +     - ((RML**2)/FM2)*WW4                        !<=FM2 inv di RMM!!
36136
36137       FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
36138
36139       DO I=1,3
36140         POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
36141         POLARX(I)=POL(4,I)
36142       END DO
36143
36144       PMODUL=0.D0
36145       DO I=1,3
36146         PMODUL=PMODUL+POL(4,I)**2
36147       END DO
36148
36149       IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
36150          IF(NEUDEC.EQ.1) THEN
36151             CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
36152      +        ETL,PXL,PYL,PZL,
36153      +        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36154 c
36155 c     Tau has decayed in muon
36156 c
36157          ENDIF
36158          IF(NEUDEC.EQ.2) THEN
36159             CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
36160      +        ETL,PXL,PYL,PZL,
36161      +        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36162 c
36163 c     Tau has decayed in electron
36164 c
36165          ENDIF
36166          K(4,1)=15
36167          K(4,4) = 6
36168          K(4,5) = 8
36169          N=N+3
36170 c
36171 c     fill common for muon(electron)
36172 c
36173          P(6,1)=PXL
36174          P(6,2)=PYL
36175          P(6,3)=PZL
36176          P(6,4)=ETL
36177          K(6,1)=1
36178          IF(JTYP.EQ.5) THEN
36179             IF(NEUDEC.EQ.1) THEN
36180                P(6,5)=EML(JTYP-2)
36181                K(6,2)=13
36182             ELSEIF(NEUDEC.EQ.2) THEN
36183                P(6,5)=EML(JTYP-4)
36184                K(6,2)=11
36185             ENDIF
36186          ELSEIF(JTYP.EQ.6) THEN
36187             IF(NEUDEC.EQ.1) THEN
36188                K(6,2)=-13
36189             ELSEIF(NEUDEC.EQ.2) THEN
36190                K(6,2)=-11
36191             ENDIF
36192          END IF
36193          K(6,3)=4
36194          K(6,4)=0
36195          K(6,5)=0
36196 c
36197 c     fill common for tau_(anti)neutrino
36198 c
36199          P(7,1)=PXB
36200          P(7,2)=PYB
36201          P(7,3)=PZB
36202          P(7,4)=ETB
36203          P(7,5)=0.
36204          K(7,1)=1
36205          IF(JTYP.EQ.5) THEN
36206             K(7,2)=16
36207          ELSEIF(JTYP.EQ.6) THEN
36208             K(7,2)=-16
36209          END IF
36210          K(7,3)=4
36211          K(7,4)=0
36212          K(7,5)=0
36213 c
36214 c     Fill common for muon(electron)_(anti)neutrino
36215 c
36216          P(8,1)=PXN
36217          P(8,2)=PYN
36218          P(8,3)=PZN
36219          P(8,4)=ETN
36220          P(8,5)=0.
36221          K(8,1)=1
36222          IF(JTYP.EQ.5) THEN
36223             IF(NEUDEC.EQ.1) THEN
36224                K(8,2)=-14
36225             ELSEIF(NEUDEC.EQ.2) THEN
36226                K(8,2)=-12
36227             ENDIF
36228          ELSEIF(JTYP.EQ.6) THEN
36229             IF(NEUDEC.EQ.1) THEN
36230                K(8,2)=14
36231             ELSEIF(NEUDEC.EQ.2) THEN
36232                K(8,2)=12
36233             ENDIF
36234          END IF
36235          K(8,3)=4
36236          K(8,4)=0
36237          K(8,5)=0
36238       ENDIF
36239 c      WRITE(*,*)
36240 c      WRITE(*,*)
36241
36242 c      IF(PMODUL.GE.1.D+00) THEN
36243 c        WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
36244 c        write(*,*) pmodul
36245 c        DO I=1,3
36246 c          POL(4,I)=POL(4,I)/PMODUL
36247 c          POLARX(I)=POL(4,I)
36248 c        END DO
36249 c        PMODUL=0.
36250 c        DO I=1,3
36251 c          PMODUL=PMODUL+POL(4,I)**2
36252 c        END DO
36253 c        WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
36254 c
36255 c      ENDIF
36256
36257 c      WRITE(*,*) 'PMODUL = ',PMODUL
36258
36259 c      WRITE(*,*)
36260 c      WRITE(*,*)
36261 c      WRITE(*,*) 'prepola: Now back to nucl rest frame'
36262       CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
36263
36264       XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
36265       YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
36266       ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
36267       DO NDC =6,8
36268          V(NDC,1) = XDC
36269          V(NDC,2) = YDC
36270          V(NDC,3) = ZDC
36271       END DO
36272
36273       RETURN
36274       END
36275
36276 *$ CREATE DT_TESTROT.FOR
36277 *COPY DT_TESTROT
36278 *
36279 *===testrot============================================================*
36280 *
36281       SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
36282
36283       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36284       SAVE
36285
36286       DIMENSION ROT(3,3),PI(3),PO(3)
36287
36288       IF (MODE.EQ.1) THEN
36289          ROT(1,1) = 1.D0
36290          ROT(1,2) = 0.D0
36291          ROT(1,3) = 0.D0
36292          ROT(2,1) = 0.D0
36293          ROT(2,2) = COS(PHI)
36294          ROT(2,3) = -SIN(PHI)
36295          ROT(3,1) = 0.D0
36296          ROT(3,2) = SIN(PHI)
36297          ROT(3,3) = COS(PHI)
36298       ELSEIF (MODE.EQ.2) THEN
36299          ROT(1,1) = 0.D0
36300          ROT(1,2) = 1.D0
36301          ROT(1,3) = 0.D0
36302          ROT(2,1) = COS(PHI)
36303          ROT(2,2) = 0.D0
36304          ROT(2,3) = -SIN(PHI)
36305          ROT(3,1) = SIN(PHI)
36306          ROT(3,2) = 0.D0
36307          ROT(3,3) = COS(PHI)
36308       ELSEIF (MODE.EQ.3) THEN
36309          ROT(1,1) = 0.D0
36310          ROT(2,1) = 1.D0
36311          ROT(3,1) = 0.D0
36312          ROT(1,2) = COS(PHI)
36313          ROT(2,2) = 0.D0
36314          ROT(3,2) = -SIN(PHI)
36315          ROT(1,3) = SIN(PHI)
36316          ROT(2,3) = 0.D0
36317          ROT(3,3) = COS(PHI)
36318       ELSEIF (MODE.EQ.4) THEN
36319          ROT(1,1) = 1.D0
36320          ROT(2,1) = 0.D0
36321          ROT(3,1) = 0.D0
36322          ROT(1,2) = 0.D0
36323          ROT(2,2) = COS(PHI)
36324          ROT(3,2) = -SIN(PHI)
36325          ROT(1,3) = 0.D0
36326          ROT(2,3) = SIN(PHI)
36327          ROT(3,3) = COS(PHI)
36328       ELSE
36329          STOP ' TESTROT: mode not supported!'
36330       ENDIF
36331       DO 1 J=1,3
36332         PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
36333     1 CONTINUE
36334
36335       RETURN
36336       END
36337
36338 *$ CREATE DT_LEPDCYP.FOR
36339 *COPY DT_LEPDCYP
36340 *
36341 *===lepdcyp============================================================*
36342 *
36343       SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
36344      &                      ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36345 C
36346 C-----------------------------------------------------------------
36347 C
36348 C   Author   :- G. Battistoni         10-NOV-1995
36349 C
36350 C=================================================================
36351 C
36352 C   Purpose   : performs decay of polarized lepton in
36353 C               its rest frame: a => b + l + anti-nu
36354 C               (Example: mu- => nu-mu + e- + anti-nu-e)
36355 C               Polarization is assumed along Z-axis
36356 C               WARNING:
36357 C               1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
36358 C                  OF NEGLIGIBLE MASS
36359 C               2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
36360 C                  IN THIS VERSION
36361 C
36362 C   Method    : modifies phase space distribution obtained
36363 C               by routine EXPLOD using a rejection against the
36364 C               matrix element for unpolarized lepton decay
36365 C
36366 C   Inputs    : Mass of a :  AMA
36367 C               Mass of l :  AML
36368 C               Polar. of a: POL
36369 C               (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
36370 C                                                 POL = -1)
36371 C
36372 C   Outputs   : kinematic variables in the rest frame of decaying lepton
36373 C               ETL,PXL,PYL,PZL 4-moment of l
36374 C               ETB,PXB,PYB,PZB 4-moment of b
36375 C               ETN,PXN,PYN,PZN 4-moment of anti-nu
36376 C
36377 C============================================================
36378 C +
36379 C Declarations.
36380 C -
36381       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36382       SAVE
36383
36384       PARAMETER ( LINP = 10 ,
36385      &            LOUT = 6 ,
36386      &            LDAT = 9 )
36387       PARAMETER ( KALGNM = 2 )
36388       PARAMETER ( ANGLGB = 5.0D-16 )
36389       PARAMETER ( ANGLSQ = 2.5D-31 )
36390       PARAMETER ( AXCSSV = 0.2D+16 )
36391       PARAMETER ( ANDRFL = 1.0D-38 )
36392       PARAMETER ( AVRFLW = 1.0D+38 )
36393       PARAMETER ( AINFNT = 1.0D+30 )
36394       PARAMETER ( AZRZRZ = 1.0D-30 )
36395       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
36396       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
36397       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
36398       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
36399       PARAMETER ( CSNNRM = 2.0D-15 )
36400       PARAMETER ( DMXTRN = 1.0D+08 )
36401       PARAMETER ( ZERZER = 0.D+00 )
36402       PARAMETER ( ONEONE = 1.D+00 )
36403       PARAMETER ( TWOTWO = 2.D+00 )
36404       PARAMETER ( THRTHR = 3.D+00 )
36405       PARAMETER ( FOUFOU = 4.D+00 )
36406       PARAMETER ( FIVFIV = 5.D+00 )
36407       PARAMETER ( SIXSIX = 6.D+00 )
36408       PARAMETER ( SEVSEV = 7.D+00 )
36409       PARAMETER ( EIGEIG = 8.D+00 )
36410       PARAMETER ( ANINEN = 9.D+00 )
36411       PARAMETER ( TENTEN = 10.D+00 )
36412       PARAMETER ( HLFHLF = 0.5D+00 )
36413       PARAMETER ( ONETHI = ONEONE / THRTHR )
36414       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
36415       PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
36416       PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
36417       PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
36418       PARAMETER ( CLIGHT = 2.99792458         D+10 )
36419       PARAMETER ( AVOGAD = 6.0221367          D+23 )
36420       PARAMETER ( AMELGR = 9.1093897          D-28 )
36421       PARAMETER ( PLCKBR = 1.05457266         D-27 )
36422       PARAMETER ( ELCCGS = 4.8032068          D-10 )
36423       PARAMETER ( ELCMKS = 1.60217733         D-19 )
36424       PARAMETER ( AMUGRM = 1.6605402          D-24 )
36425       PARAMETER ( AMMUMU = 0.113428913        D+00 )
36426       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
36427       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
36428       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
36429       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
36430       PARAMETER ( PLABRC = 0.197327053        D+00 )
36431       PARAMETER ( AMELCT = 0.51099906         D-03 )
36432       PARAMETER ( AMUGEV = 0.93149432         D+00 )
36433       PARAMETER ( AMMUON = 0.105658389        D+00 )
36434       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
36435       PARAMETER ( GEVMEV = 1.0                D+03 )
36436       PARAMETER ( EMVGEV = 1.0                D-03 )
36437       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
36438       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
36439       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
36440 C +
36441 C    variables for EXPLOD
36442 C -
36443       PARAMETER ( KPMX = 10 )
36444       DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
36445      &          PZEXPL (KPMX), ETEXPL (KPMX)
36446 C +
36447 C      test variables
36448 C -
36449 **sr - removed (not needed)
36450 C     COMMON /GBATNU/ ELERAT,NTRY
36451 **
36452 C +
36453 C     Initializes test variables
36454 C -
36455       NTRY = 0
36456       ELERAT = 0.D+00
36457 C +
36458 C     Maximum value for matrix element
36459 C -
36460       ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
36461      &  SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
36462 C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
36463 C     Inputs for EXPLOD
36464 C part. no. 1 is l       (e- in mu- decay)
36465 C part. no. 2 is b       (nu-mu in mu- decay)
36466 C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
36467 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
36468       NPEXPL = 3
36469       ETOTEX = AMA
36470       AMEXPL(1) = AML
36471       AMEXPL(2) = 0.D+00
36472       AMEXPL(3) = 0.D+00
36473 C +
36474 C     phase space distribution
36475 C -
36476   100 CONTINUE
36477       NTRY = NTRY + 1
36478
36479       CALL DT_EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
36480      &                 PYEXPL, PZEXPL )
36481
36482 C +
36483 C  Calculates matrix element:
36484 C  64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
36485 C  Here CTH is the cosine of the angle between anti-nu and Z axis
36486 C -
36487       CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
36488      &  PZEXPL(3)**2 )
36489       PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
36490       PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
36491      &     PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
36492       ELEMAT = 16.D+00 * PROD1 * PROD2
36493       IF(ELEMAT.GT.ELEMAX) THEN
36494         WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
36495         STOP
36496       ENDIF
36497 C +
36498 C     Here performs the rejection
36499 C -
36500       TEST = DT_RNDM(ETOTEX) * ELEMAX
36501       IF ( TEST .GT. ELEMAT ) GO TO 100
36502 C +
36503 C     final assignment of variables
36504 C -
36505       ELERAT = ELEMAT/ELEMAX
36506       ETL = ETEXPL(1)
36507       PXL = PXEXPL(1)
36508       PYL = PYEXPL(1)
36509       PZL = PZEXPL(1)
36510       ETB = ETEXPL(2)
36511       PXB = PXEXPL(2)
36512       PYB = PYEXPL(2)
36513       PZB = PZEXPL(2)
36514       ETN = ETEXPL(3)
36515       PXN = PXEXPL(3)
36516       PYN = PYEXPL(3)
36517       PZN = PZEXPL(3)
36518   999 RETURN
36519       END
36520
36521 *$ CREATE DT_GEN_DELTA.FOR
36522 *COPY DT_GEN_DELTA
36523 C==================================================================
36524 C.  Generation of  Delta resonance events
36525 C==================================================================
36526 *
36527 *===gen_delta==========================================================*
36528 *
36529       SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
36530
36531       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36532       SAVE
36533
36534       PARAMETER ( LINP = 10 ,
36535      &            LOUT = 6 ,
36536      &            LDAT = 9 )
36537 C...Generate a Delta-production neutrino/antineutrino
36538 C.  CC-interaction on a nucleon
36539 C
36540 C.  INPUT  ENU (GeV) = Neutrino Energy
36541 C.         LLEP = neutrino type
36542 C.         LTARG = nucleon target type 1=p, 2=n.
36543 C.         JINT = 1:CC, 2::NC
36544 C.
36545 C.  OUTPUT PPL(4)  4-monentum of final lepton
36546 C----------------------------------------------------
36547       PARAMETER (MAXLND=4000)
36548       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
36549 **sr - removed (not needed)
36550 C     COMMON /CBAD/  LBAD, NBAD
36551 **
36552
36553       DIMENSION PI(3),PO(3)
36554 C     REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
36555       DIMENSION AML0(6),AMN(2)
36556       DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
36557       DATA AMN  /0.93827231, 0.93956563/
36558       DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
36559
36560 c     WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
36561       LBAD = 0
36562 C...Final lepton mass
36563       IF (JINT.EQ.1) THEN
36564         AML = AML0(LLEP)
36565       ELSE
36566         AML = 0.
36567       ENDIF
36568       AML2 = AML**2
36569
36570 C...Particle labels (LUND)
36571       N = 5
36572       K(1,1) = 21
36573       K(2,1) = 21
36574       K(3,1) = 21
36575       K(4,1) = 1
36576       K(3,3) = 1
36577       K(4,3) = 1
36578       IF (LTARG .EQ. 1)  THEN
36579          K(2,2) = 2212
36580       ELSE
36581          K(2,2) = 2112
36582       ENDIF
36583       K0 = (LLEP-1)/2
36584       K1 = LLEP/2
36585       KA = 12 + 2*K0
36586       IS = -1 + 2*LLEP - 4*K1
36587       LNU = 2 - LLEP + 2*K1
36588       K(1,2) = IS*KA
36589       K(5,1) = 1
36590       K(5,3) = 2
36591       IF (JINT .EQ. 1)  THEN                    ! CC interactions
36592          K(3,2) = IS*24
36593          K(4,2) = IS*(KA-1)
36594         IF(LNU.EQ.1) THEN
36595           IF (LTARG .EQ. 1)  THEN
36596               K(5,2) = 2224
36597           ELSE
36598               K(5,2) = 2214
36599           ENDIF
36600         ELSE
36601           IF (LTARG .EQ. 1)  THEN
36602               K(5,2) = 2114
36603           ELSE
36604               K(5,2) = 1114
36605           ENDIF
36606         ENDIF
36607       ELSE
36608          K(3,2) = 23                           ! NC (Z0) interactions
36609          K(4,2) = K(1,2)
36610 **sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
36611 *                                Delta0 for neutron (LTARG=2)
36612 C        IF (LTARG .EQ. 1)  THEN
36613 C           K(5,2) = 2114
36614 C        ELSE
36615 C           K(5,2) = 2214
36616 C        ENDIF
36617          IF (LTARG .EQ. 1)  THEN
36618             K(5,2) = 2214
36619          ELSE
36620             K(5,2) = 2114
36621          ENDIF
36622 **
36623       ENDIF
36624
36625 C...4-momentum initial lepton
36626       P(1,5) = 0.
36627       P(1,4) = ENU
36628       P(1,1) = 0.
36629       P(1,2) = 0.
36630       P(1,3) = ENU
36631 C...4-momentum initial nucleon
36632       P(2,5) = AMN(LTARG)
36633 C     P(2,4) = P(2,5)
36634 C     P(2,1) = 0.
36635 C     P(2,2) = 0.
36636 C     P(2,3) = 0.
36637        P(2,1) = P21
36638        P(2,2) = P22
36639        P(2,3) = P23
36640        P(2,4) = P24
36641        P(2,5) = P25
36642       N=2
36643       beta1=-p(2,1)/p(2,4)
36644       beta2=-p(2,2)/p(2,4)
36645       beta3=-p(2,3)/p(2,4)
36646       N=2
36647
36648       CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
36649
36650 C     print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
36651
36652       phi11=atan(p(1,2)/p(1,3))
36653       pi(1)=p(1,1)
36654       pi(2)=p(1,2)
36655       pi(3)=p(1,3)
36656
36657       CALL DT_TESTROT(PI,Po,PHI11,1)
36658       DO ll=1,3
36659        IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36660       END DO
36661       p(1,1)=po(1)
36662       p(1,2)=po(2)
36663       p(1,3)=po(3)
36664       phi12=atan(p(1,1)/p(1,3))
36665
36666       pi(1)=p(1,1)
36667       pi(2)=p(1,2)
36668       pi(3)=p(1,3)
36669       CALL DT_TESTROT(Pi,Po,PHI12,2)
36670       DO ll=1,3
36671         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36672       END DO
36673       p(1,1)=po(1)
36674       p(1,2)=po(2)
36675       p(1,3)=po(3)
36676
36677       ENUU=P(1,4)
36678
36679 C...Generate the Mass of the Delta
36680       NTRY = 0
36681 100   R = PYR(0)
36682       AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
36683       NTRY = NTRY + 1
36684       IF (NTRY .GT. 1000)  THEN
36685          LBAD = 1
36686          WRITE (LOUT,1001)  NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
36687          RETURN
36688       ENDIF
36689       IF (AMD .LT. AMDMIN)  GOTO 100
36690       ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
36691       IF (ENUU .LT. ET) GOTO 100
36692
36693 C...Kinematical  limits in Q**2
36694       S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
36695       SQS = SQRT(S)
36696       PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
36697       ELF = (S - AMD**2 + AML2)/(2.*SQS)
36698       PLF = SQRT(ELF**2 - AML2)
36699       Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
36700       Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
36701       IF (Q2MIN .LT. 0.)   Q2MIN = 0.
36702
36703       DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
36704 200   Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
36705       DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
36706       IF (DSIG .LT.  DSIGMAX*PYR(0)) GOTO 200
36707
36708 C...Generate the kinematics of the final particles
36709       EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
36710       GAM = EISTAR/AMN(LTARG)
36711       BET = PSTAR/EISTAR
36712       CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
36713       EL  = GAM*(ELF + BET*PLF*CTSTAR)
36714       PLZ = GAM*(PLF*CTSTAR + BET*ELF)
36715       PL  = SQRT(EL**2 - AML2)
36716       PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
36717       PHI = 6.28319*PYR(0)
36718       P(4,1) = PLT*COS(PHI)
36719       P(4,2) = PLT*SIN(PHI)
36720       P(4,3) = PLZ
36721       P(4,4) = EL
36722       P(4,5) = AML
36723
36724 C...4-momentum of Delta
36725       P(5,1) = -P(4,1)
36726       P(5,2) = -P(4,2)
36727       P(5,3) = ENUU-P(4,3)
36728       P(5,4) = ENUU+AMN(LTARG)-P(4,4)
36729       P(5,5) = AMD
36730
36731 C...4-momentum  of intermediate boson
36732       P(3,5) = -Q2
36733       P(3,4) = P(1,4)-P(4,4)
36734       P(3,1) = P(1,1)-P(4,1)
36735       P(3,2) = P(1,2)-P(4,2)
36736       P(3,3) = P(1,3)-P(4,3)
36737       N=5
36738
36739       DO kw=1,5
36740         pi(1)=p(kw,1)
36741         pi(2)=p(kw,2)
36742         pi(3)=p(kw,3)
36743         CALL DT_TESTROT(Pi,Po,PHI12,3)
36744         DO ll=1,3
36745           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36746         END DO
36747         p(kw,1)=po(1)
36748         p(kw,2)=po(2)
36749         p(kw,3)=po(3)
36750       END DO
36751
36752 c********************************************
36753
36754         DO kw=1,5
36755           pi(1)=p(kw,1)
36756           pi(2)=p(kw,2)
36757           pi(3)=p(kw,3)
36758           CALL DT_TESTROT(Pi,Po,PHI11,4)
36759           DO ll=1,3
36760             IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36761           END DO
36762           p(kw,1)=po(1)
36763           p(kw,2)=po(2)
36764           p(kw,3)=po(3)
36765        END DO
36766 c********************************************
36767 C         transform back into Lab.
36768
36769       CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
36770
36771 C     WRITE(6,*)' Lab fram ( fermi incl.) '
36772       N=5
36773       CALL PYEXEC
36774
36775       RETURN
36776 1001  FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5,  6G10.3)
36777       END
36778
36779 *$ CREATE DT_DSIGMA_DELTA.FOR
36780 *COPY DT_DSIGMA_DELTA
36781 *
36782 *===dsigma_delta=======================================================*
36783 *
36784       DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
36785
36786       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36787       SAVE
36788
36789 C...Reaction nu + N -> lepton + Delta
36790 C.  returns the  cross section
36791 C.  dsigma/dt
36792 C.  INPUT  LNU = 1, 2  (neutrino-antineutrino)
36793 C.         QQ = t (always negative)  GeV**2
36794 C.         S  = (c.m energy)**2      GeV**2
36795 C.  OUTPUT =  10**-38 cm+2/GeV**2
36796 C-----------------------------------------------------
36797       REAL*8 MN, MN2, MN4, MD,MD2, MD4
36798       DATA MN /0.938/
36799       DATA PI /3.1415926/
36800
36801       GF = (1.1664 * 1.97)
36802       GF2 = GF*GF
36803       MN2 = MN*MN
36804       MN4 = MN2*MN2
36805       MD2 = MD*MD
36806       MD4 = MD2*MD2
36807       AML2 = AML*AML
36808       AML4 = AML2*AML2
36809       VQ  = (MN2 - MD2 - QQ)/2.
36810       VPI = (MN2 + MD2 - QQ)/2.
36811       VK  = (S + QQ - MN2 - AML2)/2.
36812       PIK = (S - MN2)/2.
36813       QK = (AML2 - QQ)/2.
36814       PIQ = (QQ + MN2 - MD2)/2.
36815       Q = SQRT(-QQ)
36816       C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
36817       C3 = SQRT(3.)*C3V/MN
36818       C4 = -C3/MD             ! attenzione al segno
36819       C5A = 1.18/(1.-QQ/0.4225)**2
36820       C32 = C3**2
36821       C42 = C4**2
36822       C5A2 = C5A**2
36823
36824       IF (LNU .EQ. 1)  THEN
36825       ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
36826      . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
36827      . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
36828      . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
36829       ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
36830      . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
36831      . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
36832      . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
36833      . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
36834      . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ-
36835      . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
36836      . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
36837      . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
36838      . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
36839      . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD*
36840      . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A
36841      . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ*
36842      . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A*
36843      . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2
36844      . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK
36845      . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
36846      . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
36847      . *C42-2.*MD2*VPI*QK**2*C32+ANS3
36848       ELSE
36849       ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
36850      . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
36851      . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
36852      . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
36853       ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
36854      . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
36855      . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
36856      . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
36857      . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
36858      . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
36859      . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
36860      . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
36861      . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
36862      . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
36863      . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
36864      . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
36865      . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
36866      . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
36867      . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
36868      . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
36869      . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
36870      . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
36871      . *C42-2.*MD2*VPI*QK**2*C32+ANS3
36872       ENDIF
36873       ANS1=32.*ANS2
36874       ANS=ANS1/(3.*MD2)
36875       P1CM = (S-MN2)/(2.*SQRT(S))
36876       DT_DSIGMA_DELTA  = GF2/2. * ANS/(64.*PI*S*P1CM**2)
36877
36878       RETURN
36879       END
36880
36881 *$ CREATE DT_QGAUS.FOR
36882 *COPY DT_QGAUS
36883 *
36884 *===qgaus==============================================================*
36885 *
36886       SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
36887
36888       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36889       SAVE
36890
36891       DIMENSION X(5),W(5)
36892       DATA X/.1488743389D0,.4333953941D0,
36893      & .6794095682D0,.8650633666D0,.9739065285D0
36894      */
36895       DATA W/.2955242247D0,.2692667193D0,
36896      & .2190863625D0,.1494513491D0,.0666713443D0
36897      */
36898       XM=0.5D0*(B+A)
36899       XR=0.5D0*(B-A)
36900       SS=0
36901       DO 11 J=1,5
36902         DX=XR*X(J)
36903         SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
36904      *  DT_DSQEL_Q2(LTYP,ENU,XM-DX))
36905 11    CONTINUE
36906       SS=XR*SS
36907
36908       RETURN
36909       END
36910
36911 *$ CREATE DT_DIQBRK.FOR
36912 *COPY DT_DIQBRK
36913 *
36914 *===diqbrk=============================================================*
36915 *
36916       SUBROUTINE DT_DIQBRK
36917
36918       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36919       SAVE
36920
36921 * event history
36922       PARAMETER (NMXHKK=200000)
36923       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36924      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36925      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36926 * extended event history
36927       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36928      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36929      &                IHIST(2,NMXHKK)
36930 * event flag
36931       COMMON /DTEVNO/ NEVENT,ICASCA
36932
36933 C     IF(DT_RNDM(VV).LE.0.5D0)THEN
36934 C       CALL GSQBS1(NHKK)
36935 C       CALL GSQBS2(NHKK)
36936 C       CALL USQBS1(NHKK)
36937 C       CALL USQBS2(NHKK)
36938 C       CALL GSABS1(NHKK)
36939 C       CALL GSABS2(NHKK)
36940 C       CALL USABS1(NHKK)
36941 C       CALL USABS2(NHKK)
36942 C     ELSE
36943 C       CALL GSQBS2(NHKK)
36944 C       CALL GSQBS1(NHKK)
36945 C       CALL USQBS2(NHKK)
36946 C       CALL USQBS1(NHKK)
36947 C       CALL GSABS2(NHKK)
36948 C       CALL GSABS1(NHKK)
36949 C       CALL USABS2(NHKK)
36950 C       CALL USABS1(NHKK)
36951 C     ENDIF
36952
36953       IF(DT_RNDM(VV).LE.0.5D0) THEN
36954         CALL DT_DBREAK(1)
36955         CALL DT_DBREAK(2)
36956         CALL DT_DBREAK(3)
36957         CALL DT_DBREAK(4)
36958         CALL DT_DBREAK(5)
36959         CALL DT_DBREAK(6)
36960         CALL DT_DBREAK(7)
36961         CALL DT_DBREAK(8)
36962       ELSE
36963         CALL DT_DBREAK(2)
36964         CALL DT_DBREAK(1)
36965         CALL DT_DBREAK(4)
36966         CALL DT_DBREAK(3)
36967         CALL DT_DBREAK(6)
36968         CALL DT_DBREAK(5)
36969         CALL DT_DBREAK(8)
36970         CALL DT_DBREAK(7)
36971       ENDIF
36972
36973       RETURN
36974       END
36975
36976 *$ CREATE MUSQBS2.FOR
36977 *COPY MUSQBS2
36978 C
36979 C
36980 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36981       SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36982      *              IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
36983 C
36984 C                  USQBS-2 diagram (split target diquark)
36985 C
36986       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36987       SAVE
36988
36989       PARAMETER ( LINP = 10 ,
36990      &            LOUT = 6 ,
36991      &            LDAT = 9 )
36992 * event history
36993       PARAMETER (NMXHKK=200000)
36994       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36995      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36996      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36997 * extended event history
36998       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36999      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37000      &                IHIST(2,NMXHKK)
37001 * Lorentz-parameters of the current interaction
37002       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37003      &                UMO,PPCM,EPROJ,PPROJ
37004 * diquark-breaking mechanism
37005       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37006
37007 C
37008       PARAMETER (NTMHKK= 300)
37009       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37010      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37011      +(4,NTMHKK)
37012 *KEEP,XSEADI.
37013       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37014      +SSMIMQ,VVMTHR
37015 *KEEP,DPRIN.
37016       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37017       COMMON /EVFLAG/ NUMEV
37018 C
37019 C                  USQBS-2 diagram (split target diquark)
37020 C
37021 C
37022 C     Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
37023 C     Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
37024 C
37025 C     Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
37026 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37027 C
37028 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37029 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37030 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37031 C
37032 C
37033 C       Put new chains into COMMON /HKKTMP/
37034 C
37035       IIGLU1=NC1T-NC1P-1
37036       IIGLU2=NC2T-NC2P-1
37037       IGCOUN=0
37038 C     WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37039       CVQ=1.D0
37040       IREJ=0
37041       IF(IPIP.EQ.2)THEN
37042 C     IF(NUMEV.EQ.-324)THEN
37043 C     WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37044 C    *             'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
37045 C    *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37046 C    *              IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
37047       ENDIF
37048 C
37049 C
37050 C
37051 C     determine x-values of NC1T diquark
37052       XDIQT=PHKK(4,NC1T)*2.D0/UMO
37053       XVQP=PHKK(4,NC1P)*2.D0/UMO
37054 C
37055 C     determine x-values of sea quark pair
37056 C
37057       IPCO=1
37058       ICOU=0
37059  2234 CONTINUE
37060       ICOU=ICOU+1
37061       IF(ICOU.GE.500)THEN
37062         IREJ=1
37063         IF(ISQ.EQ.3)IREJ=3
37064         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
37065         IPCO=0
37066         RETURN
37067       ENDIF
37068       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call  XSEAPA: UMO,XDIQT,XVQP ',
37069      * UMO, XDIQT,XVQP
37070       XSQ=0.D0
37071       XSAQ=0.D0
37072 **NEW
37073 C     CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37074       IF (IPIP.EQ.1) THEN
37075          XQMAX  = XDIQT/2.0D0
37076          XAQMAX = 2.D0*XVQP/3.0D0
37077       ELSE
37078          XQMAX  = 2.D0*XVQP/3.0D0
37079          XAQMAX = XDIQT/2.0D0
37080       ENDIF
37081       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37082       ISAQ = 6+ISQ
37083 C     write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
37084 **
37085         IF(IPCO.GE.3)
37086      &     WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37087       IF(IREJ.GE.1)THEN
37088         IF(IPCO.GE.3)
37089      &     WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37090         IPCO=0
37091         RETURN
37092       ENDIF
37093       IF(IPIP.EQ.1)THEN
37094         IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37095       ELSEIF(IPIP.EQ.2)THEN
37096         IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37097       ENDIF
37098       IF(IPCO.GE.3)THEN
37099         WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
37100      *  XDIQT,XVQP,XSQ,XSAQ
37101       ENDIF
37102 C
37103 C     subtract xsq,xsaq from NC1T diquark and NC1P quark
37104 C
37105 C     XSQ=0.D0
37106       IF(IPIP.EQ.1)THEN
37107         XDIQT=XDIQT-XSQ
37108         XVQP =XVQP -XSAQ
37109       ELSEIF(IPIP.EQ.2)THEN
37110         XDIQT=XDIQT-XSAQ
37111         XVQP =XVQP -XSQ
37112       ENDIF
37113       IF(IPCO.GE.3)
37114      &   WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
37115 C
37116 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37117 C
37118       XVTHRO=CVQ/UMO
37119       IVTHR=0
37120  3466 CONTINUE
37121       IF(IVTHR.EQ.10)THEN
37122         IREJ=1
37123         IF(ISQ.EQ.3)IREJ=3
37124         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
37125       IPCO=0
37126         RETURN
37127       ENDIF
37128       IVTHR=IVTHR+1
37129       XVTHR=XVTHRO/(201-IVTHR)
37130       UNOPRV=UNON
37131  380  CONTINUE
37132       IF(XVTHR.GT.0.66D0*XDIQT)THEN
37133         IREJ=1
37134         IF(ISQ.EQ.3)IREJ=3
37135         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR  large ',
37136      *  XVTHR
37137       IPCO=0
37138         RETURN
37139       ENDIF
37140       IF(DT_RNDM(V).LT.0.5D0)THEN
37141         XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37142         XVTQII=XDIQT-XVTQI
37143       ELSE
37144         XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37145         XVTQI=XDIQT-XVTQII
37146       ENDIF
37147       IF(IPCO.GE.3)THEN
37148         WRITE(LOUT,'(A,2E12.4)')'  MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
37149       ENDIF
37150 C
37151 C     Prepare 4 momenta of new chains and chain ends
37152 C
37153 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37154 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37155 C    +(4,NTMHKK)
37156 C
37157 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37158 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37159 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37160 C
37161 C     SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37162 C    *              IP1,IP21,IP22,IPP1,IPP2)
37163 C
37164       IF(IPIP.EQ.1)THEN
37165         XSQ1=XSQ
37166         XSAQ1=XSAQ
37167         ISQ1=ISQ
37168         ISAQ1=ISAQ
37169       ELSEIF(IPIP.EQ.2)THEN
37170         XSQ1=XSAQ
37171         XSAQ1=XSQ
37172         ISQ1=ISAQ
37173         ISAQ1=ISQ
37174       ENDIF
37175       IDHKT(1)   =IPP1
37176       ISTHKT(1)  =951
37177       JMOHKT(1,1)=NC2P
37178       JMOHKT(2,1)=0
37179       JDAHKT(1,1)=3+IIGLU1
37180       JDAHKT(2,1)=0
37181 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37182       PHKT(1,1)  =PHKK(1,NC2P)
37183       PHKT(2,1)  =PHKK(2,NC2P)
37184       PHKT(3,1)  =PHKK(3,NC2P)
37185       PHKT(4,1)  =PHKK(4,NC2P)
37186 C     PHKT(5,1)  =PHKK(5,NC2P)
37187       XMIST  =(PHKT(4,1)**2-
37188      * PHKT(3,1)**2-PHKT(2,1)**2-
37189      *PHKT(1,1)**2)
37190       IF(XMIST.GT.0.D0)THEN
37191       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37192      *PHKT(1,1)**2)
37193       ELSE
37194 C     WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
37195       PHKT(5,1)=0.D0
37196       ENDIF
37197       VHKT(1,1)  =VHKK(1,NC2P)
37198       VHKT(2,1)  =VHKK(2,NC2P)
37199       VHKT(3,1)  =VHKK(3,NC2P)
37200       VHKT(4,1)  =VHKK(4,NC2P)
37201       WHKT(1,1)  =WHKK(1,NC2P)
37202       WHKT(2,1)  =WHKK(2,NC2P)
37203       WHKT(3,1)  =WHKK(3,NC2P)
37204       WHKT(4,1)  =WHKK(4,NC2P)
37205 C     Add here IIGLU1 gluons to this chaina
37206       PG1=0.D0
37207       PG2=0.D0
37208       PG3=0.D0
37209       PG4=0.D0
37210       IF(IIGLU1.GE.1)THEN
37211       JJG=NC1P
37212       DO 61 IIG=2,2+IIGLU1-1
37213         KKG=JJG+IIG-1
37214         IDHKT(IIG)   =IDHKK(KKG)
37215         ISTHKT(IIG)  =921
37216         JMOHKT(1,IIG)=KKG
37217         JMOHKT(2,IIG)=0
37218         JDAHKT(1,IIG)=3+IIGLU1
37219         JDAHKT(2,IIG)=0
37220         PHKT(1,IIG)=PHKK(1,KKG)
37221         PG1=PG1+ PHKT(1,IIG)
37222         PHKT(2,IIG)=PHKK(2,KKG)
37223         PG2=PG2+ PHKT(2,IIG)
37224         PHKT(3,IIG)=PHKK(3,KKG)
37225         PG3=PG3+ PHKT(3,IIG)
37226         PHKT(4,IIG)=PHKK(4,KKG)
37227         PG4=PG4+ PHKT(4,IIG)
37228         PHKT(5,IIG)=PHKK(5,KKG)
37229         VHKT(1,IIG)  =VHKK(1,KKG)
37230         VHKT(2,IIG)  =VHKK(2,KKG)
37231         VHKT(3,IIG)  =VHKK(3,KKG)
37232         VHKT(4,IIG)  =VHKK(4,KKG)
37233         WHKT(1,IIG) =WHKK(1,KKG)
37234         WHKT(2,IIG) =WHKK(2,KKG)
37235         WHKT(3,IIG) =WHKK(3,KKG)
37236         WHKT(4,IIG) =WHKK(4,KKG)
37237    61 CONTINUE
37238       ENDIF
37239       IDHKT(2+IIGLU1)   =IP21
37240       ISTHKT(2+IIGLU1)  =952
37241       JMOHKT(1,2+IIGLU1)=NC1T
37242       JMOHKT(2,2+IIGLU1)=0
37243       JDAHKT(1,2+IIGLU1)=3+IIGLU1
37244       JDAHKT(2,2+IIGLU1)=0
37245       PHKT(1,2+IIGLU1)  =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
37246       PHKT(2,2+IIGLU1)  =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
37247       PHKT(3,2+IIGLU1)  =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
37248       PHKT(4,2+IIGLU1)  =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
37249 C     PHKT(5,2)  =PHKK(5,NC1T)
37250       XMIST  =(PHKT(4,2+IIGLU1)**2-
37251      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37252      *PHKT(1,2+IIGLU1)**2)
37253       IF(XMIST.GT.0.D0)THEN
37254       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
37255      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37256      *PHKT(1,2+IIGLU1)**2)
37257       ELSE
37258 C      WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
37259         PHKT(5,5+IIGLU1)=0.D0
37260       ENDIF
37261       VHKT(1,2+IIGLU1)  =VHKK(1,NC1T)
37262       VHKT(2,2+IIGLU1)  =VHKK(2,NC1T)
37263       VHKT(3,2+IIGLU1)  =VHKK(3,NC1T)
37264       VHKT(4,2+IIGLU1)  =VHKK(4,NC1T)
37265       WHKT(1,2+IIGLU1)  =WHKK(1,NC1T)
37266       WHKT(2,2+IIGLU1)  =WHKK(2,NC1T)
37267       WHKT(3,2+IIGLU1)  =WHKK(3,NC1T)
37268       WHKT(4,2+IIGLU1)  =WHKK(4,NC1T)
37269       IDHKT(3+IIGLU1)   =88888
37270       ISTHKT(3+IIGLU1)  =95
37271       JMOHKT(1,3+IIGLU1)=1
37272       JMOHKT(2,3+IIGLU1)=2+IIGLU1
37273       JDAHKT(1,3+IIGLU1)=0
37274       JDAHKT(2,3+IIGLU1)=0
37275       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
37276       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
37277       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
37278       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
37279       XMIST
37280      * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37281      *            -PHKT(3,3+IIGLU1)**2)
37282       IF(XMIST.GT.0.D0)THEN
37283       PHKT(5,3+IIGLU1)
37284      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37285      *            -PHKT(3,3+IIGLU1)**2)
37286       ELSE
37287 C      WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
37288         PHKT(5,5+IIGLU1)=0.D0
37289       ENDIF
37290       IF(IPIP.GE.2)THEN
37291 C     IF(NUMEV.EQ.-324)THEN
37292 C     WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
37293 C    * JDAHKT(1,1),
37294 C    *JDAHKT(2,1),(PHKT(III,1),III=1,5)
37295       DO 71 IIG=2,2+IIGLU1-1
37296 C     WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37297 C    &             JMOHKT(1,IIG),JMOHKT(2,IIG),
37298 C    * JDAHKT(1,IIG),
37299 C    *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37300    71 CONTINUE
37301 C     WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
37302 C    * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
37303 C    *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
37304 C     WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
37305 C    * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
37306 C    *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
37307       ENDIF
37308       CHAMAL=CHAM1
37309       IF(IPIP.EQ.1)THEN
37310         IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
37311       ELSEIF(IPIP.EQ.2)THEN
37312         IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
37313       ENDIF
37314       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
37315 C       IREJ=1
37316         IPCO=0
37317 C       RETURN
37318 C       WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
37319         GO TO 3466
37320       ENDIF
37321       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
37322       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
37323       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
37324       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
37325       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
37326       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
37327       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
37328       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
37329       IF(IPIP.EQ.1)THEN
37330         IDHKT(4+IIGLU1)   =-(ISAQ1-6)
37331       ELSEIF(IPIP.EQ.2)THEN
37332         IDHKT(4+IIGLU1)   =ISAQ1
37333       ENDIF
37334       ISTHKT(4+IIGLU1)  =951
37335       JMOHKT(1,4+IIGLU1)=NC1P
37336       JMOHKT(2,4+IIGLU1)=0
37337       JDAHKT(1,4+IIGLU1)=6+IIGLU1
37338       JDAHKT(2,4+IIGLU1)=0
37339 C     create chain    6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37340       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
37341       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
37342       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
37343       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
37344 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
37345       XMIST  =(PHKT(4,4+IIGLU1)**2-
37346      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37347      *PHKT(1,4+IIGLU1)**2)
37348       IF(XMIST.GT.0.D0)THEN
37349       PHKT(5,4+IIGLU1)  =SQRT(PHKT(4,4+IIGLU1)**2-
37350      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37351      *PHKT(1,4+IIGLU1)**2)
37352       ELSE
37353 C     WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
37354       PHKT(5,4+IIGLU1)=0.D0
37355       ENDIF
37356       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
37357       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
37358       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
37359       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
37360       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
37361       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
37362       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
37363       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
37364       IDHKT(5+IIGLU1)   =IP22
37365       ISTHKT(5+IIGLU1)  =952
37366       JMOHKT(1,5+IIGLU1)=NC1T
37367       JMOHKT(2,5+IIGLU1)=0
37368       JDAHKT(1,5+IIGLU1)=6+IIGLU1
37369       JDAHKT(2,5+IIGLU1)=0
37370       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
37371       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
37372       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
37373       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
37374 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
37375       XMIST  =(PHKT(4,5+IIGLU1)**2-
37376      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37377      *PHKT(1,5+IIGLU1)**2)
37378       IF(XMIST.GT.0.D0)THEN
37379       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
37380      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37381      *PHKT(1,5+IIGLU1)**2)
37382       ELSE
37383 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37384         PHKT(5,5+IIGLU1)=0.D0
37385       ENDIF
37386       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
37387       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
37388       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
37389       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
37390       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
37391       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
37392       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
37393       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
37394       IDHKT(6+IIGLU1)   =88888
37395       ISTHKT(6+IIGLU1)  =95
37396       JMOHKT(1,6+IIGLU1)=4+IIGLU1
37397       JMOHKT(2,6+IIGLU1)=5+IIGLU1
37398       JDAHKT(1,6+IIGLU1)=0
37399       JDAHKT(2,6+IIGLU1)=0
37400       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37401       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37402       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37403       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37404       XMIST
37405      * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37406      *            -PHKT(3,6+IIGLU1)**2)
37407       IF(XMIST.GT.0.D0)THEN
37408       PHKT(5,6+IIGLU1)
37409      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37410      *            -PHKT(3,6+IIGLU1)**2)
37411       ELSE
37412 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37413         PHKT(5,5+IIGLU1)=0.D0
37414       ENDIF
37415 C     IF(IPIP.GE.2)THEN
37416 C     IF(NUMEV.EQ.-324)THEN
37417 C     WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37418 C    * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37419 C    *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37420 C     WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37421 C    * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37422 C    *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37423 C     WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37424 C    * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37425 C    *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37426 C     ENDIF
37427       CHAMAL=CHAM1
37428       IF(IPIP.EQ.1)THEN
37429         IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37430       ELSEIF(IPIP.EQ.2)THEN
37431         IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37432       ENDIF
37433       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37434 C       IREJ=1
37435         IPCO=0
37436 C       RETURN
37437 C       WRITE(6,*)' MUSQBS1 jump back from chain 6',
37438 C    *  CHAMAL,PHKT(5,6+IIGLU1)
37439         GO TO 3466
37440       ENDIF
37441       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
37442       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
37443       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
37444       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
37445       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
37446       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
37447       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
37448       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
37449 C     IDHKT(7)   =1000*IPP1+100*ISQ+1
37450       IDHKT(7+IIGLU1)   =IP1
37451       ISTHKT(7+IIGLU1)  =951
37452       JMOHKT(1,7+IIGLU1)=NC1P
37453       JMOHKT(2,7+IIGLU1)=0
37454 **NEW
37455 C     JDAHKT(1,7+IIGLU1)=9+IIGLU1
37456       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
37457 **
37458       JDAHKT(2,7+IIGLU1)=0
37459       PHKT(1,7+IIGLU1)  =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
37460       PHKT(2,7+IIGLU1)  =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
37461       PHKT(3,7+IIGLU1)  =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
37462       PHKT(4,7+IIGLU1)  =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
37463 C     PHKT(5,7+IIGLU1)  =PHKK(5,NC1P)
37464       XMIST  =(PHKT(4,7+IIGLU1)**2-
37465      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37466      *PHKT(1,7+IIGLU1)**2)
37467       IF(XMIST.GT.0.D0)THEN
37468       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
37469      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37470      *PHKT(1,7+IIGLU1)**2)
37471       ELSE
37472 C     WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
37473       PHKT(5,7+IIGLU1)=0.D0
37474       ENDIF
37475       VHKT(1,7+IIGLU1)  =VHKK(1,NC1P)
37476       VHKT(2,7+IIGLU1)  =VHKK(2,NC1P)
37477       VHKT(3,7+IIGLU1)  =VHKK(3,NC1P)
37478       VHKT(4,7+IIGLU1)  =VHKK(4,NC1P)
37479       WHKT(1,7+IIGLU1)  =WHKK(1,NC1P)
37480       WHKT(2,7+IIGLU1)  =WHKK(2,NC1P)
37481       WHKT(3,7+IIGLU1)  =WHKK(3,NC1P)
37482       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
37483 C     Insert here the IIGLU2 gluons
37484       PG1=0.D0
37485       PG2=0.D0
37486       PG3=0.D0
37487       PG4=0.D0
37488       IF(IIGLU2.GE.1)THEN
37489       JJG=NC2P
37490       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37491         KKG=JJG+IIG-7-IIGLU1
37492         IDHKT(IIG)   =IDHKK(KKG)
37493         ISTHKT(IIG)  =921
37494         JMOHKT(1,IIG)=KKG
37495         JMOHKT(2,IIG)=0
37496         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
37497         JDAHKT(2,IIG)=0
37498         PHKT(1,IIG)=PHKK(1,KKG)
37499         PG1=PG1+ PHKT(1,IIG)
37500         PHKT(2,IIG)=PHKK(2,KKG)
37501         PG2=PG2+ PHKT(2,IIG)
37502         PHKT(3,IIG)=PHKK(3,KKG)
37503         PG3=PG3+ PHKT(3,IIG)
37504         PHKT(4,IIG)=PHKK(4,KKG)
37505         PG4=PG4+ PHKT(4,IIG)
37506         PHKT(5,IIG)=PHKK(5,KKG)
37507         VHKT(1,IIG)  =VHKK(1,KKG)
37508         VHKT(2,IIG)  =VHKK(2,KKG)
37509         VHKT(3,IIG)  =VHKK(3,KKG)
37510         VHKT(4,IIG)  =VHKK(4,KKG)
37511         WHKT(1,IIG)  =WHKK(1,KKG)
37512         WHKT(2,IIG) =WHKK(2,KKG)
37513         WHKT(3,IIG) =WHKK(3,KKG)
37514         WHKT(4,IIG) =WHKK(4,KKG)
37515    81 CONTINUE
37516       ENDIF
37517       IF(IPIP.EQ.1)THEN
37518         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*ISQ1+3
37519         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
37520         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
37521         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
37522       ELSEIF(IPIP.EQ.2)THEN
37523         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*(-ISQ1+6)-3
37524         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
37525         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
37526         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
37527       ENDIF
37528       ISTHKT(8+IIGLU1+IIGLU2)  =952
37529       JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
37530       JMOHKT(2,8+IIGLU1+IIGLU2)=0
37531       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
37532       JDAHKT(2,8+IIGLU1+IIGLU2)=0
37533       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC2T)+
37534      * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
37535       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC2T)+
37536      * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
37537       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC2T)+
37538      * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
37539       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC2T)+
37540      * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
37541 C     WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
37542 C    * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
37543       IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
37544 C       IREJ=1
37545 C       WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
37546 C    *  ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
37547         IPCO=0
37548 C       RETURN
37549         GO TO 3466
37550       ENDIF
37551 C     PHKT(5,8)  =PHKK(5,NC2T)
37552       XMIST  =(PHKT(4,8+IIGLU1+IIGLU2)**2-
37553      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37554      *PHKT(1,8+IIGLU1+IIGLU2)**2)
37555       IF(XMIST.GT.0.D0)THEN
37556       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
37557      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37558      *PHKT(1,8+IIGLU1+IIGLU2)**2)
37559       ELSE
37560 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37561         PHKT(5,5+IIGLU1)=0.D0
37562       ENDIF
37563       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC2T)
37564       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC2T)
37565       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC2T)
37566       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC2T)
37567       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC2T)
37568       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC2T)
37569       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC2T)
37570       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC2T)
37571       IDHKT(9+IIGLU1+IIGLU2)   =88888
37572       ISTHKT(9+IIGLU1+IIGLU2)  =95
37573       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
37574       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
37575       JDAHKT(1,9+IIGLU1+IIGLU2)=0
37576       JDAHKT(2,9+IIGLU1+IIGLU2)=0
37577 **NEW
37578 C     PHKT(1,9+IIGLU1+IIGLU2)
37579 C    * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37580 C     PHKT(2,9+IIGLU1+IIGLU2)
37581 C    * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37582 C     PHKT(3,9+IIGLU1+IIGLU2)
37583 C    * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37584 C     PHKT(4,9+IIGLU1+IIGLU2)
37585 C    * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37586       PHKT(1,9+IIGLU1+IIGLU2)
37587      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37588       PHKT(2,9+IIGLU1+IIGLU2)
37589      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37590       PHKT(3,9+IIGLU1+IIGLU2)
37591      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37592       PHKT(4,9+IIGLU1+IIGLU2)
37593      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37594 **
37595       XMIST
37596      * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37597      * -PHKT(2,9+IIGLU1+IIGLU2)**2
37598      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
37599       IF(XMIST.GT.0.D0)THEN
37600       PHKT(5,9+IIGLU1+IIGLU2)
37601      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37602      * -PHKT(2,9+IIGLU1+IIGLU2)**2
37603      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
37604       ELSE
37605 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37606         PHKT(5,5+IIGLU1)=0.D0
37607       ENDIF
37608       IF(IPIP.GE.2)THEN
37609 C     IF(NUMEV.EQ.-324)THEN
37610 C     WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
37611 C    * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
37612 C    *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
37613 C     DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37614 C     WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
37615 C    * JDAHKT(1,IIG),
37616 C    *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37617 C  91 CONTINUE
37618 C     WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
37619 C    * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
37620 C    *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
37621 C    *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
37622 C     WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
37623 C    * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
37624 C    *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
37625 C    *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
37626       ENDIF
37627       CHAMAL=CHAB1
37628       IF(IPIP.EQ.1)THEN
37629         IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37630       ELSEIF(IPIP.EQ.2)THEN
37631         IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37632       ENDIF
37633       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37634 C       IREJ=1
37635         IPCO=0
37636 C       RETURN
37637 C       WRITE(6,*)' MUSQBS1 jump back from chain 9',
37638 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
37639         GO TO 3466
37640       ENDIF
37641       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
37642       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
37643       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
37644       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
37645       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
37646       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
37647       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
37648       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
37649 C
37650       IPCO=0
37651       IGCOUN=9+IIGLU1+IIGLU2
37652        RETURN
37653        END
37654
37655 *$ CREATE MGSQBS2.FOR
37656 *COPY MGSQBS2
37657 C
37658 C
37659 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37660       SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37661      *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
37662 C
37663 C                  GSQBS-2 diagram (split target diquark)
37664 C
37665       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37666       SAVE
37667
37668       PARAMETER ( LINP = 10 ,
37669      &            LOUT = 6 ,
37670      &            LDAT = 9 )
37671 * event history
37672       PARAMETER (NMXHKK=200000)
37673       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37674      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37675      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37676 * extended event history
37677       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37678      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37679      &                IHIST(2,NMXHKK)
37680 * Lorentz-parameters of the current interaction
37681       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37682      &                UMO,PPCM,EPROJ,PPROJ
37683 * diquark-breaking mechanism
37684       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37685
37686 C
37687       PARAMETER (NTMHKK= 300)
37688       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37689      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37690      +(4,NTMHKK)
37691
37692 *KEEP,XSEADI.
37693       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37694      +SSMIMQ,VVMTHR
37695 *KEEP,DPRIN.
37696       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37697 C
37698 C                  GSQBS-2 diagram (split target diquark)
37699 C
37700 C
37701 C     Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
37702 C     Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
37703 C
37704 C     Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
37705 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37706 C
37707 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37708 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37709 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37710 C
37711 C
37712 C
37713 C       Put new chains into COMMON /HKKTMP/
37714 C
37715       IIGLU1=NC1T-NC1P-1
37716       IIGLU2=NC2T-NC2P-1
37717       IGCOUN=0
37718 C     WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37719       CVQ=1.D0
37720       IREJ=0
37721 C     IF(IPIP.EQ.2)THEN
37722 C     WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37723 C    *             'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
37724 C    *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37725 C    *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
37726 C     ENDIF
37727 C
37728 C
37729 C
37730 C     determine x-values of NC1T diquark
37731       XDIQT=PHKK(4,NC1T)*2.D0/UMO
37732       XVQP=PHKK(4,NC1P)*2.D0/UMO
37733 C
37734 C     determine x-values of sea quark pair
37735 C
37736       IPCO=1
37737       ICOU=0
37738  2234 CONTINUE
37739       ICOU=ICOU+1
37740       IF(ICOU.GE.500)THEN
37741         IREJ=1
37742         IF(ISQ.EQ.3)IREJ=3
37743         IF(IPCO.GE.3)
37744      &     WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
37745         IPCO=0
37746         RETURN
37747       ENDIF
37748       IF(IPCO.GE.3)
37749      &     WRITE(LOUT,*)'MGSQBS2 call  XSEAPA: UMO,XDIQT,XVQP ',
37750      * UMO, XDIQT,XVQP
37751       XSQ=0.D0
37752       XSAQ=0.D0
37753 **NEW
37754 C     CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37755       IF (IPIP.EQ.1) THEN
37756          XQMAX  = XDIQT/2.0D0
37757          XAQMAX = 2.D0*XVQP/3.0D0
37758       ELSE
37759          XQMAX  = 2.D0*XVQP/3.0D0
37760          XAQMAX = XDIQT/2.0D0
37761       ENDIF
37762       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37763       ISAQ = 6+ISQ
37764 C     write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
37765 **
37766         IF(IPCO.GE.3)
37767      &     WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37768       IF(IREJ.GE.1)THEN
37769         IF(IPCO.GE.3)
37770      &     WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37771         IPCO=0
37772         RETURN
37773       ENDIF
37774       IF(IPIP.EQ.1)THEN
37775         IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37776       ELSEIF(IPIP.EQ.2)THEN
37777         IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37778       ENDIF
37779       IF(IPCO.GE.3)THEN
37780         WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
37781      *  XDIQT,XVQP,XSQ,XSAQ
37782       ENDIF
37783 C
37784 C     subtract xsq,xsaq from NC1T diquark and NC1P quark
37785 C
37786 C     XSQ=0.D0
37787       IF(IPIP.EQ.1)THEN
37788         XDIQT=XDIQT-XSQ
37789         XVQP =XVQP -XSAQ
37790       ELSEIF(IPIP.EQ.2)THEN
37791         XDIQT=XDIQT-XSAQ
37792         XVQP =XVQP -XSQ
37793       ENDIF
37794       IF(IPCO.GE.3)
37795      &   WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
37796 C
37797 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37798 C
37799       XVTHRO=CVQ/UMO
37800       IVTHR=0
37801  3466 CONTINUE
37802       IF(IVTHR.EQ.10)THEN
37803         IREJ=1
37804         IF(ISQ.EQ.3)IREJ=3
37805         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
37806         IPCO=0
37807         RETURN
37808       ENDIF
37809       IVTHR=IVTHR+1
37810       XVTHR=XVTHRO/(201-IVTHR)
37811       UNOPRV=UNON
37812  380  CONTINUE
37813       IF(XVTHR.GT.0.66D0*XDIQT)THEN
37814         IREJ=1
37815         IF(ISQ.EQ.3)IREJ=3
37816         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR  large ',
37817      *  XVTHR
37818         IPCO=0
37819         RETURN
37820       ENDIF
37821       IF(DT_RNDM(V).LT.0.5D0)THEN
37822         XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37823         XVTQII=XDIQT-XVTQI
37824       ELSE
37825         XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37826         XVTQI=XDIQT-XVTQII
37827       ENDIF
37828       IF(IPCO.GE.3)THEN
37829         WRITE(LOUT,'(A,2E12.4)')'  MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
37830       ENDIF
37831 C
37832 C     Prepare 4 momenta of new chains and chain ends
37833 C
37834 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37835 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37836 C    +(4,NTMHKK)
37837 C
37838 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37839 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37840 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37841 C
37842 C     SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37843 C    *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
37844 C
37845       IF(IPIP.EQ.1)THEN
37846         XSQ1=XSQ
37847         XSAQ1=XSAQ
37848         ISQ1=ISQ
37849         ISAQ1=ISAQ
37850       ELSEIF(IPIP.EQ.2)THEN
37851         XSQ1=XSAQ
37852         XSAQ1=XSQ
37853         ISQ1=ISAQ
37854         ISAQ1=ISQ
37855       ENDIF
37856       KK11=IP21
37857 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
37858       KK21=IPP11
37859       KK22=IPP12
37860       XGIVE=0.D0
37861       IF(IPIP.EQ.1)THEN
37862         IDHKT(4+IIGLU1)   =-(ISAQ1-6)
37863       ELSEIF(IPIP.EQ.2)THEN
37864         IDHKT(4+IIGLU1)   =ISAQ1
37865       ENDIF
37866       ISTHKT(4+IIGLU1)  =961
37867       JMOHKT(1,4+IIGLU1)=NC1P
37868       JMOHKT(2,4+IIGLU1)=0
37869       JDAHKT(1,4+IIGLU1)=6+IIGLU1
37870       JDAHKT(2,4+IIGLU1)=0
37871 C     create chain    6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37872       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
37873       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
37874       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
37875       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
37876 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
37877       XXMIST=(PHKT(4,4+IIGLU1)**2-
37878      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37879      *PHKT(1,4+IIGLU1)**2)
37880       IF(XXMIST.GT.0.D0)THEN
37881         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
37882       ELSE
37883         WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
37884         XXMIST=ABS(XXMIST)
37885         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
37886       ENDIF
37887       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
37888       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
37889       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
37890       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
37891       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
37892       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
37893       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
37894       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
37895       IDHKT(5+IIGLU1)   =IP22
37896       ISTHKT(5+IIGLU1)  =962
37897       JMOHKT(1,5+IIGLU1)=NC1T
37898       JMOHKT(2,5+IIGLU1)=0
37899       JDAHKT(1,5+IIGLU1)=6+IIGLU1
37900       JDAHKT(2,5+IIGLU1)=0
37901       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
37902       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
37903       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
37904       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
37905 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
37906       XXMIST=(PHKT(4,5+IIGLU1)**2-
37907      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37908      *PHKT(1,5+IIGLU1)**2)
37909       IF(XXMIST.GT.0.D0)THEN
37910         PHKT(5,5+IIGLU1)  =SQRT(XXMIST)
37911       ELSE
37912         WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
37913         XXMIST=ABS(XXMIST)
37914         PHKT(5,5+IIGLU1)  =SQRT(XXMIST)
37915       ENDIF
37916       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
37917       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
37918       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
37919       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
37920       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
37921       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
37922       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
37923       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
37924       IDHKT(6+IIGLU1)   =88888
37925       ISTHKT(6+IIGLU1)  =96
37926       JMOHKT(1,6+IIGLU1)=4+IIGLU1
37927       JMOHKT(2,6+IIGLU1)=5+IIGLU1
37928       JDAHKT(1,6+IIGLU1)=0
37929       JDAHKT(2,6+IIGLU1)=0
37930       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37931       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37932       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37933       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37934       PHKT(5,6+IIGLU1)
37935      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37936      *            -PHKT(3,6+IIGLU1)**2)
37937       CHAMAL=CHAM1
37938       IF(IPIP.EQ.1)THEN
37939         IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37940       ELSEIF(IPIP.EQ.2)THEN
37941         IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37942       ENDIF
37943 C---------------------------------------------------
37944       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37945         IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
37946 C                    we drop chain 6 and give the energy to chain 3
37947           IDHKT(6+IIGLU1)=22888
37948           XGIVE=1.D0
37949 C         WRITE(6,*)' drop chain 6 xgive=1'
37950           GO TO 7788
37951         ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
37952 C                    we drop chain 6 and give the energy to chain 3
37953 C                    and change KK11 to IDHKT(5)
37954           IDHKT(6+IIGLU1)=22888
37955           XGIVE=1.D0
37956 C         WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
37957           KK11=IDHKT(5+IIGLU1)
37958           GO TO 7788
37959         ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
37960 C                    we drop chain 6 and give the energy to chain 3
37961 C                    and change KK21 to IDHKT(5+IIGLU1)
37962 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
37963           IDHKT(6+IIGLU1)=22888
37964           XGIVE=1.D0
37965 C         WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
37966           KK21=IDHKT(5+IIGLU1)
37967           GO TO 7788
37968         ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
37969 C                    we drop chain 6 and give the energy to chain 3
37970 C                    and change KK22 to IDHKT(5)
37971 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
37972           IDHKT(6+IIGLU1)=22888
37973           XGIVE=1.D0
37974 C         WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
37975           KK22=IDHKT(5+IIGLU1)
37976           GO TO 7788
37977         ENDIF
37978 C       IREJ=1
37979         IPCO=0
37980 C       RETURN
37981         GO TO 3466
37982       ENDIF
37983  7788 CONTINUE
37984 C---------------------------------------------------
37985       IF(IPIP.GE.3)THEN
37986       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37987      * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37988      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37989       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37990      * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37991      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37992       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37993      * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37994      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37995       ENDIF
37996       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
37997       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
37998       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
37999       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
38000       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
38001       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
38002       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
38003       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
38004 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
38005       IF(IPIP.EQ.1)THEN
38006         IDHKT(1)   =1000*KK21+100*KK22+3
38007         IF(IDHKT(1).EQ.1203)IDHKT(1)=2103
38008         IF(IDHKT(1).EQ.1303)IDHKT(1)=3103
38009         IF(IDHKT(1).EQ.2303)IDHKT(1)=3203
38010       ELSEIF(IPIP.EQ.2)THEN
38011         IDHKT(1)   =1000*KK21+100*KK22-3
38012         IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103
38013         IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103
38014         IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203
38015       ENDIF
38016       ISTHKT(1)  =961
38017       JMOHKT(1,1)=NC2P
38018       JMOHKT(2,1)=0
38019       JDAHKT(1,1)=3+IIGLU1
38020       JDAHKT(2,1)=0
38021 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
38022       PHKT(1,1)  =PHKK(1,NC2P)
38023      *+XGIVE*PHKT(1,4+IIGLU1)
38024       PHKT(2,1)  =PHKK(2,NC2P)
38025      *+XGIVE*PHKT(2,4+IIGLU1)
38026       PHKT(3,1)  =PHKK(3,NC2P)
38027      *+XGIVE*PHKT(3,4+IIGLU1)
38028       PHKT(4,1)  =PHKK(4,NC2P)
38029      *+XGIVE*PHKT(4,4+IIGLU1)
38030 C     PHKT(5,1)  =PHKK(5,NC2P)
38031       XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38032      *PHKT(1,1)**2
38033       IF(XXMIST.GT.0.D0)THEN
38034         PHKT(5,1)  =SQRT(XXMIST)
38035       ELSE
38036         WRITE(LOUT,*)'MGSQBS2',XXMIST
38037         XXMIST=ABS(XXMIST)
38038         PHKT(5,1)  =SQRT(XXMIST)
38039       ENDIF
38040       VHKT(1,1)  =VHKK(1,NC2P)
38041       VHKT(2,1)  =VHKK(2,NC2P)
38042       VHKT(3,1)  =VHKK(3,NC2P)
38043       VHKT(4,1)  =VHKK(4,NC2P)
38044       WHKT(1,1)  =WHKK(1,NC2P)
38045       WHKT(2,1)  =WHKK(2,NC2P)
38046       WHKT(3,1)  =WHKK(3,NC2P)
38047       WHKT(4,1)  =WHKK(4,NC2P)
38048 C     Add here IIGLU1 gluons to this chaina
38049       PG1=0.D0
38050       PG2=0.D0
38051       PG3=0.D0
38052       PG4=0.D0
38053       IF(IIGLU1.GE.1)THEN
38054       JJG=NC1P
38055       DO 61 IIG=2,2+IIGLU1-1
38056         KKG=JJG+IIG-1
38057         IDHKT(IIG)   =IDHKK(KKG)
38058         ISTHKT(IIG)  =921
38059         JMOHKT(1,IIG)=KKG
38060         JMOHKT(2,IIG)=0
38061         JDAHKT(1,IIG)=3+IIGLU1
38062         JDAHKT(2,IIG)=0
38063         PHKT(1,IIG)=PHKK(1,KKG)
38064         PG1=PG1+ PHKT(1,IIG)
38065         PHKT(2,IIG)=PHKK(2,KKG)
38066         PG2=PG2+ PHKT(2,IIG)
38067         PHKT(3,IIG)=PHKK(3,KKG)
38068         PG3=PG3+ PHKT(3,IIG)
38069         PHKT(4,IIG)=PHKK(4,KKG)
38070         PG4=PG4+ PHKT(4,IIG)
38071         PHKT(5,IIG)=PHKK(5,KKG)
38072         VHKT(1,IIG)  =VHKK(1,KKG)
38073         VHKT(2,IIG)  =VHKK(2,KKG)
38074         VHKT(3,IIG)  =VHKK(3,KKG)
38075         VHKT(4,IIG)  =VHKK(4,KKG)
38076         WHKT(1,IIG)  =WHKK(1,KKG)
38077         WHKT(2,IIG)  =WHKK(2,KKG)
38078         WHKT(3,IIG)  =WHKK(3,KKG)
38079         WHKT(4,IIG)  =WHKK(4,KKG)
38080    61 CONTINUE
38081       ENDIF
38082 C     IDHKT(2)   =IP21
38083       IDHKT(2+IIGLU1)   =KK11
38084       ISTHKT(2+IIGLU1)  =962
38085       JMOHKT(1,2+IIGLU1)=NC1T
38086       JMOHKT(2,2+IIGLU1)=0
38087       JDAHKT(1,2+IIGLU1)=3+IIGLU1
38088       JDAHKT(2,2+IIGLU1)=0
38089       PHKT(1,2+IIGLU1)  =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
38090 C    * +0.5D0*PHKK(1,NC2T)
38091      *+XGIVE*PHKT(1,5+IIGLU1)
38092       PHKT(2,2+IIGLU1)  =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
38093 C    *+0.5D0*PHKK(2,NC2T)
38094      *+XGIVE*PHKT(2,5+IIGLU1)
38095       PHKT(3,2+IIGLU1)  =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
38096 C    *+0.5D0*PHKK(3,NC2T)
38097      *+XGIVE*PHKT(3,5+IIGLU1)
38098       PHKT(4,2+IIGLU1)  =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
38099 C    *+0.5D0*PHKK(4,NC2T)
38100      *+XGIVE*PHKT(4,5+IIGLU1)
38101 C     PHKT(5,2)  =PHKK(5,NC1T)
38102       XXMIST=(PHKT(4,2+IIGLU1)**2-
38103      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38104      *PHKT(1,2+IIGLU1)**2)
38105       IF(XXMIST.GT.0.D0)THEN
38106         PHKT(5,2+IIGLU1)  =SQRT(XXMIST)
38107       ELSE
38108         WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
38109         XXMIST=ABS(XXMIST)
38110         PHKT(5,2+IIGLU1)  =SQRT(XXMIST)
38111       ENDIF
38112       VHKT(1,2+IIGLU1)  =VHKK(1,NC1T)
38113       VHKT(2,2+IIGLU1)  =VHKK(2,NC1T)
38114       VHKT(3,2+IIGLU1)  =VHKK(3,NC1T)
38115       VHKT(4,2+IIGLU1)  =VHKK(4,NC1T)
38116       WHKT(1,2+IIGLU1)  =WHKK(1,NC1T)
38117       WHKT(2,2+IIGLU1)  =WHKK(2,NC1T)
38118       WHKT(3,2+IIGLU1)  =WHKK(3,NC1T)
38119       WHKT(4,2+IIGLU1)  =WHKK(4,NC1T)
38120       IDHKT(3+IIGLU1)   =88888
38121       ISTHKT(3+IIGLU1)  =96
38122       JMOHKT(1,3+IIGLU1)=1
38123       JMOHKT(2,3+IIGLU1)=2+IIGLU1
38124       JDAHKT(1,3+IIGLU1)=0
38125       JDAHKT(2,3+IIGLU1)=0
38126       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38127       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38128       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38129       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38130       PHKT(5,3+IIGLU1)
38131      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38132      *            -PHKT(3,3+IIGLU1)**2)
38133       IF(IPIP.EQ.3)THEN
38134       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
38135      * JDAHKT(1,1),
38136      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38137       DO 71 IIG=2,2+IIGLU1-1
38138       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38139      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38140      * JDAHKT(1,IIG),
38141      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38142    71 CONTINUE
38143       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
38144      * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38145      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38146       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38147      * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38148      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38149       ENDIF
38150       CHAMAL=CHAB1
38151       IF(IPIP.EQ.1)THEN
38152         IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
38153       ELSEIF(IPIP.EQ.2)THEN
38154         IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
38155       ENDIF
38156       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38157 C       IREJ=1
38158         IPCO=0
38159 C       RETURN
38160         GO TO 3466
38161       ENDIF
38162       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
38163       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
38164       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
38165       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
38166       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
38167       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
38168       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
38169       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
38170 C     IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ+1
38171       IDHKT(7+IIGLU1)   =IP1
38172       ISTHKT(7+IIGLU1)  =961
38173       JMOHKT(1,7+IIGLU1)=NC1P
38174       JMOHKT(2,7+IIGLU1)=0
38175       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38176       JDAHKT(2,7+IIGLU1)=0
38177       PHKT(1,7+IIGLU1)  =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
38178       PHKT(2,7+IIGLU1)  =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
38179       PHKT(3,7+IIGLU1)  =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
38180       PHKT(4,7+IIGLU1)  =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
38181 C     PHKT(5,7+IIGLU1)  =PHKK(5,NC1P)
38182       XXMIST=(PHKT(4,7+IIGLU1)**2-
38183      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38184      *PHKT(1,7+IIGLU1)**2)
38185       IF(XXMIST.GT.0.D0)THEN
38186         PHKT(5,7+IIGLU1)  =SQRT(XXMIST)
38187       ELSE
38188         WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
38189         XXMIST=ABS(XXMIST)
38190         PHKT(5,7+IIGLU1)  =SQRT(XXMIST)
38191       ENDIF
38192       VHKT(1,7+IIGLU1)  =VHKK(1,NC1P)
38193       VHKT(2,7+IIGLU1)  =VHKK(2,NC1P)
38194       VHKT(3,7+IIGLU1)  =VHKK(3,NC1P)
38195       VHKT(4,7+IIGLU1)  =VHKK(4,NC1P)
38196       WHKT(1,7+IIGLU1)  =WHKK(1,NC1P)
38197       WHKT(2,7+IIGLU1)  =WHKK(2,NC1P)
38198       WHKT(3,7+IIGLU1)  =WHKK(3,NC1P)
38199       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
38200 C     IDHKT(7)   =1000*IPP1+100*ISQ+1
38201 C     Insert here the IIGLU2 gluons
38202       PG1=0.D0
38203       PG2=0.D0
38204       PG3=0.D0
38205       PG4=0.D0
38206       IF(IIGLU2.GE.1)THEN
38207       JJG=NC2P
38208       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38209         KKG=JJG+IIG-7-IIGLU1
38210         IDHKT(IIG)   =IDHKK(KKG)
38211         ISTHKT(IIG)  =921
38212         JMOHKT(1,IIG)=KKG
38213         JMOHKT(2,IIG)=0
38214         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38215         JDAHKT(2,IIG)=0
38216         PHKT(1,IIG)=PHKK(1,KKG)
38217         PG1=PG1+ PHKT(1,IIG)
38218         PHKT(2,IIG)=PHKK(2,KKG)
38219         PG2=PG2+ PHKT(2,IIG)
38220         PHKT(3,IIG)=PHKK(3,KKG)
38221         PG3=PG3+ PHKT(3,IIG)
38222         PHKT(4,IIG)=PHKK(4,KKG)
38223         PG4=PG4+ PHKT(4,IIG)
38224         PHKT(5,IIG)=PHKK(5,KKG)
38225         VHKT(1,IIG)  =VHKK(1,KKG)
38226         VHKT(2,IIG)  =VHKK(2,KKG)
38227         VHKT(3,IIG)  =VHKK(3,KKG)
38228         VHKT(4,IIG)  =VHKK(4,KKG)
38229         WHKT(1,IIG)  =WHKK(1,KKG)
38230         WHKT(2,IIG)  =WHKK(2,KKG)
38231         WHKT(3,IIG)  =WHKK(3,KKG)
38232         WHKT(4,IIG)  =WHKK(4,KKG)
38233    81 CONTINUE
38234       ENDIF
38235       IF(IPIP.EQ.1)THEN
38236         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*ISQ1+3
38237         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
38238         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
38239         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
38240       ELSEIF(IPIP.EQ.2)THEN
38241 **NEW
38242 C       IDHKT(8)   =1000*IPP2+100*(-ISQ1+6)-3
38243         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*(-ISQ1+6)-3
38244 **
38245         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
38246         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
38247         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
38248       ENDIF
38249       ISTHKT(8+IIGLU1+IIGLU2)  =962
38250       JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
38251       JMOHKT(2,8+IIGLU1+IIGLU2)=0
38252       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38253       JDAHKT(2,8+IIGLU1+IIGLU2)=0
38254 C     PHKT(1,8)  =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
38255 C     PHKT(2,8)  =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
38256 C     PHKT(3,8)  =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
38257 C     PHKT(4,8)  =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
38258       PHKT(1,8+IIGLU1+IIGLU2)  =
38259      * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
38260       PHKT(2,8+IIGLU1+IIGLU2)  =
38261      * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
38262       PHKT(3,8+IIGLU1+IIGLU2)  =
38263      * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
38264       PHKT(4,8+IIGLU1+IIGLU2)  =
38265      * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
38266 C     WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
38267 C    * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
38268       IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
38269 C       IREJ=1
38270 C       WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
38271         IPCO=0
38272 C       RETURN
38273         GO TO 3466
38274       ENDIF
38275 C     PHKT(5,8)  =PHKK(5,NC2T)
38276       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38277      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38278      *PHKT(1,8+IIGLU1+IIGLU2)**2)
38279       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC2T)
38280       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC2T)
38281       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC2T)
38282       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC2T)
38283       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC2T)
38284       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC2T)
38285       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC2T)
38286       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC2T)
38287       IDHKT(9+IIGLU1+IIGLU2)   =88888
38288       ISTHKT(9+IIGLU1+IIGLU2)  =96
38289       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38290       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38291       JDAHKT(1,9+IIGLU1+IIGLU2)=0
38292       JDAHKT(2,9+IIGLU1+IIGLU2)=0
38293       PHKT(1,9+IIGLU1+IIGLU2)
38294      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
38295       PHKT(2,9+IIGLU1+IIGLU2)
38296      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
38297       PHKT(3,9+IIGLU1+IIGLU2)
38298      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
38299       PHKT(4,9+IIGLU1+IIGLU2)
38300      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
38301       PHKT(5,9+IIGLU1+IIGLU2)
38302      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
38303      * PHKT(2,9+IIGLU1+IIGLU2)**2
38304      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
38305       IF(IPIP.GE.3)THEN
38306       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38307      * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38308      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38309       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38310       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38311      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38312      * JDAHKT(1,IIG),
38313      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38314    91 CONTINUE
38315       WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
38316      * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
38317      *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
38318      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38319       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38320      * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
38321      *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
38322      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38323       ENDIF
38324       CHAMAL=CHAB1
38325       IF(IPIP.EQ.1)THEN
38326         IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38327       ELSEIF(IPIP.EQ.2)THEN
38328         IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38329       ENDIF
38330       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38331 C       IREJ=1
38332         IPCO=0
38333 C       RETURN
38334         GO TO 3466
38335       ENDIF
38336       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
38337       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
38338       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
38339       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
38340       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
38341       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
38342       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
38343       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
38344 C
38345       IPCO=0
38346       IGCOUN=9+IIGLU1+IIGLU2
38347        RETURN
38348        END
38349
38350 *$ CREATE MUSQBS1.FOR
38351 *COPY MUSQBS1
38352 C
38353 C
38354 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38355       SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38356      *              IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
38357 C
38358 C                  USQBS-1 diagram (split projectile diquark)
38359 C
38360       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38361       SAVE
38362
38363       PARAMETER ( LINP = 10 ,
38364      &            LOUT = 6 ,
38365      &            LDAT = 9 )
38366 * event history
38367       PARAMETER (NMXHKK=200000)
38368       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38369      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38370      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38371 * extended event history
38372       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38373      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38374      &                IHIST(2,NMXHKK)
38375 * Lorentz-parameters of the current interaction
38376       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
38377      &                UMO,PPCM,EPROJ,PPROJ
38378 * diquark-breaking mechanism
38379       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
38380
38381 C
38382       PARAMETER (NTMHKK= 300)
38383       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38384      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38385      +(4,NTMHKK)
38386 *KEEP,XSEADI.
38387       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
38388      +SSMIMQ,VVMTHR
38389 *KEEP,DPRIN.
38390       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
38391       COMMON /EVFLAG/ NUMEV
38392 C
38393 C                  USQBS-1 diagram (split projectile diquark)
38394 C
38395 C     Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
38396 C     Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
38397 C
38398 C     Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
38399 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
38400 C
38401 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38402 C                   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38403 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38404 C
38405 C       Put new chains into COMMON /HKKTMP/
38406 C
38407       IIGLU1=NC1T-NC1P-1
38408       IIGLU2=NC2T-NC2P-1
38409       IGCOUN=0
38410 C     WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
38411       CVQ=1.D0
38412       IREJ=0
38413       IF(IPIP.EQ.3)THEN
38414 C     IF(NUMEV.EQ.-324)THEN
38415       WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
38416      *             ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
38417      *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38418      *              IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
38419       ENDIF
38420 C
38421 C
38422 C
38423 C     determine x-values of NC1P diquark
38424       XDIQP=PHKK(4,NC1P)*2.D0/UMO
38425       XVQT=PHKK(4,NC1T)*2.D0/UMO
38426 C
38427 C     determine x-values of sea quark pair
38428 C
38429       IPCO=1
38430       ICOU=0
38431  2234 CONTINUE
38432       ICOU=ICOU+1
38433       IF(ICOU.GE.500)THEN
38434         IREJ=1
38435         IF(ISQ.EQ.3)IREJ=3
38436         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
38437         IPCO=0
38438         RETURN
38439       ENDIF
38440       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call  XSEAPA: UMO,XDIQP,XVQT ',
38441      * UMO, XDIQP,XVQT
38442       XSQ=0.D0
38443       XSAQ=0.D0
38444 **NEW
38445 C     CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
38446       IF (IPIP.EQ.1) THEN
38447          XQMAX  = XDIQP/2.0D0
38448          XAQMAX = 2.D0*XVQT/3.0D0
38449       ELSE
38450          XQMAX  = 2.D0*XVQT/3.0D0
38451          XAQMAX = XDIQP/2.0D0
38452       ENDIF
38453       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
38454       ISAQ = 6+ISQ
38455 C     write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
38456 **
38457       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
38458       IF(IREJ.GE.1)THEN
38459         IF(IPCO.GE.3)
38460      &     WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
38461         IPCO=0
38462         RETURN
38463       ENDIF
38464       IF(IPIP.EQ.1)THEN
38465         IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
38466       ELSEIF(IPIP.EQ.2)THEN
38467         IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
38468       ENDIF
38469       IF(IPCO.GE.3)THEN
38470         WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
38471      *  XDIQP,XVQT,XSQ,XSAQ
38472       ENDIF
38473 C
38474 C     subtract xsq,xsaq from NC1P diquark and NC1T quark
38475 C
38476 C     XSQ=0.D0
38477       IF(IPIP.EQ.1)THEN
38478         XDIQP=XDIQP-XSQ
38479         XVQT =XVQT -XSAQ
38480       ELSEIF(IPIP.EQ.2)THEN
38481         XDIQP=XDIQP-XSAQ
38482         XVQT =XVQT -XSQ
38483       ENDIF
38484       IF(IPCO.GE.3)
38485      &   WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
38486 C
38487 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
38488 C
38489       XVTHRO=CVQ/UMO
38490       IVTHR=0
38491  3466 CONTINUE
38492       IF(IVTHR.EQ.10)THEN
38493         IREJ=1
38494         IF(ISQ.EQ.3)IREJ=3
38495         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
38496         IPCO=0
38497         RETURN
38498       ENDIF
38499       IVTHR=IVTHR+1
38500       XVTHR=XVTHRO/(201-IVTHR)
38501       UNOPRV=UNON
38502  380  CONTINUE
38503       IF(XVTHR.GT.0.66D0*XDIQP)THEN
38504         IREJ=1
38505         IF(ISQ.EQ.3)IREJ=3
38506         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR  large ',
38507      *  XVTHR
38508         IPCO=0
38509         RETURN
38510       ENDIF
38511       IF(DT_RNDM(V).LT.0.5D0)THEN
38512         XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
38513         XVPQII=XDIQP-XVPQI
38514       ELSE
38515         XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
38516         XVPQI=XDIQP-XVPQII
38517       ENDIF
38518       IF(IPCO.GE.3)THEN
38519         WRITE(LOUT,'(A,2E12.4)')'  MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
38520       ENDIF
38521 C
38522 C     Prepare 4 momenta of new chains and chain ends
38523 C
38524 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38525 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38526 C    +(4,NTMHKK)
38527 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38528 C                   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38529 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38530       IF(IPIP.EQ.1)THEN
38531         XSQ1=XSQ
38532         XSAQ1=XSAQ
38533         ISQ1=ISQ
38534         ISAQ1=ISAQ
38535       ELSEIF(IPIP.EQ.2)THEN
38536         XSQ1=XSAQ
38537         XSAQ1=XSQ
38538         ISQ1=ISAQ
38539         ISAQ1=ISQ
38540       ENDIF
38541       IDHKT(1)   =IP11
38542       ISTHKT(1)  =931
38543       JMOHKT(1,1)=NC1P
38544       JMOHKT(2,1)=0
38545       JDAHKT(1,1)=3+IIGLU1
38546       JDAHKT(2,1)=0
38547 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38548       PHKT(1,1)  =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
38549       PHKT(2,1)  =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
38550       PHKT(3,1)  =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
38551       PHKT(4,1)  =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
38552 C     PHKT(5,1)  =PHKK(5,NC1P)
38553       XMIST  =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38554      *PHKT(1,1)**2)
38555       IF(XMIST.GE.0.D0)THEN
38556       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38557      *PHKT(1,1)**2)
38558       ELSE
38559 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38560        PHKT(5,1)=0.D0
38561       ENDIF
38562       VHKT(1,1)  =VHKK(1,NC1P)
38563       VHKT(2,1)  =VHKK(2,NC1P)
38564       VHKT(3,1)  =VHKK(3,NC1P)
38565       VHKT(4,1)  =VHKK(4,NC1P)
38566       WHKT(1,1)  =WHKK(1,NC1P)
38567       WHKT(2,1)  =WHKK(2,NC1P)
38568       WHKT(3,1)  =WHKK(3,NC1P)
38569       WHKT(4,1)  =WHKK(4,NC1P)
38570 C     Add here IIGLU1 gluons to this chaina
38571       PG1=0.D0
38572       PG2=0.D0
38573       PG3=0.D0
38574       PG4=0.D0
38575       IF(IIGLU1.GE.1)THEN
38576       JJG=NC1P
38577       DO 61 IIG=2,2+IIGLU1-1
38578         KKG=JJG+IIG-1
38579         IDHKT(IIG)   =IDHKK(KKG)
38580         ISTHKT(IIG)  =921
38581         JMOHKT(1,IIG)=KKG
38582         JMOHKT(2,IIG)=0
38583         JDAHKT(1,IIG)=3+IIGLU1
38584         JDAHKT(2,IIG)=0
38585         PHKT(1,IIG)=PHKK(1,KKG)
38586         PG1=PG1+ PHKT(1,IIG)
38587         PHKT(2,IIG)=PHKK(2,KKG)
38588         PG2=PG2+ PHKT(2,IIG)
38589         PHKT(3,IIG)=PHKK(3,KKG)
38590         PG3=PG3+ PHKT(3,IIG)
38591         PHKT(4,IIG)=PHKK(4,KKG)
38592         PG4=PG4+ PHKT(4,IIG)
38593         PHKT(5,IIG)=PHKK(5,KKG)
38594         VHKT(1,IIG)  =VHKK(1,KKG)
38595         VHKT(2,IIG)  =VHKK(2,KKG)
38596         VHKT(3,IIG)  =VHKK(3,KKG)
38597         VHKT(4,IIG)  =VHKK(4,KKG)
38598         WHKT(1,IIG) =WHKK(1,KKG)
38599         WHKT(2,IIG) =WHKK(2,KKG)
38600         WHKT(3,IIG) =WHKK(3,KKG)
38601         WHKT(4,IIG) =WHKK(4,KKG)
38602    61 CONTINUE
38603       ENDIF
38604       IDHKT(2+IIGLU1)   =IPP2
38605       ISTHKT(2+IIGLU1)  =932
38606       JMOHKT(1,2+IIGLU1)=NC2T
38607       JMOHKT(2,2+IIGLU1)=0
38608       JDAHKT(1,2+IIGLU1)=3+IIGLU1
38609       JDAHKT(2,2+IIGLU1)=0
38610       PHKT(1,2+IIGLU1)  =PHKK(1,NC2T)
38611       PHKT(2,2+IIGLU1)  =PHKK(2,NC2T)
38612       PHKT(3,2+IIGLU1)  =PHKK(3,NC2T)
38613       PHKT(4,2+IIGLU1)  =PHKK(4,NC2T)
38614 C     PHKT(5,2+IIGLU1)  =PHKK(5,NC2T)
38615       XMIST=(PHKT(4,2+IIGLU1)**2-
38616      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38617      *PHKT(1,2+IIGLU1)**2)
38618       IF(XMIST.GT.0.D0)THEN
38619       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
38620      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38621      *PHKT(1,2+IIGLU1)**2)
38622       ELSE
38623 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38624         PHKT(5,2+IIGLU1)=0.D0
38625       ENDIF
38626       VHKT(1,2+IIGLU1)  =VHKK(1,NC2T)
38627       VHKT(2,2+IIGLU1)  =VHKK(2,NC2T)
38628       VHKT(3,2+IIGLU1)  =VHKK(3,NC2T)
38629       VHKT(4,2+IIGLU1)  =VHKK(4,NC2T)
38630       WHKT(1,2+IIGLU1)  =WHKK(1,NC2T)
38631       WHKT(2,2+IIGLU1)  =WHKK(2,NC2T)
38632       WHKT(3,2+IIGLU1)  =WHKK(3,NC2T)
38633       WHKT(4,2+IIGLU1)  =WHKK(4,NC2T)
38634       IDHKT(3+IIGLU1)   =88888
38635       ISTHKT(3+IIGLU1)  =94
38636       JMOHKT(1,3+IIGLU1)=1
38637       JMOHKT(2,3+IIGLU1)=2+IIGLU1
38638       JDAHKT(1,3+IIGLU1)=0
38639       JDAHKT(2,3+IIGLU1)=0
38640       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38641       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38642       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38643       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38644       XMIST
38645      * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38646      *            -PHKT(3,3+IIGLU1)**2)
38647       IF(XMIST.GE.0.D0)THEN
38648       PHKT(5,3+IIGLU1)
38649      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38650      *            -PHKT(3,3+IIGLU1)**2)
38651       ELSE
38652 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38653        PHKT(5,1)=0.D0
38654       ENDIF
38655       IF(IPIP.GE.3)THEN
38656 C     IF(NUMEV.EQ.-324)THEN
38657       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
38658      * JMOHKT(2,1),JDAHKT(1,1),
38659      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38660       DO 71 IIG=2,2+IIGLU1-1
38661       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38662      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38663      * JDAHKT(1,IIG),
38664      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38665    71 CONTINUE
38666       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
38667      * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38668      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38669       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38670      * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38671      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38672       ENDIF
38673       CHAMAL=CHAM1
38674       IF(IPIP.EQ.1)THEN
38675         IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
38676       ELSEIF(IPIP.EQ.2)THEN
38677         IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
38678       ENDIF
38679       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38680 C       IREJ=1
38681         IPCO=0
38682 C       RETURN
38683 C       WRITE(6,*)' MUSQBS1 jump back from chain 3'
38684         GO TO 3466
38685       ENDIF
38686       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
38687       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
38688       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
38689       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
38690       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
38691       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
38692       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
38693       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
38694       IDHKT(4+IIGLU1)   =IP12
38695       ISTHKT(4+IIGLU1)  =931
38696       JMOHKT(1,4+IIGLU1)=NC1P
38697       JMOHKT(2,4+IIGLU1)=0
38698       JDAHKT(1,4+IIGLU1)=6+IIGLU1
38699       JDAHKT(2,4+IIGLU1)=0
38700 C   create  chain   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38701       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
38702       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
38703       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
38704       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
38705 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
38706       XMIST  =(PHKT(4,4+IIGLU1)**2-
38707      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
38708      *PHKT(1,4+IIGLU1)**2)
38709       IF(XMIST.GT.0.D0)THEN
38710       PHKT(5,4+IIGLU1)  =SQRT(PHKT(4,4+IIGLU1)**2-
38711      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
38712      *PHKT(1,4+IIGLU1)**2)
38713       ELSE
38714 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38715         PHKT(5,4+IIGLU1)=0.D0
38716       ENDIF
38717       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
38718       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
38719       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
38720       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
38721       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
38722       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
38723       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
38724       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
38725       IF(IPIP.EQ.1)THEN
38726         IDHKT(5+IIGLU1)   =-(ISAQ1-6)
38727       ELSEIF(IPIP.EQ.2)THEN
38728         IDHKT(5+IIGLU1)   =ISAQ1
38729       ENDIF
38730       ISTHKT(5+IIGLU1)  =932
38731       JMOHKT(1,5+IIGLU1)=NC1T
38732       JMOHKT(2,5+IIGLU1)=0
38733       JDAHKT(1,5+IIGLU1)=6+IIGLU1
38734       JDAHKT(2,5+IIGLU1)=0
38735       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
38736       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
38737       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
38738       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
38739 C     IF( PHKT(4,5).EQ.0.D0)THEN
38740 C       IREJ=1
38741 CIPCO=0
38742 CRETURN
38743 C     ENDIF
38744 C     PHKT(5,5)  =PHKK(5,NC1T)
38745       XMIST=(PHKT(4,5+IIGLU1)**2-
38746      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
38747      *PHKT(1,5+IIGLU1)**2)
38748       IF(XMIST.GT.0.D0)THEN
38749       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
38750      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
38751      *PHKT(1,5+IIGLU1)**2)
38752       ELSE
38753 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38754         PHKT(5,5+IIGLU1)=0.D0
38755       ENDIF
38756       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
38757       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
38758       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
38759       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
38760       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
38761       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
38762       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
38763       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
38764       IDHKT(6+IIGLU1)   =88888
38765       ISTHKT(6+IIGLU1)  =94
38766       JMOHKT(1,6+IIGLU1)=4+IIGLU1
38767       JMOHKT(2,6+IIGLU1)=5+IIGLU1
38768       JDAHKT(1,6+IIGLU1)=0
38769       JDAHKT(2,6+IIGLU1)=0
38770       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
38771       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
38772       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
38773       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
38774       XMIST
38775      * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
38776      *            -PHKT(3,6+IIGLU1)**2)
38777       IF(XMIST.GE.0.D0)THEN
38778       PHKT(5,6+IIGLU1)
38779      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
38780      *            -PHKT(3,6+IIGLU1)**2)
38781       ELSE
38782 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38783        PHKT(5,1)=0.D0
38784       ENDIF
38785 C     IF(IPIP.EQ.3)THEN
38786       CHAMAL=CHAM1
38787       IF(IPIP.EQ.1)THEN
38788         IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
38789       ELSEIF(IPIP.EQ.2)THEN
38790         IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
38791       ENDIF
38792       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
38793 C       IREJ=1
38794         IPCO=0
38795 C       RETURN
38796 C       WRITE(6,*)' MGSQBS1 jump back from chain 6',
38797 C    *  CHAMAL,PHKT(5,6+IIGLU1)
38798         GO TO 3466
38799       ENDIF
38800       IF(IPIP.GE.3)THEN
38801 C     IF(NUMEV.EQ.-324)THEN
38802       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
38803      * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
38804      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
38805       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
38806      * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
38807      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
38808       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
38809      * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
38810      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
38811       ENDIF
38812       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
38813       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
38814       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
38815       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
38816       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
38817       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
38818       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
38819       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
38820       IF(IPIP.EQ.1)THEN
38821         IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ+3
38822         IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
38823         IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
38824         IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
38825       ELSEIF(IPIP.EQ.2)THEN
38826         IDHKT(7+IIGLU1)   =1000*IPP1+100*(-ISQ1+6)-3
38827         IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
38828         IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
38829         IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
38830 C       WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
38831       ENDIF
38832       ISTHKT(7+IIGLU1)  =931
38833       JMOHKT(1,7+IIGLU1)=NC2P
38834       JMOHKT(2,7+IIGLU1)=0
38835       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38836       JDAHKT(2,7+IIGLU1)=0
38837 C    create chain     9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38838       PHKT(1,7+IIGLU1)  =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
38839       PHKT(2,7+IIGLU1)  =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
38840       PHKT(3,7+IIGLU1)  =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
38841       PHKT(4,7+IIGLU1)  =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
38842 C     WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
38843 C    * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
38844       IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
38845 C       IREJ=1
38846 C       WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
38847         IPCO=0
38848 C       RETURN
38849         GO TO 3466
38850       ENDIF
38851 C     PHKT(5,7)  =PHKK(5,NC2P)
38852       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
38853      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38854      *PHKT(1,7+IIGLU1)**2)
38855       VHKT(1,7+IIGLU1)  =VHKK(1,NC2P)
38856       VHKT(2,7+IIGLU1)  =VHKK(2,NC2P)
38857       VHKT(3,7+IIGLU1)  =VHKK(3,NC2P)
38858       VHKT(4,7+IIGLU1)  =VHKK(4,NC2P)
38859       WHKT(1,7+IIGLU1)  =WHKK(1,NC2P)
38860       WHKT(2,7+IIGLU1)  =WHKK(2,NC2P)
38861       WHKT(3,7+IIGLU1)  =WHKK(3,NC2P)
38862       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
38863 C     Insert here the IIGLU2 gluons
38864       PG1=0.D0
38865       PG2=0.D0
38866       PG3=0.D0
38867       PG4=0.D0
38868       IF(IIGLU2.GE.1)THEN
38869       JJG=NC2P
38870       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38871         KKG=JJG+IIG-7-IIGLU1
38872         IDHKT(IIG)   =IDHKK(KKG)
38873         ISTHKT(IIG)  =921
38874         JMOHKT(1,IIG)=KKG
38875         JMOHKT(2,IIG)=0
38876         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38877         JDAHKT(2,IIG)=0
38878         PHKT(1,IIG)=PHKK(1,KKG)
38879         PG1=PG1+ PHKT(1,IIG)
38880         PHKT(2,IIG)=PHKK(2,KKG)
38881         PG2=PG2+ PHKT(2,IIG)
38882         PHKT(3,IIG)=PHKK(3,KKG)
38883         PG3=PG3+ PHKT(3,IIG)
38884         PHKT(4,IIG)=PHKK(4,KKG)
38885         PG4=PG4+ PHKT(4,IIG)
38886         PHKT(5,IIG)=PHKK(5,KKG)
38887         VHKT(1,IIG)  =VHKK(1,KKG)
38888         VHKT(2,IIG)  =VHKK(2,KKG)
38889         VHKT(3,IIG)  =VHKK(3,KKG)
38890         VHKT(4,IIG)  =VHKK(4,KKG)
38891         WHKT(1,IIG)  =WHKK(1,KKG)
38892         WHKT(2,IIG) =WHKK(2,KKG)
38893         WHKT(3,IIG) =WHKK(3,KKG)
38894         WHKT(4,IIG) =WHKK(4,KKG)
38895    81 CONTINUE
38896       ENDIF
38897       IDHKT(8+IIGLU1+IIGLU2)   =IP2
38898       ISTHKT(8+IIGLU1+IIGLU2)  =932
38899       JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
38900       JMOHKT(2,8+IIGLU1+IIGLU2)=0
38901       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38902       JDAHKT(2,8+IIGLU1+IIGLU2)=0
38903       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
38904       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
38905       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
38906       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
38907 C     PHKT(5,8+IIGLU1+IIGLU2)  =PHKK(5,NC1T)
38908       XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
38909      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38910      *PHKT(1,8+IIGLU1+IIGLU2)**2)
38911       IF(XMIST.GT.0.D0)THEN
38912       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38913      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38914      *PHKT(1,8+IIGLU1+IIGLU2)**2)
38915       ELSE
38916 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38917         PHKT(5,8+IIGLU1+IIGLU2)=0.D0
38918       ENDIF
38919       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC1T)
38920       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC1T)
38921       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC1T)
38922       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC1T)
38923       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC1T)
38924       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC1T)
38925       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC1T)
38926       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC1T)
38927       IDHKT(9+IIGLU1+IIGLU2)   =88888
38928       ISTHKT(9+IIGLU1+IIGLU2)  =94
38929       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38930       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38931       JDAHKT(1,9+IIGLU1+IIGLU2)=0
38932       JDAHKT(2,9+IIGLU1+IIGLU2)=0
38933       PHKT(1,9+IIGLU1+IIGLU2)
38934      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
38935       PHKT(2,9+IIGLU1+IIGLU2)
38936      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
38937       PHKT(3,9+IIGLU1+IIGLU2)
38938      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
38939       PHKT(4,9+IIGLU1+IIGLU2)
38940      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
38941       XMIST
38942      *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
38943      * -PHKT(2,9+IIGLU1+IIGLU2)**2
38944      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
38945       IF(XMIST.GE.0.D0)THEN
38946       PHKT(5,9+IIGLU1+IIGLU2)
38947      *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
38948      * -PHKT(2,9+IIGLU1+IIGLU2)**2
38949      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
38950       ELSE
38951 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38952        PHKT(5,1)=0.D0
38953       ENDIF
38954       IF(IPIP.GE.3)THEN
38955 C     IF(NUMEV.EQ.-324)THEN
38956       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38957      * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38958      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38959       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38960       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38961      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38962      * JDAHKT(1,IIG),
38963      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38964    91 CONTINUE
38965       WRITE(LOUT,*)8+IIGLU1+IIGLU2,
38966      * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
38967      * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
38968      *JDAHKT(1,8+IIGLU1+IIGLU2),
38969      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38970       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38971      * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
38972      *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
38973      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38974       ENDIF
38975       CHAMAL=CHAB1
38976       IF(IPIP.EQ.1)THEN
38977         IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38978       ELSEIF(IPIP.EQ.2)THEN
38979         IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38980       ENDIF
38981       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38982 C       IREJ=1
38983         IPCO=0
38984 C       RETURN
38985 C       WRITE(6,*)' MGSQBS1 jump back from chain 9',
38986 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
38987         GO TO 3466
38988       ENDIF
38989       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
38990       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
38991       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
38992       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
38993       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
38994       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
38995       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
38996       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
38997 C
38998       IPCO=0
38999       IGCOUN=9+IIGLU1+IIGLU2
39000        RETURN
39001        END
39002
39003 *$ CREATE MGSQBS1.FOR
39004 *COPY MGSQBS1
39005 C
39006 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
39007       SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
39008      *              IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
39009 C
39010 C                  GSQBS-1 diagram (split projectile diquark)
39011 C
39012       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39013       SAVE
39014
39015       PARAMETER ( LINP = 10 ,
39016      &            LOUT = 6 ,
39017      &            LDAT = 9 )
39018 * event history
39019       PARAMETER (NMXHKK=200000)
39020       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39021      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39022      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39023 * extended event history
39024       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39025      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39026      &                IHIST(2,NMXHKK)
39027 * Lorentz-parameters of the current interaction
39028       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
39029      &                UMO,PPCM,EPROJ,PPROJ
39030 * diquark-breaking mechanism
39031       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
39032
39033 C
39034       PARAMETER (NTMHKK= 300)
39035       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39036      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39037      +(4,NTMHKK)
39038 *KEEP,XSEADI.
39039       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
39040      +SSMIMQ,VVMTHR
39041 *KEEP,DPRIN.
39042       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
39043 C
39044 C                  GSQBS-1 diagram (split projectile diquark)
39045 C
39046 C
39047 C     Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
39048 C     Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
39049 C
39050 C     Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
39051 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
39052 C
39053 C     Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
39054 C                   6 valence quark(vq2P 4)-sea-quark(aqsP 5)
39055 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
39056 C
39057 C       Put new chains into COMMON /HKKTMP/
39058 C
39059       IIGLU1=NC1T-NC1P-1
39060       IIGLU2=NC2T-NC2P-1
39061       IGCOUN=0
39062 C     WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
39063       CVQ=1.D0
39064       NNNC1=IDHKK(NC1)/1000
39065       MMMC1=IDHKK(NC1)-NNNC1*1000
39066       KKKC1=ISTHKK(NC1)
39067       NNNC2=IDHKK(NC2)/1000
39068       MMMC2=IDHKK(NC2)-NNNC2*1000
39069       KKKC2=ISTHKK(NC2)
39070       IREJ=0
39071       IF(IPIP.EQ.3)THEN
39072       WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
39073      *             ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
39074      *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
39075      *              IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
39076       ENDIF
39077 C
39078 C
39079 C
39080 C     determine x-values of NC1P diquark
39081       XDIQP=PHKK(4,NC1P)*2.D0/UMO
39082       XVQT=PHKK(4,NC1T)*2.D0/UMO
39083 C
39084 C     determine x-values of sea quark pair
39085 C
39086       IPCO=1
39087       ICOU=0
39088  2234 CONTINUE
39089       ICOU=ICOU+1
39090       IF(ICOU.GE.500)THEN
39091         IREJ=1
39092         IF(ISQ.EQ.3)IREJ=3
39093         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
39094       IPCO=0
39095         RETURN
39096       ENDIF
39097       IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call  XSEAPA: UMO,XDIQP,XVQT ',
39098      * UMO, XDIQP,XVQT
39099       XSQ=0.D0
39100       XSAQ=0.D0
39101 **NEW
39102 C     CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
39103       IF (IPIP.EQ.1) THEN
39104          XQMAX  = XDIQP/2.0D0
39105          XAQMAX = 2.D0*XVQT/3.0D0
39106       ELSE
39107          XQMAX  = 2.D0*XVQT/3.0D0
39108          XAQMAX = XDIQP/2.0D0
39109       ENDIF
39110       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
39111       ISAQ = 6+ISQ
39112 C     write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
39113 **
39114         IF(IPCO.GE.3)
39115      &     WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
39116       IF(IREJ.GE.1)THEN
39117         IF(IPCO.GE.3)
39118      &     WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
39119       IPCO=0
39120         RETURN
39121       ENDIF
39122       IF(IPIP.EQ.1)THEN
39123         IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
39124       ELSEIF(IPIP.EQ.2)THEN
39125         IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
39126       ENDIF
39127       IF(IPCO.GE.3)THEN
39128         WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
39129      *  XDIQP,XVQT,XSQ,XSAQ
39130       ENDIF
39131 C
39132 C     subtract xsq,xsaq from NC1P diquark and NC1T quark
39133 C
39134 C     XSQ=0.D0
39135       IF(IPIP.EQ.1)THEN
39136         XDIQP=XDIQP-XSQ
39137 **NEW
39138 C       IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
39139 **
39140         XVQT =XVQT -XSAQ
39141       ELSEIF(IPIP.EQ.2)THEN
39142         XDIQP=XDIQP-XSAQ
39143         XVQT =XVQT -XSQ
39144       ENDIF
39145       IF(IPCO.GE.3)
39146      &   WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
39147 C
39148 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
39149 C
39150       XVTHRO=CVQ/UMO
39151       IVTHR=0
39152  3466 CONTINUE
39153       IF(IVTHR.EQ.10)THEN
39154         IREJ=1
39155         IF(ISQ.EQ.3)IREJ=3
39156         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
39157       IPCO=0
39158         RETURN
39159       ENDIF
39160       IVTHR=IVTHR+1
39161       XVTHR=XVTHRO/(201-IVTHR)
39162       UNOPRV=UNON
39163  380  CONTINUE
39164       IF(XVTHR.GT.0.66D0*XDIQP)THEN
39165         IREJ=1
39166         IF(ISQ.EQ.3)IREJ=3
39167         IF(IPCO.GE.3)
39168      &     WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR  large ',
39169      *  XVTHR
39170       IPCO=0
39171         RETURN
39172       ENDIF
39173       IF(DT_RNDM(V).LT.0.5D0)THEN
39174         XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
39175         XVPQII=XDIQP-XVPQI
39176       ELSE
39177         XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
39178         XVPQI=XDIQP-XVPQII
39179       ENDIF
39180       IF(IPCO.GE.3)THEN
39181         WRITE(LOUT,'(A,4E12.4)')'  MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
39182      *  XVTHR,XDIQP,XVPQI,XVPQII
39183       ENDIF
39184 C
39185 C     Prepare 4 momenta of new chains and chain ends
39186 C
39187 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39188 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39189 C    +(4,NTMHKK)
39190 C     Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
39191 C                   6 valence quark(vq2P 4)-sea-quark(aqsP 5)
39192 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
39193       IF(IPIP.EQ.1)THEN
39194         XSQ1=XSQ
39195         XSAQ1=XSAQ
39196         ISQ1=ISQ
39197         ISAQ1=ISAQ
39198       ELSEIF(IPIP.EQ.2)THEN
39199         XSQ1=XSAQ
39200         XSAQ1=XSQ
39201         ISQ1=ISAQ
39202         ISAQ1=ISQ
39203       ENDIF
39204       KK11=IP11
39205 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
39206       KK21= IPP21
39207       KK22= IPP22
39208       XGIVE=0.D0
39209       IDHKT(4+IIGLU1)   =IP12
39210       ISTHKT(4+IIGLU1)  =921
39211       JMOHKT(1,4+IIGLU1)=NC1P
39212       JMOHKT(2,4+IIGLU1)=0
39213       JDAHKT(1,4+IIGLU1)=6+IIGLU1
39214       JDAHKT(2,4+IIGLU1)=0
39215 **NEW
39216       IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
39217      &    (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
39218 **
39219       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
39220       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
39221       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
39222       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
39223 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
39224       XXMIST=(PHKT(4,4+IIGLU1)**2-
39225      *              PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
39226      *              PHKT(1,4+IIGLU1)**2)
39227       IF(XXMIST.GT.0.D0)THEN
39228         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
39229       ELSE
39230         WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
39231         XXMIST=ABS(XXMIST)
39232         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
39233       ENDIF
39234       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
39235       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
39236       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
39237       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
39238       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
39239       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
39240       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
39241       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
39242       IF(IPIP.EQ.1)THEN
39243         IDHKT(5+IIGLU1)   =-(ISAQ1-6)
39244       ELSEIF(IPIP.EQ.2)THEN
39245         IDHKT(5+IIGLU1)   =ISAQ1
39246       ENDIF
39247       ISTHKT(5+IIGLU1)  =922
39248       JMOHKT(1,5+IIGLU1)=NC1T
39249       JMOHKT(2,5+IIGLU1)=0
39250       JDAHKT(1,5+IIGLU1)=6+IIGLU1
39251       JDAHKT(2,5+IIGLU1)=0
39252 **NEW
39253       IF ((XSAQ1.LT.0.0D0).OR.(XVQT  .LT.0.0D0))
39254      &    WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
39255 **
39256       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
39257       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
39258       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
39259       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
39260 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
39261       XMIST=(PHKT(4,5+IIGLU1)**2-
39262      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
39263      *PHKT(1,5+IIGLU1)**2)
39264       IF(XMIST.GT.0.D0)THEN
39265       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
39266      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
39267      *PHKT(1,5+IIGLU1)**2)
39268       ELSE
39269 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
39270         PHKT(5,5+IIGLU1)=0.D0
39271       ENDIF
39272       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
39273       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
39274       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
39275       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
39276       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
39277       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
39278       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
39279       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
39280       IDHKT(6+IIGLU1)   =88888
39281 C     IDHKT(6)   =1000*NNNC1+MMMC1
39282       ISTHKT(6+IIGLU1)  =93
39283 C     ISTHKT(6)  =KKKC1
39284       JMOHKT(1,6+IIGLU1)=4+IIGLU1
39285       JMOHKT(2,6+IIGLU1)=5+IIGLU1
39286       JDAHKT(1,6+IIGLU1)=0
39287       JDAHKT(2,6+IIGLU1)=0
39288       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
39289       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
39290       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
39291       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
39292       PHKT(5,6+IIGLU1)
39293      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
39294      *            -PHKT(3,6+IIGLU1)**2)
39295       CHAMAL=CHAM1
39296       IF(IPIP.EQ.1)THEN
39297         IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
39298       ELSEIF(IPIP.EQ.2)THEN
39299         IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
39300       ENDIF
39301       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
39302         IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
39303 C                    we drop chain 6 and give the energy to chain 3
39304           IDHKT(6+IIGLU1)=33888
39305           XGIVE=1.D0
39306 C         WRITE(6,*)' drop chain 6 xgive=1'
39307           GO TO 7788
39308         ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
39309 C                    we drop chain 6 and give the energy to chain 3
39310 C                    and change KK11 to IDHKT(4)
39311           IDHKT(6+IIGLU1)=33888
39312           XGIVE=1.D0
39313 C         WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
39314           KK11=IDHKT(4+IIGLU1)
39315           GO TO 7788
39316         ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
39317 C                    we drop chain 6 and give the energy to chain 3
39318 C                    and change KK21 to IDHKT(4)
39319 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
39320           IDHKT(6+IIGLU1)=33888
39321           XGIVE=1.D0
39322 C         WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
39323           KK21=IDHKT(4+IIGLU1)
39324           GO TO 7788
39325         ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
39326 C                    we drop chain 6 and give the energy to chain 3
39327 C                    and change KK22 to IDHKT(4)
39328 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
39329           IDHKT(6+IIGLU1)=33888
39330           XGIVE=1.D0
39331 C         WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
39332           KK22=IDHKT(4+IIGLU1)
39333           GO TO 7788
39334         ENDIF
39335 C       IREJ=1
39336         IPCO=0
39337 C       RETURN
39338 C       WRITE(6,*)' MGSQBS1 jump back from chain 6'
39339         GO TO 3466
39340       ENDIF
39341  7788 CONTINUE
39342       IF(IPIP.GE.3)THEN
39343       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
39344      * JMOHKT(1,4+IIGLU1),
39345      * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
39346      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
39347       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
39348      * JMOHKT(1,5+IIGLU1),
39349      * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
39350      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
39351       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
39352      * JMOHKT(1,6+IIGLU1),
39353      * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
39354      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
39355       ENDIF
39356       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
39357       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
39358       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
39359       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
39360       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
39361       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
39362       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
39363       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
39364 C     IDHKT(1)   =IP11
39365       IDHKT(1)   =KK11
39366       ISTHKT(1)  =921
39367       JMOHKT(1,1)=NC1P
39368       JMOHKT(2,1)=0
39369       JDAHKT(1,1)=3+IIGLU1
39370       JDAHKT(2,1)=0
39371       PHKT(1,1)  =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
39372 C    * +0.5D0*PHKK(1,NC2P)
39373      *+XGIVE*PHKT(1,4+IIGLU1)
39374       PHKT(2,1)  =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
39375 C    * +0.5D0*PHKK(2,NC2P)
39376      *+XGIVE*PHKT(2,4+IIGLU1)
39377       PHKT(3,1)  =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
39378 C    * +0.5D0*PHKK(3,NC2P)
39379      *+XGIVE*PHKT(3,4+IIGLU1)
39380       PHKT(4,1)  =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
39381 C    * +0.5D0*PHKK(4,NC2P)
39382      *+XGIVE*PHKT(4,4+IIGLU1)
39383 C     PHKT(5,1)  =PHKK(5,NC1P)
39384       XMIST  =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
39385      *PHKT(1,1)**2)
39386       IF(XMIST.GE.0.D0)THEN
39387       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
39388      *PHKT(1,1)**2)
39389       ELSE
39390 C      WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
39391        PHKT(5,1)=0.D0
39392       ENDIF
39393       VHKT(1,1)  =VHKK(1,NC1P)
39394       VHKT(2,1)  =VHKK(2,NC1P)
39395       VHKT(3,1)  =VHKK(3,NC1P)
39396       VHKT(4,1)  =VHKK(4,NC1P)
39397       WHKT(1,1)  =WHKK(1,NC1P)
39398       WHKT(2,1)  =WHKK(2,NC1P)
39399       WHKT(3,1)  =WHKK(3,NC1P)
39400       WHKT(4,1)  =WHKK(4,NC1P)
39401 C     Add here IIGLU1 gluons to this chaina
39402       PG1=0.D0
39403       PG2=0.D0
39404       PG3=0.D0
39405       PG4=0.D0
39406       IF(IIGLU1.GE.1)THEN
39407       JJG=NC1P
39408       DO 61 IIG=2,2+IIGLU1-1
39409         KKG=JJG+IIG-1
39410         IDHKT(IIG)   =IDHKK(KKG)
39411         ISTHKT(IIG)  =921
39412         JMOHKT(1,IIG)=KKG
39413         JMOHKT(2,IIG)=0
39414         JDAHKT(1,IIG)=3+IIGLU1
39415         JDAHKT(2,IIG)=0
39416         PHKT(1,IIG)=PHKK(1,KKG)
39417         PG1=PG1+ PHKT(1,IIG)
39418         PHKT(2,IIG)=PHKK(2,KKG)
39419         PG2=PG2+ PHKT(2,IIG)
39420         PHKT(3,IIG)=PHKK(3,KKG)
39421         PG3=PG3+ PHKT(3,IIG)
39422         PHKT(4,IIG)=PHKK(4,KKG)
39423         PG4=PG4+ PHKT(4,IIG)
39424         PHKT(5,IIG)=PHKK(5,KKG)
39425         VHKT(1,IIG)  =VHKK(1,KKG)
39426         VHKT(2,IIG)  =VHKK(2,KKG)
39427         VHKT(3,IIG)  =VHKK(3,KKG)
39428         VHKT(4,IIG)  =VHKK(4,KKG)
39429         WHKT(1,IIG)  =WHKK(1,KKG)
39430         WHKT(2,IIG)  =WHKK(2,KKG)
39431         WHKT(3,IIG)  =WHKK(3,KKG)
39432         WHKT(4,IIG)  =WHKK(4,KKG)
39433    61 CONTINUE
39434       ENDIF
39435 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
39436       IF(IPIP.EQ.1)THEN
39437         IDHKT(2+IIGLU1)   =1000*KK21+100*KK22+3
39438         IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103
39439         IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103
39440         IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203
39441       ELSEIF(IPIP.EQ.2)THEN
39442         IDHKT(2+IIGLU1)   =1000*KK21+100*KK22-3
39443         IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103
39444         IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103
39445         IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203
39446       ENDIF
39447       ISTHKT(2+IIGLU1)  =922
39448       JMOHKT(1,2+IIGLU1)=NC2T
39449       JMOHKT(2,2+IIGLU1)=0
39450       JDAHKT(1,2+IIGLU1)=3+IIGLU1
39451       JDAHKT(2,2+IIGLU1)=0
39452       PHKT(1,2+IIGLU1)  =PHKK(1,NC2T)
39453      *+XGIVE*PHKT(1,5+IIGLU1)
39454       PHKT(2,2+IIGLU1)  =PHKK(2,NC2T)
39455      *+XGIVE*PHKT(2,5+IIGLU1)
39456       PHKT(3,2+IIGLU1)  =PHKK(3,NC2T)
39457      *+XGIVE*PHKT(3,5+IIGLU1)
39458       PHKT(4,2+IIGLU1)  =PHKK(4,NC2T)
39459      *+XGIVE*PHKT(4,5+IIGLU1)
39460 C     PHKT(5,2)  =PHKK(5,NC2T)
39461       XMIST=(PHKT(4,2+IIGLU1)**2-
39462      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
39463      *PHKT(1,2+IIGLU1)**2)
39464       IF(XMIST.GT.0.D0)THEN
39465       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
39466      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
39467      *PHKT(1,2+IIGLU1)**2)
39468       ELSE
39469 C     WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
39470       PHKT(5,2+IIGLU1)=0.D0
39471       ENDIF
39472       VHKT(1,2+IIGLU1)  =VHKK(1,NC2T)
39473       VHKT(2,2+IIGLU1)  =VHKK(2,NC2T)
39474       VHKT(3,2+IIGLU1)  =VHKK(3,NC2T)
39475       VHKT(4,2+IIGLU1)  =VHKK(4,NC2T)
39476       WHKT(1,2+IIGLU1)  =WHKK(1,NC2T)
39477       WHKT(2,2+IIGLU1)  =WHKK(2,NC2T)
39478       WHKT(3,2+IIGLU1)  =WHKK(3,NC2T)
39479       WHKT(4,2+IIGLU1)  =WHKK(4,NC2T)
39480       IDHKT(3+IIGLU1)   =88888
39481 C     IDHKT(3)   =1000*NNNC1+MMMC1+10
39482       ISTHKT(3+IIGLU1)  =93
39483 C     ISTHKT(3)  =KKKC1
39484       JMOHKT(1,3+IIGLU1)=1
39485       JMOHKT(2,3+IIGLU1)=2+IIGLU1
39486       JDAHKT(1,3+IIGLU1)=0
39487       JDAHKT(2,3+IIGLU1)=0
39488       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
39489       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
39490       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
39491       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
39492       PHKT(5,3+IIGLU1)
39493      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
39494      *            -PHKT(3,3+IIGLU1)**2)
39495       IF(IPIP.GE.3)THEN
39496       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
39497      * JDAHKT(1,1),
39498      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
39499       DO 71 IIG=2,2+IIGLU1-1
39500       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
39501      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
39502      * JDAHKT(1,IIG),
39503      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
39504    71 CONTINUE
39505       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
39506      &             IDHKT(2),JMOHKT(1,2+IIGLU1),
39507      * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
39508      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
39509       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
39510      * JMOHKT(1,3+IIGLU1),
39511      * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
39512      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
39513       ENDIF
39514       CHAMAL=CHAB1
39515 **NEW
39516 C     IF(IPIP.EQ.1)THEN
39517 C       IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
39518 C     ELSEIF(IPIP.EQ.2)THEN
39519 C       IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
39520 C     ENDIF
39521       IF(IPIP.EQ.1)THEN
39522         IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
39523       ELSEIF(IPIP.EQ.2)THEN
39524         IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
39525       ENDIF
39526 **
39527       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
39528 C       IREJ=1
39529         IPCO=0
39530 C       RETURN
39531 C       WRITE(6,*)' MGSQBS1 jump back from chain 3'
39532         GO TO 3466
39533       ENDIF
39534       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
39535       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
39536       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
39537       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
39538       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
39539       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
39540       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
39541       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
39542       IF(IPIP.EQ.1)THEN
39543         IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ1+3
39544         IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
39545         IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
39546         IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
39547       ELSEIF(IPIP.EQ.2)THEN
39548         IDHKT(7+IIGLU1)   =1000*IPP1+100*(-ISQ1+6)-3
39549         IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
39550         IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
39551         IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
39552 C       WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
39553       ENDIF
39554       ISTHKT(7+IIGLU1)  =921
39555       JMOHKT(1,7+IIGLU1)=NC2P
39556       JMOHKT(2,7+IIGLU1)=0
39557       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
39558       JDAHKT(2,7+IIGLU1)=0
39559 C     PHKT(1,7)  =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
39560 C     PHKT(2,7)  =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
39561 C     PHKT(3,7)  =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
39562 C     PHKT(4,7+IIGLU1)  =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
39563 **NEW
39564       IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
39565      &    WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
39566 **
39567       PHKT(1,7+IIGLU1)  =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
39568       PHKT(2,7+IIGLU1)  =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
39569       PHKT(3,7+IIGLU1)  =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
39570       PHKT(4,7+IIGLU1)  =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
39571 C     WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
39572 C    * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
39573       IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
39574 C       IREJ=1
39575 C       WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
39576         IPCO=0
39577 C       RETURN
39578         GO TO 3466
39579       ENDIF
39580 C     PHKT(5,7)  =PHKK(5,NC2P)
39581       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
39582      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
39583      *PHKT(1,7+IIGLU1)**2)
39584       VHKT(1,7+IIGLU1)  =VHKK(1,NC2P)
39585       VHKT(2,7+IIGLU1)  =VHKK(2,NC2P)
39586       VHKT(3,7+IIGLU1)  =VHKK(3,NC2P)
39587       VHKT(4,7+IIGLU1)  =VHKK(4,NC2P)
39588       WHKT(1,7+IIGLU1)  =WHKK(1,NC2P)
39589       WHKT(2,7+IIGLU1)  =WHKK(2,NC2P)
39590       WHKT(3,7+IIGLU1)  =WHKK(3,NC2P)
39591       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
39592 C     Insert here the IIGLU2 gluons
39593       PG1=0.D0
39594       PG2=0.D0
39595       PG3=0.D0
39596       PG4=0.D0
39597       IF(IIGLU2.GE.1)THEN
39598       JJG=NC2P
39599       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
39600         KKG=JJG+IIG-7-IIGLU1
39601         IDHKT(IIG)   =IDHKK(KKG)
39602         ISTHKT(IIG)  =921
39603         JMOHKT(1,IIG)=KKG
39604         JMOHKT(2,IIG)=0
39605         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
39606         JDAHKT(2,IIG)=0
39607         PHKT(1,IIG)=PHKK(1,KKG)
39608         PG1=PG1+ PHKT(1,IIG)
39609         PHKT(2,IIG)=PHKK(2,KKG)
39610         PG2=PG2+ PHKT(2,IIG)
39611         PHKT(3,IIG)=PHKK(3,KKG)
39612         PG3=PG3+ PHKT(3,IIG)
39613         PHKT(4,IIG)=PHKK(4,KKG)
39614         PG4=PG4+ PHKT(4,IIG)
39615         PHKT(5,IIG)=PHKK(5,KKG)
39616         VHKT(1,IIG)  =VHKK(1,KKG)
39617         VHKT(2,IIG)  =VHKK(2,KKG)
39618         VHKT(3,IIG)  =VHKK(3,KKG)
39619         VHKT(4,IIG)  =VHKK(4,KKG)
39620         WHKT(1,IIG)  =WHKK(1,KKG)
39621         WHKT(2,IIG)  =WHKK(2,KKG)
39622         WHKT(3,IIG)  =WHKK(3,KKG)
39623         WHKT(4,IIG)  =WHKK(4,KKG)
39624    81 CONTINUE
39625       ENDIF
39626       IDHKT(8+IIGLU1+IIGLU2)   =IP2
39627       ISTHKT(8+IIGLU1+IIGLU2)  =922
39628       JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
39629       JMOHKT(2,8+IIGLU1+IIGLU2)=0
39630       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
39631       JDAHKT(2,8+IIGLU1+IIGLU2)=0
39632 **NEW
39633       IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
39634      &    WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
39635 **
39636       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
39637       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
39638       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
39639       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
39640 C     PHKT(5,8+IIGLU1+IIGLU2)  =PHKK(5,NC1T)
39641       XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
39642      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
39643      *PHKT(1,8+IIGLU1+IIGLU2)**2)
39644       IF(XMIST.GT.0.D0)THEN
39645       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
39646      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
39647      *PHKT(1,8+IIGLU1+IIGLU2)**2)
39648       ELSE
39649 C     WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
39650       PHKT(5,8+IIGLU1+IIGLU2)=0.D0
39651       ENDIF
39652       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC1T)
39653       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC1T)
39654       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC1T)
39655       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC1T)
39656       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC1T)
39657       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC1T)
39658       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC1T)
39659       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC1T)
39660       IDHKT(9+IIGLU1+IIGLU2)   =88888
39661 C     IDHKT(9)   =1000*NNNC2+MMMC2+10
39662       ISTHKT(9+IIGLU1+IIGLU2)  =93
39663 C     ISTHKT(9)  =KKKC2
39664       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
39665       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
39666       JDAHKT(1,9+IIGLU1+IIGLU2)=0
39667       JDAHKT(2,9+IIGLU1+IIGLU2)=0
39668       PHKT(1,9+IIGLU1+IIGLU2)  =PHKT(1,7+IIGLU1)
39669      * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
39670       PHKT(2,9+IIGLU1+IIGLU2)  =PHKT(2,7+IIGLU1)
39671      * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
39672       PHKT(3,9+IIGLU1+IIGLU2)  =PHKT(3,7+IIGLU1)
39673      * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
39674       PHKT(4,9+IIGLU1+IIGLU2)  =PHKT(4,7+IIGLU1)
39675      * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
39676       PHKT(5,9+IIGLU1+IIGLU2)
39677      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
39678      * PHKT(2,9+IIGLU1+IIGLU2)**2
39679      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
39680       IF(IPIP.GE.3)THEN
39681       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
39682      * JMOHKT(1,7+IIGLU1),
39683      * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
39684      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
39685       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
39686       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
39687      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
39688      * JDAHKT(1,IIG),
39689      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
39690    91 CONTINUE
39691       WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
39692      * IDHKT(8+IIGLU1+IIGLU2),
39693      * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
39694      * JDAHKT(1,8+IIGLU1+IIGLU2),
39695      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
39696       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
39697      * IDHKT(9+IIGLU1+IIGLU2),
39698      * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
39699      * JDAHKT(1,9+IIGLU1+IIGLU2),
39700      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
39701       ENDIF
39702       CHAMAL=CHAB1
39703       IF(IPIP.EQ.1)THEN
39704         IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
39705       ELSEIF(IPIP.EQ.2)THEN
39706         IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
39707       ENDIF
39708       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
39709 C       IREJ=1
39710         IPCO=0
39711 C       RETURN
39712 C       WRITE(6,*)' MGSQBS1 jump back from chain 9',
39713 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
39714         GO TO 3466
39715       ENDIF
39716       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
39717       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
39718       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
39719       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
39720       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
39721       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
39722       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
39723       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
39724 C
39725       IGCOUN=9+IIGLU1+IIGLU2
39726       IPCO=0
39727        RETURN
39728        END
39729
39730 *$ CREATE HKKHKT.FOR
39731 *COPY HKKHKT
39732 C
39733 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
39734 C
39735       SUBROUTINE HKKHKT(I,J)
39736       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39737       SAVE
39738
39739 * event history
39740       PARAMETER (NMXHKK=200000)
39741       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39742      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39743      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39744 * extended event history
39745       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39746      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39747      &                IHIST(2,NMXHKK)
39748
39749       PARAMETER (NTMHKK= 300)
39750       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39751      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39752      +(4,NTMHKK)
39753 C
39754       ISTHKK(I)  =ISTHKT(J)
39755       IDHKK(I)   =IDHKT(J)
39756 C     IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
39757       IF(IDHKK(I).EQ.88888)THEN
39758 C       JMOHKK(1,I)=I-2
39759 C       JMOHKK(2,I)=I-1
39760         JMOHKK(1,I)=I-(J-JMOHKT(1,J))
39761         JMOHKK(2,I)=I-(J-JMOHKT(2,J))
39762       ELSE
39763         JMOHKK(1,I)=JMOHKT(1,J)
39764         JMOHKK(2,I)=JMOHKT(2,J)
39765       ENDIF
39766       JDAHKK(1,I)=JDAHKT(1,J)
39767       JDAHKK(2,I)=JDAHKT(2,J)
39768 C       IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
39769 C       JDAHKK(1,I)=I+2
39770 C     ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
39771 C       JDAHKK(1,I)=I+1
39772 C     ENDIF
39773       IF(JDAHKT(1,J).GT.0)THEN
39774         JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
39775       ENDIF
39776       PHKK(1,I)  =PHKT(1,J)
39777       PHKK(2,I)  =PHKT(2,J)
39778       PHKK(3,I)  =PHKT(3,J)
39779       PHKK(4,I)  =PHKT(4,J)
39780       PHKK(5,I)  =PHKT(5,J)
39781       VHKK(1,I)  =VHKT(1,J)
39782       VHKK(2,I)  =VHKT(2,J)
39783       VHKK(3,I)  =VHKT(3,J)
39784       VHKK(4,I)  =VHKT(4,J)
39785       WHKK(1,I)  =WHKT(1,J)
39786       WHKK(2,I)  =WHKT(2,J)
39787       WHKK(3,I)  =WHKT(3,J)
39788       WHKK(4,I)  =WHKT(4,J)
39789       RETURN
39790       END
39791
39792 *$ CREATE DT_DBREAK.FOR
39793 *COPY DT_DBREAK
39794 *
39795 *===dbreak=============================================================*
39796 *
39797       SUBROUTINE DT_DBREAK(MODE)
39798
39799 ************************************************************************
39800 * This is the steering subroutine for the different diquark breaking   *
39801 * mechanisms.                                                          *
39802 *                                                                      *
39803 * MODE = 1  breaking of projectile diquark in qq-q chain using         *
39804 *           a sea quark (q-qq chain) of the same projectile            *
39805 *      = 2  breaking of target     diquark in q-qq chain using         *
39806 *           a sea quark (qq-q chain) of the same target                *
39807 *      = 3  breaking of projectile diquark in qq-q chain using         *
39808 *           a sea quark (q-aq chain) of the same projectile            *
39809 *      = 4  breaking of target     diquark in q-qq chain using         *
39810 *           a sea quark (aq-q chain) of the same target                *
39811 *      = 5  breaking of projectile anti-diquark in aqaq-aq chain using *
39812 *           a sea anti-quark (aq-aqaq chain) of the same projectile    *
39813 *      = 6  breaking of target     anti-diquark in aq-aqaq chain using *
39814 *           a sea anti-quark (aqaq-aq chain) of the same target        *
39815 *      = 7  breaking of projectile anti-diquark in aqaq-aq chain using *
39816 *           a sea anti-quark (aq-q chain) of the same projectile       *
39817 *      = 8  breaking of target     anti-diquark in aq-aqaq chain using *
39818 *           a sea anti-quark (q-aq chain) of the same target           *
39819 *                                                                      *
39820 * Original version by J. Ranft.                                        *
39821 * This version dated 17.5.00  is written by S. Roesler.                *
39822 ************************************************************************
39823
39824       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39825       SAVE
39826       PARAMETER ( LINP = 10 ,
39827      &            LOUT = 6 ,
39828      &            LDAT = 9 )
39829
39830 * event history
39831       PARAMETER (NMXHKK=200000)
39832       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39833      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39834      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39835 * extended event history
39836       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39837      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39838      &                IHIST(2,NMXHKK)
39839 * flags for input different options
39840       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
39841       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
39842      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
39843 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
39844       PARAMETER (MAXCHN=10000)
39845       COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
39846 * diquark-breaking mechanism
39847       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
39848 * flags for particle decays
39849       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
39850      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
39851      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
39852
39853 *
39854 * chain identifiers
39855 * ( 1 = q-aq,   2 = aq-q,   3 = q-qq,   4 = qq-q,
39856 *   5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
39857       DIMENSION IDCHN1(8),IDCHN2(8)
39858       DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
39859       DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
39860 *
39861 * parton identifiers
39862 * ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
39863 *   +-51/52 = unitarity-sea, +-61/62 = gluons )
39864       DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
39865       DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
39866      &             31, 31, 31, 31, 31, 31, 31, 31,
39867      &             41, 41, 41, 41, 51, 51, 51, 51/
39868       DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
39869      &             32, 32, 32, 32, 32, 32, 32, 32,
39870      &             42, 42, 42, 42, 52, 52, 52, 52/
39871       DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
39872      &             51, 31, 41, 41, 31, 31, 31, 31,
39873      &              0, 41, 51, 51, 51, 51, 51, 51/
39874       DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
39875      &             32, 52, 42, 42, 32, 32, 32, 32,
39876      &             42,  0, 52, 52, 52, 52, 52, 52/
39877
39878       IF (NCHAIN.LE.0) RETURN
39879       DO 1 I=1,NCHAIN
39880          IDX1 = IDXCHN(1,I)
39881          IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
39882          IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
39883          IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
39884      &       .AND.
39885      &        ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
39886      &                                    (IS1P.EQ.ISP1P(MODE,3)))
39887      &       .AND.
39888      &        ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
39889      &                                    (IS1T.EQ.ISP1T(MODE,3)))
39890      &      ) THEN
39891             DO 2 J=1,NCHAIN
39892                IDX2 = IDXCHN(1,J)
39893                IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
39894                IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
39895                IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
39896      &             .AND.
39897      &              ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
39898      &                                      .OR.(IS2P.EQ.ISP2P(MODE,3)))
39899      &             .AND.
39900      &              ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
39901      &                                      .OR.(IS2T.EQ.ISP2T(MODE,3)))
39902      &            ) THEN
39903 *   find mother nucleons of the diquark to be splitted and of the
39904 *   sea-quark and reject this combination if it is not the same
39905                   IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
39906      &                (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
39907                      IANCES = 1
39908                   ELSE
39909                      IANCES = 2
39910                   ENDIF
39911                   IDXMO1 = JMOHKK(IANCES,IDX1)
39912     4             CONTINUE
39913                   IF ((JMOHKK(1,IDXMO1).NE.0).AND.
39914      &                (JMOHKK(2,IDXMO1).NE.0)) THEN
39915                      IANC = IANCES
39916                   ELSE
39917                      IANC = 1
39918                   ENDIF
39919                   IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
39920                      IDXMO1 = JMOHKK(IANC,IDXMO1)
39921                      GOTO 4
39922                   ENDIF
39923                   IDXMO2 = JMOHKK(IANCES,IDX2)
39924     5             CONTINUE
39925                   IF ((JMOHKK(1,IDXMO2).NE.0).AND.
39926      &                (JMOHKK(2,IDXMO2).NE.0)) THEN
39927                      IANC = IANCES
39928                   ELSE
39929                      IANC = 1
39930                   ENDIF
39931                   IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
39932                      IDXMO2 = JMOHKK(IANC,IDXMO2)
39933                      GOTO 5
39934                   ENDIF
39935                   IF (IDXMO1.NE.IDXMO2) GOTO 2
39936 *   quark content of projectile parton
39937                   IP1   = IDHKK(JMOHKK(1,IDX1))
39938                   IP11  = IP1/1000
39939                   IP12  = (IP1-1000*IP11)/100
39940                   IP2   = IDHKK(JMOHKK(2,IDX1))
39941                   IP21  = IP2/1000
39942                   IP22  = (IP2-1000*IP21)/100
39943 *   quark content of target parton
39944                   IT1  = IDHKK(JMOHKK(1,IDX2))
39945                   IT11 = IT1/1000
39946                   IT12 = (IT1-1000*IT11)/100
39947                   IT2  = IDHKK(JMOHKK(2,IDX2))
39948                   IT21 = IT2/1000
39949                   IT22 = (IT2-1000*IT21)/100
39950 *   split diquark and form new chains
39951                   IF (MODE.EQ.1) THEN
39952                      IF (IT1.EQ.4) GOTO 2
39953                      CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39954      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39955      &                         IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
39956                   ELSEIF (MODE.EQ.2) THEN
39957                      IF (IT2.EQ.4) GOTO 2
39958                      CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39959      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39960      &                         IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
39961                   ELSEIF (MODE.EQ.3) THEN
39962                      IF (IT1.EQ.4) GOTO 2
39963                      CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39964      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39965      &                         IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
39966                   ELSEIF (MODE.EQ.4) THEN
39967                      IF (IT2.EQ.4) GOTO 2
39968                      CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39969      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39970      &                         IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
39971                   ELSEIF (MODE.EQ.5) THEN
39972                      CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39973      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39974      &                         IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
39975                   ELSEIF (MODE.EQ.6) THEN
39976                      CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39977      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39978      &                         IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN)
39979                   ELSEIF (MODE.EQ.7) THEN
39980                      CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39981      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39982      &                         IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
39983                   ELSEIF (MODE.EQ.8) THEN
39984                      CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39985      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39986      &                         IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
39987                   ENDIF
39988                   IF (IREJ.GE.1) THEN
39989                      if ((ipq.lt.0).or.(ipq.ge.4))
39990      &                  write(LOUT,*) 'ipq !!!',ipq,mode
39991                      DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
39992 *   accept or reject new chains corresponding to PDBSEA
39993                   ELSE
39994                      IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
39995                         ACC   = DBRKA(1,MODE)+DBRKA(2,MODE)
39996                         REJ   = DBRKR(1,MODE)+DBRKR(2,MODE)
39997                      ELSEIF (IPQ.EQ.3) THEN
39998                         ACC   = DBRKA(3,MODE)
39999                         REJ   = DBRKR(3,MODE)
40000                      ELSE
40001                         WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
40002                         STOP
40003                      ENDIF
40004                      IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
40005                         DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
40006                         IACC = 1
40007                      ELSE
40008                         DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
40009                         IACC = 0
40010                      ENDIF
40011 *   new chains have been accepted and are now copied into HKKEVT
40012                      IF (IACC.EQ.1) THEN
40013                         IF (LEMCCK) THEN
40014                            CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
40015      &                                    PHKK(3,IDX1),PHKK(4,IDX1),
40016      &                                    1,IDUM1,IDUM2)
40017                            CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
40018      &                                    PHKK(3,IDX2),PHKK(4,IDX2),
40019      &                                    2,IDUM1,IDUM2)
40020                         ENDIF
40021                         IDHKK(IDX1) = 99888
40022                         IDHKK(IDX2) = 99888
40023                         IDXCHN(2,I) = -1
40024                         IDXCHN(2,J) = -1
40025                         DO 3 K=1,IGCOUN
40026                            NHKK = NHKK+1
40027                            CALL HKKHKT(NHKK,K)
40028                            IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
40029                               PX = -PHKK(1,NHKK)
40030                               PY = -PHKK(2,NHKK)
40031                               PZ = -PHKK(3,NHKK)
40032                               PE = -PHKK(4,NHKK)
40033                               CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
40034                            ENDIF
40035     3                   CONTINUE
40036                         IF (LEMCCK) THEN
40037                            CHKLEV = 0.1D0
40038                            CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
40039      &                                                             IREJ)
40040                            IF (IREJ.NE.0) CALL DT_EVTOUT(4)
40041                         ENDIF
40042                         GOTO 1
40043                      ENDIF
40044                   ENDIF
40045                ENDIF
40046     2       CONTINUE
40047          ENDIF
40048     1 CONTINUE
40049       RETURN
40050       END
40051
40052 *$ CREATE DT_CQPAIR.FOR
40053 *COPY DT_CQPAIR
40054 *
40055 *===cqpair=============================================================*
40056 *
40057       SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
40058
40059 ************************************************************************
40060 * This subroutine Creates a Quark-antiquark PAIR from the sea.         *
40061 *                                                                      *
40062 *   XQMAX   maxium energy fraction of quark (input)                    *
40063 *   XAQMAX  maxium energy fraction of antiquark (input)                *
40064 *   XQ      energy fraction of quark (output)                          *
40065 *   XAQ     energy fraction of antiquark (output)                      *
40066 *   IFLV    quark flavour (- antiquark flavor) (output)                *
40067 *                                                                      *
40068 * This version dated 14.5.00  is written by S. Roesler.                *
40069 ************************************************************************
40070
40071       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
40072       SAVE
40073       PARAMETER ( LINP = 10 ,
40074      &            LOUT = 6 ,
40075      &            LDAT = 9 )
40076
40077 * Lorentz-parameters of the current interaction
40078       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
40079      &                UMO,PPCM,EPROJ,PPROJ
40080
40081 *
40082       IREJ = 0
40083       XQ   = 0.0D0
40084       XAQ  = 0.0D0
40085 *
40086 * sample quark flavour
40087 *
40088 *  set seasq here (the one from DTCHAI should be used in the future)
40089       SEASQ = 0.5D0
40090       IFLV  = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
40091 *
40092 * sample energy fractions of sea pair
40093 * we first sample the energy fraction of a gluon and then split the gluon
40094 *
40095 *  maximum energy fraction of the gluon forced via input
40096       XGMAXI = XQMAX+XAQMAX
40097 *  minimum energy fraction of the gluon
40098       XTHR1 = 4.0D0 /UMO**2
40099       XTHR2 = 0.54D0/UMO**1.5D0
40100       XGMIN = MAX(XTHR1,XTHR2)
40101 *  maximum energy fraction of the gluon
40102       XGMAX = 0.3D0
40103       XGMAX = MIN(XGMAXI,XGMAX)
40104       IF (XGMIN.GE.XGMAX) THEN
40105          IREJ = 1
40106          RETURN
40107       ENDIF
40108 *
40109 *  sample energy fraction of the gluon
40110       NLOOP = 0
40111     1 CONTINUE
40112       NLOOP = NLOOP+1
40113       IF (NLOOP.GE.50) THEN
40114          IREJ = 1
40115          RETURN
40116       ENDIF
40117       XGLUON = DT_SAMSQX(XGMIN,XGMAX)
40118       EGLUON = XGLUON*UMO/2.0D0
40119 *
40120 *  split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
40121       ZMIN = MIN(0.1D0,0.5D0/EGLUON)
40122       ZMAX = 1.0D0-ZMIN
40123       RZ   = DT_RNDM(ZMAX)
40124       XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
40125       RQ   = DT_RNDM(ZMAX)
40126       IF (RQ.LT.0.5D0) THEN
40127          XQ  = XGLUON*XHLP
40128          XAQ = XGLUON-XQ
40129       ELSE
40130          XAQ = XGLUON*XHLP
40131          XQ  = XGLUON-XAQ
40132       ENDIF
40133       IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1
40134
40135       RETURN
40136       END