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       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
2207      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
2208      &                NCP,NCT
2209
2210       DIMENSION WHAT(6)
2211
2212       IREJ  = 0
2213       ILOOP = 0
2214       NSD1  = 0
2215       NSD2  = 0
2216       NDD   = 0
2217   100 CONTINUE
2218       IF (ILOOP.EQ.4) THEN
2219          WRITE(LOUT,1000) NEVHKK
2220  1000    FORMAT(1X,'KKINC: event ',I8,' rejected!')
2221          GOTO 9999
2222       ENDIF
2223       ILOOP = ILOOP+1
2224
2225 * variable energy-runs, recalculate parameters for LT's
2226       IF ((ABS(VAREHI).GT.ZERO).OR.(IOGLB.EQ.100)) THEN
2227          PDUM = ZERO
2228          CDUM = ZERO
2229          CALL DT_LTINI(IDP,1,EPN,PDUM,CDUM,1)
2230       ENDIF
2231       IF (EPN.GT.EPROJ) THEN
2232          WRITE(LOUT,'(A,E9.3,2A,E9.3,A)')
2233      &      ' Requested energy (',EPN,'GeV) exceeds',
2234      &      ' initialization energy (',EPROJ,'GeV) !'
2235          STOP
2236       ENDIF
2237
2238 * re-initialize /DTPRTA/
2239       IP  = NPMASS
2240       IPZ = NPCHAR
2241       IT  = NTMASS
2242       ITZ = NTCHAR
2243       IJPROJ = IDP
2244       IBPROJ = IIBAR(IJPROJ)
2245
2246 * calculate nuclear potentials (common /DTNPOT/)
2247       CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
2248
2249 * initialize treatment for residual nuclei
2250       CALL DT_RESNCL(EPN,NLOOP,1)
2251
2252 * sample hadron/nucleus-nucleus interaction
2253       CALL DT_KKEVNT(KKMAT,IREJ1)
2254       IF (IREJ1.GT.0) THEN
2255          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKINC'
2256          GOTO 9999
2257       ENDIF
2258
2259       IF ((NPMASS.GT.1).OR.(NTMASS.GT.1)) THEN
2260
2261 * intranuclear cascade of final state particles for KTAUGE generations
2262 * of secondaries
2263          CALL DT_FOZOCA(LFZC,IREJ1)
2264          IF (IREJ1.GT.0) THEN
2265             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKINC'
2266             GOTO 9999
2267          ENDIF
2268
2269 * baryons unable to escape the nuclear potential are treated as
2270 * excited nucleons (ISTHKK=15,16)
2271          CALL DT_SCN4BA
2272
2273 * decay of resonances produced in intranuclear cascade processes
2274 **sr 15-11-95 should be obsolete
2275 C        IF (LFZC) CALL DT_DECAY1
2276
2277   101    CONTINUE
2278 * treatment of residual nuclei
2279          CALL DT_RESNCL(EPN,NLOOP,2)
2280
2281 * evaporation / fission / fragmentation
2282 * (if intranuclear cascade was sampled only)
2283          IF (LFZC) THEN
2284             CALL DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ1)
2285             IF (IREJ1.GT.1) GOTO 101
2286             IF (IREJ1.EQ.1) GOTO 100
2287          ENDIF
2288
2289       ENDIF
2290
2291 * rejection of unphysical configurations
2292       CALL DT_REJUCO(1,IREJ1)
2293       IF (IREJ1.GT.0) THEN
2294          IF (IOULEV(1).GT.0)
2295      &      WRITE(LOUT,*) 'rejected 3 in KKINC: too large x'
2296          GOTO 100
2297       ENDIF
2298
2299 * transform finale state into Lab.
2300       IFLAG = 2
2301       CALL DT_BEAMPR(WHAT,DUM,IFLAG)
2302       IF ((IFRAME.EQ.1).AND.(IFLAG.EQ.-1)) CALL DT_LT2LAB
2303
2304       IF (IPI0.EQ.1) CALL DT_DECPI0
2305
2306 C     IF (NEVHKK.EQ.5) CALL DT_EVTOUT(4)
2307       RETURN
2308
2309  9999 CONTINUE
2310       IREJ = 1
2311
2312       RETURN
2313       END
2314
2315 *$ CREATE DT_DEFAUL.FOR
2316 *COPY DT_DEFAUL
2317 *
2318 *===defaul=============================================================*
2319 *
2320       SUBROUTINE DT_DEFAUL(EPN,PPN)
2321
2322 ************************************************************************
2323 * Variables are set to default values.                                 *
2324 * This version dated 8.5.95 is written by S. Roesler.                  *
2325 ************************************************************************
2326
2327       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2328       SAVE
2329       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
2330       PARAMETER (TWOPI  = 6.283185307179586454D+00)
2331
2332 * particle properties (BAMJET index convention)
2333       CHARACTER*8  ANAME
2334       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2335      &                IICH(210),IIBAR(210),K1(210),K2(210)
2336 * nuclear potential
2337       LOGICAL LFERMI
2338       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
2339      &                EBINDP(2),EBINDN(2),EPOT(2,210),
2340      &                ETACOU(2),ICOUL,LFERMI
2341 * interface HADRIN-DPM
2342       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
2343 * central particle production, impact parameter biasing
2344       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
2345 * properties of interacting particles
2346       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2347 * properties of photon/lepton projectiles
2348       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2349       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2350 * emulsion treatment
2351       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2352      &                NCOMPO,IEMUL
2353 * parameter for intranuclear cascade
2354       LOGICAL LPAULI
2355       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
2356 * various options for treatment of partons (DTUNUC 1.x)
2357 * (chain recombination, Cronin,..)
2358       LOGICAL LCO2CR,LINTPT
2359       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
2360      &                LCO2CR,LINTPT
2361 * threshold values for x-sampling (DTUNUC 1.x)
2362       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
2363      &                SSMIMQ,VVMTHR
2364 * flags for input different options
2365       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2366       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2367      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2368 * n-n cross section fluctuations
2369       PARAMETER (NBINS = 1000)
2370       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
2371 * flags for particle decays
2372       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2373      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2374      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2375 * diquark-breaking mechanism
2376       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
2377 * nucleon-nucleon event-generator
2378       CHARACTER*8 CMODEL
2379       LOGICAL LPHOIN
2380       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2381 * flags for diffractive interactions (DTUNUC 1.x)
2382       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
2383 * VDM parameter for photon-nucleus interactions
2384       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
2385 * Glauber formalism: flags and parameters for statistics
2386       LOGICAL LPROD
2387       CHARACTER*8 CGLB
2388       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2389 * kinematical cuts for lepton-nucleus interactions
2390       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2391      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2392 * flags for activated histograms
2393       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2394 * cuts for variable energy runs
2395       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2396 * parameters for hA-diffraction
2397       COMMON /DTDIHA/ DIBETA,DIALPH
2398 * LEPTO
2399       REAL RPPN
2400       COMMON /LEPTOI/ RPPN,LEPIN,INTER
2401 * steering flags for qel neutrino scattering modules
2402       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
2403 * event flag
2404       COMMON /DTEVNO/ NEVENT,ICASCA
2405
2406       DATA POTMES /0.002D0/
2407
2408 * common /DTNPOT/
2409       DO 10 I=1,2
2410          PFERMP(I) = ZERO
2411          PFERMN(I) = ZERO
2412          EBINDP(I) = ZERO
2413          EBINDN(I) = ZERO
2414          DO 11 J=1,210
2415             EPOT(I,J) = ZERO
2416    11    CONTINUE
2417 * nucleus independent meson potential
2418          EPOT(I,13) = POTMES
2419          EPOT(I,14) = POTMES
2420          EPOT(I,15) = POTMES
2421          EPOT(I,16) = POTMES
2422          EPOT(I,23) = POTMES
2423          EPOT(I,24) = POTMES
2424          EPOT(I,25) = POTMES
2425    10 CONTINUE
2426       FERMOD    = 0.55D0
2427       ETACOU(1) = ZERO
2428       ETACOU(2) = ZERO
2429       ICOUL     = 1
2430       LFERMI    = .TRUE.
2431
2432 * common /HNTHRE/
2433       EHADTH = -99.0D0
2434       EHADLO = 4.06D0
2435       EHADHI = 6.0D0
2436       INTHAD = 1
2437       IDXTA  = 2
2438
2439 * common /DTIMPA/
2440       ICENTR = 0
2441       BIMIN  = ZERO
2442       BIMAX  = 1.0D10
2443       XSFRAC = 1.0D0
2444
2445 * common /DTPRTA/
2446       IP  = 1
2447       IPZ = 1
2448       IT  = 1
2449       ITZ = 1
2450       IJPROJ = 1
2451       IBPROJ = 1
2452       IJTARG = 1
2453       IBTARG = 1
2454 * common /DTGPRO/
2455       VIRT = ZERO
2456       DO 14 I=1,4
2457          PGAMM(I)  = ZERO
2458          PLEPT0(I) = ZERO
2459          PLEPT1(I) = ZERO
2460          PNUCL(I)  = ZERO
2461    14 CONTINUE
2462       IDIREC   = 0
2463
2464 * common /DTFOTI/
2465 **sr 7.4.98: changed after corrected B-sampling
2466 C     TAUFOR = 4.4D0
2467       TAUFOR = 3.5D0
2468       KTAUGE = 25
2469       ITAUVE = 1
2470       INCMOD = 1
2471       LPAULI = .TRUE.
2472
2473 * common /DTCHAI/
2474       SEASQ  = ONE
2475       MKCRON = 1
2476       CRONCO = 0.64D0
2477       ISICHA = 0
2478       CUTOF  = 100.0D0
2479       LCO2CR = .FALSE.
2480       IRECOM = 1
2481       LINTPT = .TRUE.
2482
2483 * common /DTXCUT/
2484 *  definition of soft quark distributions
2485       XSEACU = 0.05D0
2486       UNON   = 2.0D0
2487       UNOM   = 1.5D0
2488       UNOSEA = 5.0D0
2489 *  cutoff parameters for x-sampling
2490       CVQ    = 1.0D0
2491       CDQ    = 2.0D0
2492 C     CSEA   = 0.3D0
2493       CSEA   = 0.1D0
2494       SSMIMA = 1.2D0
2495       SSMIMQ = SSMIMA**2
2496       VVMTHR = 2.0D0
2497
2498 * common /DTXSFL/
2499       IFLUCT = 0
2500
2501 * common /DTFRPA/
2502       PDB = 0.15D0
2503       PDBSEA(1) = 0.0D0
2504       PDBSEA(2) = 0.0D0
2505       PDBSEA(3) = 0.0D0
2506       ISIG0 = 0
2507       IPI0  = 0
2508       NMSTU = 0
2509       NPARU = 0
2510       NMSTJ = 0
2511       NPARJ = 0
2512
2513 * common /DTDIQB/
2514       DO 15 I=1,8
2515          DBRKR(1,I) = 5.0D0
2516          DBRKR(2,I) = 5.0D0
2517          DBRKR(3,I) = 10.0D0
2518          DBRKA(1,I) = ZERO
2519          DBRKA(2,I) = ZERO
2520          DBRKA(3,I) = ZERO
2521    15 CONTINUE
2522       CHAM1 = 0.2D0
2523       CHAM3 = 0.5D0
2524       CHAB1 = 0.7D0
2525       CHAB3 = 1.0D0
2526
2527 * common /DTFLG3/
2528       ISINGD = 0
2529       IDOUBD = 0
2530       IFLAGD = 0
2531       IDIFF  = 0
2532
2533 * common /DTMODL/
2534       MCGENE    = 2
2535       CMODEL(1) = 'DTUNUC  '
2536       CMODEL(2) = 'PHOJET  '
2537       CMODEL(3) = 'LEPTO   '
2538       CMODEL(4) = 'QNEUTRIN'
2539       LPHOIN    = .TRUE.
2540       ELOJET    = 5.0D0
2541
2542 * common /DTLCUT/
2543       ECMIN  = 3.5D0
2544       ECMAX  = 1.0D10
2545       XBJMIN = ZERO
2546       ELMIN = ZERO
2547       EGMIN = ZERO
2548       EGMAX = 1.0D10
2549       YMIN  = TINY10
2550       YMAX  = 0.999D0
2551       Q2MIN = TINY10
2552       Q2MAX = 10.0D0
2553       THMIN = ZERO
2554       THMAX = TWOPI
2555       Q2LI  = ZERO
2556       Q2HI  = 1.0D10
2557       ECMLI = ZERO
2558       ECMHI = 1.0D10
2559
2560 * common /DTVDMP/
2561       RL2       = 2.0D0
2562       INTRGE(1) = 1
2563       INTRGE(2) = 3
2564       IDPDF     = 2212
2565       MODEGA    = 4
2566       ISHAD(1)  = 1
2567       ISHAD(2)  = 1
2568       ISHAD(3)  = 1
2569       EPSPOL    = ZERO
2570
2571 * common /DTGLGP/
2572       JSTATB = 1000
2573       JBINSB = 49
2574       CGLB   = '        '
2575       IF (ITRSPT.EQ.1) THEN
2576          IOGLB  = 100
2577       ELSE
2578          IOGLB  = 0
2579       ENDIF
2580       LPROD  = .TRUE.
2581
2582 * common /DTHIS3/
2583       DO 16 I=1,50
2584          IHISPP(I) = 0
2585          IHISXS(I) = 0
2586    16 CONTINUE
2587       IXSTBL = 0
2588
2589 * common /DTVARE/
2590       VARELO = ZERO
2591       VAREHI = ZERO
2592       VARCLO = ZERO
2593       VARCHI = ZERO
2594
2595 * common /DTDIHA/
2596       DIBETA = -1.0D0
2597       DIALPH = ZERO
2598
2599 * common /LEPTOI/
2600       RPPN  = 0.0
2601       LEPIN = 0
2602       INTER = 0
2603
2604 * common /QNEUTO/
2605       NEUTYP = 1
2606       NEUDEC = 0
2607
2608 * common /DTEVNO/
2609       NEVENT = 1
2610       IF (ITRSPT.EQ.1) THEN
2611          ICASCA = 1
2612       ELSE
2613          ICASCA = 0
2614       ENDIF
2615
2616 * default Lab.-energy
2617       EPN = 200.0D0
2618       PPN = SQRT((EPN-AAM(IJPROJ))*(EPN+AAM(IJPROJ)))
2619
2620       RETURN
2621       END
2622
2623 *$ CREATE DT_AAEVT.FOR
2624 *COPY DT_AAEVT
2625 *
2626 *===aaevt==============================================================*
2627 *
2628       SUBROUTINE DT_AAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2629      &                                             IDP,IGLAU)
2630
2631 ************************************************************************
2632 * This version dated 22.03.96 is written by S. Roesler.                *
2633 ************************************************************************
2634
2635       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2636       SAVE
2637       PARAMETER ( LINP = 10 ,
2638      &            LOUT = 6 ,
2639      &            LDAT = 9 )
2640
2641       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2642 * emulsion treatment
2643       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2644      &                NCOMPO,IEMUL
2645 * event flag
2646       COMMON /DTEVNO/ NEVENT,ICASCA
2647       CHARACTER*8 DATE,HHMMSS
2648       DIMENSION IDMNYR(3)
2649       NSD1 = 0
2650       NSD2 = 0
2651       NDD  = 0
2652       KKMAT  = 1
2653       NMSG   = MAX(NEVTS/100,1)
2654
2655 * initialization of run-statistics and histograms
2656       CALL DT_STATIS(1)
2657       CALL PHO_PHIST(1000,DUM)
2658
2659 * initialization of Glauber-formalism
2660       IF (NCOMPO.LE.0) THEN
2661          CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2662       ELSE
2663          DO 1 I=1,NCOMPO
2664             CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2665     1    CONTINUE
2666       ENDIF
2667       CALL DT_SIGEMU
2668
2669       CALL IDATE(IDMNYR)
2670       WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2671      &   IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2672       CALL ITIME(IDMNYR)
2673       WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2674      &   IDMNYR(1),IDMNYR(2),IDMNYR(3)
2675       WRITE(LOUT,1001) DATE,HHMMSS
2676  1001 FORMAT(/,' DT_AAEVT: Initialisation finished. ( Date: ',A8,
2677      &       '   Time: ',A8,' )')
2678
2679 * generate NEVTS events
2680       DO 2 IEVT=1,NEVTS
2681
2682 *  print run-status message
2683          IF (MOD(IEVT,NMSG).EQ.0) THEN
2684             CALL IDATE(IDMNYR)
2685             WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2686      &         IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2687             CALL ITIME(IDMNYR)
2688             WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2689      &         IDMNYR(1),IDMNYR(2),IDMNYR(3)
2690             WRITE(LOUT,1000) IEVT-1,NEVTS,DATE,HHMMSS
2691  1000       FORMAT(/,1X,I8,' out of ',I8,' events sampled ( Date: ',A,
2692      &             '   Time: ',A,' )',/)
2693 C           WRITE(LOUT,1000) IEVT-1
2694 C1000       FORMAT(1X,I8,' events sampled')
2695          ENDIF
2696          NEVENT = IEVT
2697 *  treat nuclear emulsions
2698          IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
2699 *  composite targets only
2700          KKMAT = -KKMAT
2701 *  sample this event
2702          CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,IREJ)
2703
2704          CALL PHO_PHIST(2000,DUM)
2705
2706          write(6,*) "Diffractive collisions", NSD1, NSD2, NDD
2707
2708     2 CONTINUE
2709
2710 * print run-statistics and histograms to output-unit 6
2711       CALL PHO_PHIST(3000,DUM)
2712       CALL DT_STATIS(2)
2713       RETURN
2714       END
2715
2716 *$ CREATE DT_LAEVT.FOR
2717 *COPY DT_LAEVT
2718 *
2719 *===laevt==============================================================*
2720 *
2721       SUBROUTINE DT_LAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2722      &                                             IDP,IGLAU)
2723
2724 ************************************************************************
2725 * Interface to run DPMJET for lepton-nucleus interactions.             *
2726 * Kinematics is sampled using the equivalent photon approximation      *
2727 * Based on GPHERA-routine by R. Engel.                                 *
2728 * This version dated 23.03.96 is written by S. Roesler.                *
2729 ************************************************************************
2730
2731       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2732       SAVE
2733       PARAMETER ( LINP = 10 ,
2734      &            LOUT = 6 ,
2735      &            LDAT = 9 )
2736       PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,
2737      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
2738       PARAMETER (TWOPI  = 6.283185307179586454D+00,
2739      &           PI     = TWOPI/TWO,
2740      &           ALPHEM = ONE/137.0D0)
2741
2742 C     CHARACTER*72 HEADER
2743
2744 * particle properties (BAMJET index convention)
2745       CHARACTER*8  ANAME
2746       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2747      &                IICH(210),IIBAR(210),K1(210),K2(210)
2748 * event history
2749       PARAMETER (NMXHKK=200000)
2750       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2751      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2752      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2753 * extended event history
2754       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2755      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2756      &                IHIST(2,NMXHKK)
2757 * kinematical cuts for lepton-nucleus interactions
2758       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2759      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2760 * properties of interacting particles
2761       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2762 * properties of photon/lepton projectiles
2763       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2764 * kinematics at lepton-gamma vertex
2765       COMMON /DTLGVX/ PPL0(4),PPL1(4),PPG(4),PPA(4)
2766 * flags for activated histograms
2767       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2768       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2769 * emulsion treatment
2770       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2771      &                NCOMPO,IEMUL
2772 * Glauber formalism: cross sections
2773       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
2774      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
2775      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
2776      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
2777      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
2778      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
2779      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
2780      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
2781      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
2782      &                BSLOPE,NEBINI,NQBINI
2783 * nucleon-nucleon event-generator
2784       CHARACTER*8 CMODEL
2785       LOGICAL LPHOIN
2786       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2787 * flags for input different options
2788       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2789       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2790      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2791 * event flag
2792       COMMON /DTEVNO/ NEVENT,ICASCA
2793
2794       DIMENSION XDUMB(40),BGTA(4)
2795
2796 * LEPTO
2797       IF (MCGENE.EQ.3) THEN
2798          STOP ' This version does not contain LEPTO !'
2799       ENDIF
2800
2801       KKMAT  = 1
2802       NMSG   = MAX(NEVTS/10,1)
2803
2804 * mass of incident lepton
2805       AMLPT  = AAM(IDP)
2806       AMLPT2 = AMLPT**2
2807       IDPPDG = IDT_IPDGHA(IDP)
2808
2809 * consistency of kinematical limits
2810       Q2MIN  = MAX(Q2MIN,TINY10)
2811       Q2MAX  = MAX(Q2MAX,TINY10)
2812       YMIN   = MIN(MAX(YMIN,TINY10),0.999D0)
2813       YMAX   = MIN(MAX(YMAX,TINY10),0.999D0)
2814
2815 * total energy of the lepton-nucleon system
2816       PTOTLN = SQRT( (PLEPT0(1)+PNUCL(1))**2+(PLEPT0(2)+PNUCL(2))**2
2817      &                                      +(PLEPT0(3)+PNUCL(3))**2 )
2818       ETOTLN = PLEPT0(4)+PNUCL(4)
2819       ECMLN  = SQRT((ETOTLN-PTOTLN)*(ETOTLN+PTOTLN))
2820       ECMAX  = MIN(ECMAX,ECMLN)
2821       WRITE(LOUT,1003) ECMIN,ECMAX,YMIN,YMAX,Q2MIN,Q2MAX,EGMIN,
2822      &                 THMIN,THMAX,ELMIN
2823  1003 FORMAT(1X,'LAEVT:',16X,'kinematical cuts',/,22X,
2824      &       '------------------',/,9X,'W (min)   =',
2825      &       F7.1,' GeV    (max) =',F7.1,' GeV',/,9X,'y (min)   =',
2826      &       F7.3,8X,'(max) =',F7.3,/,9X,'Q^2 (min) =',F7.1,
2827      &       ' GeV^2  (max) =',F7.1,' GeV^2',/,' (Lab)   E_g (min) ='
2828      &       ,F7.1,' GeV',/,' (Lab) theta (min) =',F7.4,8X,'(max) =',
2829      &       F7.4,'   for E_lpt >',F7.1,' GeV',/)
2830
2831 * Lorentz-parameter for transf. into Lab
2832       BGTA(1) = PNUCL(1)/AAM(1)
2833       BGTA(2) = PNUCL(2)/AAM(1)
2834       BGTA(3) = PNUCL(3)/AAM(1)
2835       BGTA(4) = PNUCL(4)/AAM(1)
2836 * LT of incident lepton into Lab and dump it in DTEVT1
2837       CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
2838      &            PLEPT0(1),PLEPT0(2),PLEPT0(3),PLEPT0(4),
2839      &            PLTOT,PPL0(1),PPL0(2),PPL0(3),PPL0(4))
2840       CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
2841      &            PNUCL(1),PNUCL(2),PNUCL(3),PNUCL(4),
2842      &            PLTOT,PPA(1),PPA(2),PPA(3),PPA(4))
2843 * maximum energy of photon nucleon system
2844       PTOTGN = SQRT((YMAX*PPL0(1)+PPA(1))**2+(YMAX*PPL0(2)+PPA(2))**2
2845      &                                      +(YMAX*PPL0(3)+PPA(3))**2)
2846       ETOTGN = YMAX*PPL0(4)+PPA(4)
2847       EGNMAX = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
2848       EGNMAX = MIN(EGNMAX,ECMAX)
2849 * minimum energy of photon nucleon system
2850       PTOTGN = SQRT((YMIN*PPL0(1)+PPA(1))**2+(YMIN*PPL0(2)+PPA(2))**2
2851      &                                      +(YMIN*PPL0(3)+PPA(3))**2)
2852       ETOTGN = YMIN*PPL0(4)+PPA(4)
2853       EGNMIN = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
2854       EGNMIN = MAX(EGNMIN,ECMIN)
2855
2856 * limits for Glauber-initialization
2857       Q2LI  = Q2MIN
2858       Q2HI  = MAX(Q2LI,MIN(Q2HI,Q2MAX))
2859       ECMLI = MAX(EGNMIN,THREE)
2860       ECMHI = EGNMAX
2861       WRITE(LOUT,1004) EGNMIN,EGNMAX,ECMLI,ECMHI,Q2LI,Q2HI
2862  1004 FORMAT(1X,'resulting limits:',/,9X,'W (min)   =',F7.1,
2863      &       ' GeV    (max) =',F7.1,' GeV',/,/,' limits for ',
2864      &       'Glauber-initialization:',/,9X,'W (min)   =',F7.1,
2865      &       ' GeV    (max) =',F7.1,' GeV',/,9X,'Q^2 (min) =',F7.1,
2866      &       ' GeV^2  (max) =',F7.1,' GeV^2',/)
2867 * initialization of Glauber-formalism
2868       IF (NCOMPO.LE.0) THEN
2869          CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2870       ELSE
2871          DO 9 I=1,NCOMPO
2872             CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2873     9    CONTINUE
2874       ENDIF
2875       CALL DT_SIGEMU
2876
2877 * initialization of run-statistics and histograms
2878       CALL DT_STATIS(1)
2879       CALL PHO_PHIST(1000,DUM)
2880
2881 * maximum photon-nucleus cross section
2882       I1  = 1
2883       I2  = 1
2884       RAT = ONE
2885       IF (EGNMAX.GE.ECMNN(NEBINI)) THEN
2886          I1  = NEBINI
2887          I2  = NEBINI
2888          RAT = ONE
2889       ELSEIF (EGNMAX.GT.ECMNN(1)) THEN
2890          DO 5 I=2,NEBINI
2891             IF (EGNMAX.LT.ECMNN(I)) THEN
2892                I1  = I-1
2893                I2  = I
2894                RAT = (EGNMAX-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
2895                GOTO 6
2896             ENDIF
2897     5    CONTINUE
2898     6    CONTINUE
2899       ENDIF
2900       SIGMAX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
2901       EGNXX  = EGNMAX
2902       I1  = 1
2903       I2  = 1
2904       RAT = ONE
2905       IF (EGNMIN.GE.ECMNN(NEBINI)) THEN
2906          I1  = NEBINI
2907          I2  = NEBINI
2908          RAT = ONE
2909       ELSEIF (EGNMIN.GT.ECMNN(1)) THEN
2910          DO 7 I=2,NEBINI
2911             IF (EGNMIN.LT.ECMNN(I)) THEN
2912                I1  = I-1
2913                I2  = I
2914                RAT = (EGNMIN-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
2915                GOTO 8
2916             ENDIF
2917     7    CONTINUE
2918     8    CONTINUE
2919       ENDIF
2920       SIGXX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
2921       IF (SIGXX.GT.SIGMAX) EGNXX = EGNMIN
2922       SIGMAX = MAX(SIGMAX,SIGXX)
2923       WRITE(LOUT,'(9X,A,F8.3,A)') 'Sigma_tot (max) =',SIGMAX,' mb'
2924
2925 * plot photon flux table
2926       AYMIN = LOG(YMIN)
2927       AYMAX = LOG(YMAX)
2928       AYRGE = AYMAX-AYMIN
2929       MAXTAB = 50
2930       ADY    = LOG(YMAX/YMIN)/DBLE(MAXTAB-1)
2931 C     WRITE(LOUT,'(/,1X,A)') 'LAEVT:   photon flux '
2932       DO 1 I=1,MAXTAB
2933          Y     = EXP(AYMIN+ADY*DBLE(I-1))
2934          Q2LOW = MAX(Q2MIN,AMLPT2*Y**2/(ONE-Y))
2935          FF1   = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2936      &                           -TWO*AMLPT2*Y*(ONE/Q2LOW-ONE/Q2MAX))
2937          FF2   = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2938      &                           -TWO*(ONE-Y)/Y*(ONE-Q2LOW/Q2MAX))
2939 C        WRITE(LOUT,'(5X,3E15.4)') Y,FF1,FF2
2940     1 CONTINUE
2941
2942 * maximum residual weight for flux sampling (dy/y)
2943       YY     = YMIN
2944       Q2LOW  = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
2945       WGHMAX = (ONE+(ONE-YY)**2)*LOG(Q2MAX/Q2LOW)
2946      &         -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
2947
2948       CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY0)
2949       CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY1)
2950       CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY2)
2951       CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ0)
2952       CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ1)
2953       CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ2)
2954       CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE0)
2955       CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE1)
2956       CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE2)
2957       CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU0)
2958       CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU1)
2959       CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU2)
2960       XBLOW = 0.001D0
2961       CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX0)
2962       CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX1)
2963       CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX2)
2964
2965       ITRY = 0
2966       ITRW = 0
2967       NC0  = 0
2968       NC1  = 0
2969
2970 * generate events
2971       DO 2 IEVT=1,NEVTS
2972          IF (MOD(IEVT,NMSG).EQ.0) THEN
2973 C           OPEN(LDAT,FILE='/scrtch3/hr/sroesler/statusd5.out',
2974 C    &                                         STATUS='UNKNOWN')
2975             WRITE(LOUT,'(1X,I8,A)') IEVT-1,' events sampled'
2976 C           CLOSE(LDAT)
2977          ENDIF
2978          NEVENT = IEVT
2979
2980   100    CONTINUE
2981          ITRY = ITRY+1
2982
2983 *  sample y
2984   101    CONTINUE
2985          ITRW  = ITRW+1
2986          YY    = EXP(AYRGE*DT_RNDM(RAT)+AYMIN)
2987          Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
2988          Q2LOG = LOG(Q2MAX/Q2LOW)
2989          WGH   = (ONE+(ONE-YY)**2)*Q2LOG
2990      &           -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
2991          IF (WGHMAX.LT.WGH) WRITE(LOUT,1000) YY,WGHMAX,WGH
2992  1000    FORMAT(1X,'LAEVT:   weight error!',3E12.5)
2993          IF (DT_RNDM(YY)*WGHMAX.GT.WGH) GOTO 101
2994
2995 *  sample Q2
2996          YEFF = ONE+(ONE-YY)**2
2997   102    CONTINUE
2998          Q2  = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
2999          WGH = (YEFF-TWO*(ONE-YY)*Q2LOW/Q2)/YEFF
3000          IF (WGH.LT.DT_RNDM(Q2)) GOTO 102
3001
3002 c        NC0 = NC0+1
3003 c        CALL DT_FILHGR(YY,ONE,IHFLY0,NC0)
3004 c        CALL DT_FILHGR(Q2,ONE,IHFLQ0,NC0)
3005
3006 *  kinematics at lepton-photon vertex
3007 *   scattered electron
3008          YQ2 = SQRT((ONE-YY)*Q2)
3009          Q2E = Q2/(4.0D0*PLEPT0(4))
3010          E1Y = (ONE-YY)*PLEPT0(4)
3011          CALL DT_DSFECF(SIF,COF)
3012          PLEPT1(1) = YQ2*COF
3013          PLEPT1(2) = YQ2*SIF
3014          PLEPT1(3) = E1Y-Q2E
3015          PLEPT1(4) = E1Y+Q2E
3016 C        THETA = ACOS( (E1Y-Q2E)/(E1Y+Q2E) )
3017 *   radiated photon
3018          PGAMM(1) = -PLEPT1(1)
3019          PGAMM(2) = -PLEPT1(2)
3020          PGAMM(3) = PLEPT0(3)-PLEPT1(3)
3021          PGAMM(4) = PLEPT0(4)-PLEPT1(4)
3022 *   E_cm cut
3023          PTOTGN = SQRT( (PGAMM(1)+PNUCL(1))**2+(PGAMM(2)+PNUCL(2))**2
3024      &                                        +(PGAMM(3)+PNUCL(3))**2 )
3025          ETOTGN = PGAMM(4)+PNUCL(4)
3026          ECMGN  = (ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)
3027          IF (ECMGN.LT.0.1D0) GOTO 101
3028          ECMGN  = SQRT(ECMGN)
3029          IF ((ECMGN.LT.ECMIN).OR.(ECMGN.GT.ECMAX)) GOTO 101
3030
3031 *  Lorentz-transformation into nucleon-rest system
3032          CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3033      &               PGAMM(1),PGAMM(2),PGAMM(3),PGAMM(4),
3034      &               PGTOT,PPG(1),PPG(2),PPG(3),PPG(4))
3035          CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3036      &               PLEPT1(1),PLEPT1(2),PLEPT1(3),PLEPT1(4),
3037      &               PLTOT,PPL1(1),PPL1(2),PPL1(3),PPL1(4))
3038 *  temporary checks..
3039          Q2TMP = ABS(PPG(4)**2-PGTOT**2)
3040          IF (ABS(Q2-Q2TMP).GT.0.01D0) WRITE(LOUT,1001) Q2,Q2TMP
3041  1001    FORMAT(1X,'LAEVT:    inconsistent kinematics (Q2,Q2TMP) ',
3042      &          2F10.4)
3043          ECMTMP = SQRT((PPG(4)+AAM(1)-PGTOT)*(PPG(4)+AAM(1)+PGTOT))
3044          IF (ABS(ECMGN-ECMTMP).GT.TINY10) WRITE(LOUT,1002) ECMGN,ECMTMP
3045  1002    FORMAT(1X,'LAEVT:    inconsistent kinematics (ECMGN,ECMTMP) ',
3046      &          2F10.2)
3047          YYTMP = PPG(4)/PPL0(4)
3048          IF (ABS(YY-YYTMP).GT.0.01D0) WRITE(LOUT,1005) YY,YYTMP
3049  1005    FORMAT(1X,'LAEVT:    inconsistent kinematics (YY,YYTMP) ',
3050      &          2F10.4)
3051
3052 *  lepton tagger (Lab)
3053          THETA = ACOS( PPL1(3)/PLTOT )
3054          IF (PPL1(4).GT.ELMIN) THEN
3055             IF ((THETA.LT.THMIN).OR.(THETA.GT.THMAX)) GOTO 101
3056          ENDIF
3057 *  photon energy-cut (Lab)
3058          IF (PPG(4).LT.EGMIN) GOTO 101
3059          IF (PPG(4).GT.EGMAX) GOTO 101
3060 *   x_Bj cut
3061          XBJ = ABS(Q2/(1.876D0*PPG(4)))
3062          IF (XBJ.LT.XBJMIN) GOTO 101
3063
3064          NC0 = NC0+1
3065          CALL DT_FILHGR(    Q2,ONE,IHFLQ0,NC0)
3066          CALL DT_FILHGR(    YY,ONE,IHFLY0,NC0)
3067          CALL DT_FILHGR(   XBJ,ONE,IHFLX0,NC0)
3068          CALL DT_FILHGR(PPG(4),ONE,IHFLU0,NC0)
3069          CALL DT_FILHGR( ECMGN,ONE,IHFLE0,NC0)
3070
3071 *  rotation angles against z-axis
3072          COD = PPG(3)/PGTOT
3073 C        SID = SQRT((ONE-COD)*(ONE+COD))
3074          PPT = SQRT(PPG(1)**2+PPG(2)**2)
3075          SID = PPT/PGTOT
3076          COF = ONE
3077          SIF = ZERO
3078          IF (PGTOT*SID.GT.TINY10) THEN
3079             COF   = PPG(1)/(SID*PGTOT)
3080             SIF   = PPG(2)/(SID*PGTOT)
3081             ANORF = SQRT(COF*COF+SIF*SIF)
3082             COF   = COF/ANORF
3083             SIF   = SIF/ANORF
3084          ENDIF
3085
3086          IF (IXSTBL.EQ.0) THEN
3087 *  change to photon projectile
3088             IJPROJ = 7
3089 *  set virtuality
3090             VIRT = Q2
3091 *  re-initialize LTs with new kinematics
3092 *  !!PGAMM ist set in cms (ECMGN) along z
3093             EPN = ZERO
3094             PPN = ZERO
3095             CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,ECMGN,0)
3096 *  force Lab-system
3097             IFRAME = 1
3098 *  get emulsion component if requested
3099             IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
3100 *  convolute with cross section
3101             CALL DT_SIGGAT(Q2LOW,EGNXX,STOTX,KKMAT)
3102             CALL DT_SIGGAT(Q2,ECMGN,STOT,KKMAT)
3103             IF (STOTX.LT.STOT) WRITE(LOUT,'(1X,A,/,6E12.3)')
3104      &         'LAEVT: warning STOTX<STOT ! ',Q2LOW,EGNMAX,STOTX,
3105      &                                        Q2,ECMGN,STOT
3106             IF (DT_RNDM(Q2)*STOTX.GT.STOT) GOTO 100
3107             NC1 = NC1+1
3108             CALL DT_FILHGR(    Q2,ONE,IHFLQ1,NC1)
3109             CALL DT_FILHGR(    YY,ONE,IHFLY1,NC1)
3110             CALL DT_FILHGR(   XBJ,ONE,IHFLX1,NC1)
3111             CALL DT_FILHGR(PPG(4),ONE,IHFLU1,NC1)
3112             CALL DT_FILHGR( ECMGN,ONE,IHFLE1,NC1)
3113 *  composite targets only
3114             KKMAT = -KKMAT
3115 *  sample this event
3116             CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IJPROJ,EPN,KKMAT,
3117      &                                                            IREJ)
3118 *  rotate momenta of final state particles back in photon-nucleon syst.
3119             DO 4 I=NPOINT(4),NHKK
3120                IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
3121      &                                      (ISTHKK(I).EQ.1001)) THEN
3122                   PX = PHKK(1,I)
3123                   PY = PHKK(2,I)
3124                   PZ = PHKK(3,I)
3125                   CALL DT_MYTRAN(1,PX,PY,PZ,COD,SID,COF,SIF,
3126      &                        PHKK(1,I),PHKK(2,I),PHKK(3,I))
3127                ENDIF
3128     4       CONTINUE
3129          ENDIF
3130
3131          CALL DT_FILHGR(    Q2,ONE,IHFLQ2,NC1)
3132          CALL DT_FILHGR(    YY,ONE,IHFLY2,NC1)
3133          CALL DT_FILHGR(   XBJ,ONE,IHFLX2,NC1)
3134          CALL DT_FILHGR(PPG(4),ONE,IHFLU2,NC1)
3135          CALL DT_FILHGR( ECMGN,ONE,IHFLE2,NC1)
3136
3137 *  dump this event to histograms
3138          CALL PHO_PHIST(2000,DUM)
3139
3140     2 CONTINUE
3141
3142       WGY    = ALPHEM/TWOPI*WGHMAX*DBLE(ITRY)/DBLE(ITRW)
3143       WGY    = WGY*LOG(YMAX/YMIN)
3144       WEIGHT = WGY*SIGMAX*DBLE(NEVTS)/DBLE(ITRY)
3145
3146 C     HEADER = ' LAEVT:  Q^2 distribution 0'
3147 C     CALL DT_OUTHGR(IHFLQ0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3148 C     HEADER = ' LAEVT:  Q^2 distribution 1'
3149 C     CALL DT_OUTHGR(IHFLQ1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3150 C     HEADER = ' LAEVT:  Q^2 distribution 2'
3151 C     CALL DT_OUTHGR(IHFLQ2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3152 C     HEADER = ' LAEVT:  y   distribution 0'
3153 C     CALL DT_OUTHGR(IHFLY0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3154 C     HEADER = ' LAEVT:  y   distribution 1'
3155 C     CALL DT_OUTHGR(IHFLY1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3156 C     HEADER = ' LAEVT:  y   distribution 2'
3157 C     CALL DT_OUTHGR(IHFLY2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3158 C     HEADER = ' LAEVT:  x   distribution 0'
3159 C     CALL DT_OUTHGR(IHFLX0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3160 C     HEADER = ' LAEVT:  x   distribution 1'
3161 C     CALL DT_OUTHGR(IHFLX1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3162 C     HEADER = ' LAEVT:  x   distribution 2'
3163 C     CALL DT_OUTHGR(IHFLX2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3164 C     HEADER = ' LAEVT:  E_g distribution 0'
3165 C     CALL DT_OUTHGR(IHFLU0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3166 C     HEADER = ' LAEVT:  E_g distribution 1'
3167 C     CALL DT_OUTHGR(IHFLU1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3168 C     HEADER = ' LAEVT:  E_g distribution 2'
3169 C     CALL DT_OUTHGR(IHFLU2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3170 C     HEADER = ' LAEVT:  E_c distribution 0'
3171 C     CALL DT_OUTHGR(IHFLE0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3172 C     HEADER = ' LAEVT:  E_c distribution 1'
3173 C     CALL DT_OUTHGR(IHFLE1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3174 C     HEADER = ' LAEVT:  E_c distribution 2'
3175 C     CALL DT_OUTHGR(IHFLE2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3176
3177 * print run-statistics and histograms to output-unit 6
3178       CALL PHO_PHIST(3000,DUM)
3179       IF (IXSTBL.EQ.0) CALL DT_STATIS(2)
3180
3181       RETURN
3182       END
3183
3184 *$ CREATE DT_DTUINI.FOR
3185 *COPY DT_DTUINI
3186 *
3187 *===dtuini=============================================================*
3188 *
3189       SUBROUTINE DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
3190      &                                               IDP,IEMU)
3191
3192       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3193       SAVE
3194
3195       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
3196 * emulsion treatment
3197       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
3198      &                NCOMPO,IEMUL
3199 * Glauber formalism: flags and parameters for statistics
3200       LOGICAL LPROD
3201       CHARACTER*8 CGLB
3202       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
3203
3204       CALL DT_INIT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IGLAU)
3205       CALL DT_STATIS(1)
3206       CALL PHO_PHIST(1000,DUM)
3207       IF (NCOMPO.LE.0) THEN
3208          CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
3209       ELSE
3210          DO 1 I=1,NCOMPO
3211             CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
3212     1    CONTINUE
3213       ENDIF
3214       IF (IOGLB.NE.100) CALL DT_SIGEMU
3215       IEMU = IEMUL
3216
3217       RETURN
3218       END
3219
3220 *$ CREATE DT_DTUOUT.FOR
3221 *COPY DT_DTUOUT
3222 *
3223 *===dtuout=============================================================*
3224 *
3225       SUBROUTINE DT_DTUOUT
3226
3227       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3228       SAVE
3229
3230       CALL PHO_PHIST(3000,DUM)
3231       CALL DT_STATIS(2)
3232
3233       RETURN
3234       END
3235
3236 *$ CREATE DT_BEAMPR.FOR
3237 *COPY DT_BEAMPR
3238 *
3239 *===beampr=============================================================*
3240 *
3241       SUBROUTINE DT_BEAMPR(WHAT,PLAB,MODE)
3242
3243 ************************************************************************
3244 * Initialization of event generation                                   *
3245 * This version dated  7.4.98  is written by S. Roesler.                *
3246 ************************************************************************
3247
3248       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3249       SAVE
3250
3251       PARAMETER ( LINP = 10 ,
3252      &            LOUT = 6 ,
3253      &            LDAT = 9 )
3254       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3255       PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3256
3257       LOGICAL LBEAM
3258
3259 * event history
3260       PARAMETER (NMXHKK=200000)
3261       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3262      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3263      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3264 * extended event history
3265       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3266      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3267      &                IHIST(2,NMXHKK)
3268 * properties of interacting particles
3269       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3270 * particle properties (BAMJET index convention)
3271       CHARACTER*8  ANAME
3272       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3273      &                IICH(210),IIBAR(210),K1(210),K2(210)
3274 * beam momenta
3275       COMMON /DTBEAM/ P1(4),P2(4)
3276
3277 C     DIMENSION WHAT(6),P1(4),P2(4),P1CMS(4),P2CMS(4)
3278       DIMENSION WHAT(6),P1CMS(4),P2CMS(4)
3279
3280       DATA LBEAM /.FALSE./
3281
3282       GOTO (1,2) MODE
3283
3284     1 CONTINUE
3285
3286       E1  = WHAT(1)
3287       IF (E1.LT.ZERO) E1 = DBLE(IPZ)/DBLE(IP)*ABS(WHAT(1))
3288       E2  = WHAT(2)
3289       IF (E2.LT.ZERO) E2 = DBLE(ITZ)/DBLE(IT)*ABS(WHAT(2))
3290       PP1 = SQRT( (E1+AAM(IJPROJ))*(E1-AAM(IJPROJ)) )
3291       PP2 = SQRT( (E2+AAM(IJTARG))*(E2-AAM(IJTARG)) )
3292       TH  = 1.D-6*WHAT(3)/2.D0
3293       PH  = WHAT(4)*BOG
3294       P1(1) = PP1*SIN(TH)*COS(PH)
3295       P1(2) = PP1*SIN(TH)*SIN(PH)
3296       P1(3) = PP1*COS(TH)
3297       P1(4) = E1
3298       P2(1) = PP2*SIN(TH)*COS(PH)
3299       P2(2) = PP2*SIN(TH)*SIN(PH)
3300       P2(3) = -PP2*COS(TH)
3301       P2(4) = E2
3302       ECM  = SQRT( (P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
3303      &                                              -(P1(3)+P2(3))**2 )
3304       ELAB = (ECM**2-AAM(IJPROJ)**2-AAM(IJTARG)**2)/(2.0D0*AAM(IJTARG))
3305       PLAB = SQRT( (ELAB+AAM(IJPROJ))*(ELAB-AAM(IJPROJ)) )
3306       BGX  = (P1(1)+P2(1))/ECM
3307       BGY  = (P1(2)+P2(2))/ECM
3308       BGZ  = (P1(3)+P2(3))/ECM
3309       BGE  = (P1(4)+P2(4))/ECM
3310       CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P1(1),P1(2),P1(3),P1(4),
3311      &            P1TOT,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4))
3312       CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P2(1),P2(2),P2(3),P2(4),
3313      &            P2TOT,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4))
3314       COD = P1CMS(3)/P1TOT
3315 C     SID = SQRT((ONE-COD)*(ONE+COD))
3316       PPT = SQRT(P1CMS(1)**2+P1CMS(2)**2)
3317       SID = PPT/P1TOT
3318       COF = ONE
3319       SIF = ZERO
3320       IF (P1TOT*SID.GT.TINY10) THEN
3321          COF   = P1CMS(1)/(SID*P1TOT)
3322          SIF   = P1CMS(2)/(SID*P1TOT)
3323          ANORF = SQRT(COF*COF+SIF*SIF)
3324          COF   = COF/ANORF
3325          SIF   = SIF/ANORF
3326       ENDIF
3327 **check
3328 C     WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3329 C     WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3330 C     WRITE(LOUT,'(5E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),P1TOT
3331 C     WRITE(LOUT,'(5E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),P2TOT
3332 C     PAX = ZERO
3333 C     PAY = ZERO
3334 C     PAZ = P1TOT
3335 C     PAE = SQRT(AAM(IJPROJ)**2+PAZ**2)
3336 C     PBX = ZERO
3337 C     PBY = ZERO
3338 C     PBZ = -P2TOT
3339 C     PBE = SQRT(AAM(IJTARG)**2+PBZ**2)
3340 C     WRITE(LOUT,'(4E15.4)') PAX,PAY,PAZ,PAE
3341 C     WRITE(LOUT,'(4E15.4)') PBX,PBY,PBZ,PBE
3342 C     CALL DT_MYTRAN(1,PAX,PAY,PAZ,COD,SID,COF,SIF,
3343 C    &            P1CMS(1),P1CMS(2),P1CMS(3))
3344 C     CALL DT_MYTRAN(1,PBX,PBY,PBZ,COD,SID,COF,SIF,
3345 C    &            P2CMS(1),P2CMS(2),P2CMS(3))
3346 C     WRITE(LOUT,'(4E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4)
3347 C     WRITE(LOUT,'(4E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4)
3348 C     CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),
3349 C    &            P1TOT,P1(1),P1(2),P1(3),P1(4))
3350 C     CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),
3351 C    &            P2TOT,P2(1),P2(2),P2(3),P2(4))
3352 C     WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3353 C     WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3354 C     STOP
3355 **
3356
3357       LBEAM = .TRUE.
3358
3359       RETURN
3360
3361     2 CONTINUE
3362
3363       IF (LBEAM) THEN
3364          IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3365          DO 20 I=NPOINT(4),NHKK
3366             IF ((ABS(ISTHKK(I)).EQ.1)  .OR.
3367      &           (ABS(ISTHKK(I)).EQ.2) .OR.
3368      &           (ISTHKK(I).EQ.1000)   .OR.
3369      &           (ISTHKK(I).EQ.1001)) THEN
3370
3371                CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I),
3372      &                     COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS)
3373                PECMS = PHKK(4,I)
3374                CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS,
3375      &                     PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I))
3376             ENDIF
3377    20    CONTINUE
3378       ELSE
3379          MODE = -1
3380       ENDIF
3381
3382       RETURN
3383       END
3384
3385 *$ CREATE DT_REJUCO.FOR
3386 *COPY DT_REJUCO
3387 *
3388 *===rejuco=============================================================*
3389 *
3390       SUBROUTINE DT_REJUCO(MODE,IREJ)
3391
3392 ************************************************************************
3393 * REJection of Unphysical COnfigurations                               *
3394 *     MODE = 1  rejection of particles with unphysically large energy  *
3395 *                                                                      *
3396 * This version dated 27.12.2006 is written by S. Roesler.              *
3397 ************************************************************************
3398
3399       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3400       SAVE
3401
3402       PARAMETER ( LINP = 10 ,
3403      &            LOUT = 6 ,
3404      &            LDAT = 9 )
3405       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3406       PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3407
3408 * maximum x_cms of final state particle
3409       PARAMETER (XCMSMX = 1.4D0)
3410
3411 * event history
3412       PARAMETER (NMXHKK=200000)
3413       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3414      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3415      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3416 * extended event history
3417       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3418      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3419      &                IHIST(2,NMXHKK)
3420 * Lorentz-parameters of the current interaction
3421       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
3422      &                UMO,PPCM,EPROJ,PPROJ
3423
3424       IREJ = 0
3425
3426       IF (MODE.EQ.1) THEN
3427          IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3428          ECMHLF = UMO/2.0D0
3429          DO 10 I=NPOINT(4),NHKK
3430             IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDHKK(I).NE.80000)) THEN
3431                XCMS = ABS(PHKK(4,I))/ECMHLF
3432                IF (XCMS.GT.XCMSMX) GOTO 9999
3433             ENDIF
3434    10    CONTINUE
3435       ENDIF
3436
3437       RETURN
3438  9999 CONTINUE
3439       IREJ = 1
3440       RETURN
3441       END
3442
3443 *$ CREATE DT_EVENTB.FOR
3444 *COPY DT_EVENTB
3445 *
3446 *===eventb=============================================================*
3447 *
3448       SUBROUTINE DT_EVENTB(NCSY,IREJ)
3449
3450 ************************************************************************
3451 * Treatment of nucleon-nucleon interactions with full two-component    *
3452 * Dual Parton Model.                                                   *
3453 *          NCSY     number of nucleon-nucleon interactions             *
3454 *          IREJ     rejection flag                                     *
3455 * This version dated 14.01.2000 is written by S. Roesler               *
3456 ************************************************************************
3457
3458       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3459       SAVE
3460       PARAMETER ( LINP = 10 ,
3461      &            LOUT = 6 ,
3462      &            LDAT = 9 )
3463       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
3464
3465 * event history
3466       PARAMETER (NMXHKK=200000)
3467       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3468      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3469      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3470 * extended event history
3471       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3472      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3473      &                IHIST(2,NMXHKK)
3474 *! uncomment this line for internal phojet-fragmentation
3475 C #include "dtu_dtevtp.inc"
3476 * particle properties (BAMJET index convention)
3477       CHARACTER*8  ANAME
3478       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3479      &                IICH(210),IIBAR(210),K1(210),K2(210)
3480 * flags for input different options
3481       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
3482       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
3483      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
3484 * rejection counter
3485       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
3486      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
3487      &                IREXCI(3),IRDIFF(2),IRINC
3488 * properties of interacting particles
3489       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3490 * properties of photon/lepton projectiles
3491       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
3492 * various options for treatment of partons (DTUNUC 1.x)
3493 * (chain recombination, Cronin,..)
3494       LOGICAL LCO2CR,LINTPT
3495       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
3496      &                LCO2CR,LINTPT
3497 * statistics
3498       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
3499      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
3500      &                ICEVTG(8,0:30)
3501 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
3502       COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
3503 * Glauber formalism: collision properties
3504       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
3505      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
3506      &                NCP,NCT
3507 * flags for diffractive interactions (DTUNUC 1.x)
3508       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
3509 * statistics: double-Pomeron exchange
3510       COMMON /DTFLG2/ INTFLG,IPOPO
3511 * flags for particle decays
3512       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
3513      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
3514      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
3515 * nucleon-nucleon event-generator
3516       CHARACTER*8 CMODEL
3517       LOGICAL LPHOIN
3518       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
3519 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
3520       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
3521       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
3522       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
3523      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
3524 C  model switches and parameters
3525       CHARACTER*8 MDLNA
3526       INTEGER ISWMDL,IPAMDL
3527       DOUBLE PRECISION PARMDL
3528       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3529 C  initial state parton radiation (internal part)
3530       INTEGER MXISR3,MXISR4
3531       PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
3532       INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
3533       DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
3534       COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
3535      &                ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
3536      &                IFL1(2,MXISR3),IFL2(2,MXISR3),
3537      &                IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
3538 C  event debugging information
3539       INTEGER NMAXD
3540       PARAMETER (NMAXD=100)
3541       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3542      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3543       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3544      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3545 C  general process information
3546       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3547       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3548
3549       DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4),
3550      &          PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4),
3551      &          PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4),
3552      &          KPRON(15),ISINGL(2000)
3553
3554 * initial values for max. number of phojet scatterings and dtunuc chains
3555 * to be fragmented with one pyexec call
3556       DATA MXPHFR,MXDTFR /10,100/
3557
3558       IREJ      = 0
3559 * pointer to first parton of the first chain in dtevt common
3560       NPOINT(3) = NHKK+1
3561 * special flag for double-Pomeron statistics
3562       IPOPO = 1
3563 * counter for low-mass (DTUNUC) interactions
3564       NDTUSC = 0
3565 * counter for interactions treated by PHOJET
3566       NPHOSC = 0
3567
3568 * scan interactions for single nucleon-nucleon interactions
3569 * (this has to be checked here because Cronin modifies parton momenta)
3570       NC = NPOINT(2)
3571       IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! '
3572       DO 8 I=1,NCSY
3573          ISINGL(I) = 0
3574          MOP = JMOHKK(1,NC)
3575          MOT = JMOHKK(1,NC+1)
3576          DIFF1 = ABS(PHKK(4,MOP)-PHKK(4,  NC)-PHKK(4,NC+2))
3577          DIFF2 = ABS(PHKK(4,MOT)-PHKK(4,NC+1)-PHKK(4,NC+3))
3578          IF ((DIFF1.LT.TINY10).AND.(DIFF2.LT.TINY10)) ISINGL(I) = 1
3579          NC = NC+4
3580     8 CONTINUE
3581
3582 * multiple scattering of chain ends
3583       IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
3584       IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
3585
3586 * switch to PHOJET-settings for JETSET parameter
3587       CALL DT_INITJS(1)
3588
3589 * loop over nucleon-nucleon interaction
3590       NC = NPOINT(2)
3591       DO 2 I=1,NCSY
3592 *
3593 *   pick up one nucleon-nucleon interaction from DTEVT1
3594 *     ppnn  / ptnn   - momenta of the interacting nucleons (cms)
3595 *     ptotnn         - total momentum of the interacting nucleons (cms)
3596 *     pp1,2 / pt1,2  - momenta of the four partons
3597 *     pp    / pt     - total momenta of the proj / targ partons
3598 *     ptot           - total momentum of the four partons
3599          MOP = JMOHKK(1,NC)
3600          MOT = JMOHKK(1,NC+1)
3601          DO 3 K=1,4
3602             PPNN(K)   = PHKK(K,MOP)
3603             PTNN(K)   = PHKK(K,MOT)
3604             PTOTNN(K) = PPNN(K)+PTNN(K)
3605             PP1(K)    = PHKK(K,NC)
3606             PT1(K)    = PHKK(K,NC+1)
3607             PP2(K)    = PHKK(K,NC+2)
3608             PT2(K)    = PHKK(K,NC+3)
3609             PP(K)     = PP1(K)+PP2(K)
3610             PT(K)     = PT1(K)+PT2(K)
3611             PTOT(K)   = PP(K)+PT(K)
3612     3    CONTINUE
3613 *
3614 *-----------------------------------------------------------------------
3615 *   this is a complete nucleon-nucleon interaction
3616 *
3617          IF (ISINGL(I).EQ.1) THEN
3618 *
3619 *     initialize PHOJET-variables for remnant/valence-partons
3620             IHFLD(1,1) = 0
3621             IHFLD(1,2) = 0
3622             IHFLD(2,1) = 0
3623             IHFLD(2,2) = 0
3624             IHFLS(1) = 1
3625             IHFLS(2) = 1
3626 *     save current settings of PHOJET process and min. bias flags
3627             DO 9 K=1,11
3628                KPRON(K) = IPRON(K,1)
3629     9       CONTINUE
3630             ISWSAV   = ISWMDL(2)
3631 *
3632 *     check if forced sampling of diffractive interaction requested
3633             IF (ISINGD.LT.-1) THEN
3634                DO 90 K=1,11
3635                   IPRON(K,1) = 0
3636    90          CONTINUE
3637                IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-3)) IPRON(5,1) = 1
3638                IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-4)) IPRON(6,1) = 1
3639                IF (ISINGD.EQ.-5) IPRON(4,1) = 1
3640             ENDIF
3641 *
3642 *     for photons: a direct/anomalous interaction is not sampled
3643 *     in PHOJET but already in Glauber-formalism. Here we check if such
3644 *     an interaction is requested
3645             IF (IJPROJ.EQ.7) THEN
3646 *       first switch off direct interactions
3647                IPRON(8,1) = 0
3648 *       this is a direct interactions
3649                IF (IDIREC.EQ.1) THEN
3650                   DO 12 K=1,11
3651                      IPRON(K,1) = 0
3652    12             CONTINUE
3653                   IPRON(8,1) = 1
3654 *       this is an anomalous interactions
3655 *         (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) )
3656                ELSEIF (IDIREC.EQ.2) THEN
3657                   ISWMDL(2) = 0
3658                ENDIF
3659             ELSE
3660                IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! '
3661             ENDIF
3662 *
3663 *     make sure that total momenta of partons, pp and pt, are on mass
3664 *     shell (Cronin may have srewed this up..)
3665             CALL DT_MASHEL(PP,PT,PHKK(5,MOP),PHKK(5,MOT),PPNN,PTNN,IR1)
3666             IF (IR1.NE.0) THEN
3667                IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)')
3668      &              'EVENTB:  mass shell correction rejected'
3669                GOTO 9999
3670             ENDIF
3671 *
3672 *     initialize the incoming particles in PHOJET
3673             IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3674                CALL PHO_SETPAR(1,22,0,VIRT)
3675             ELSE
3676                CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO)
3677             ENDIF
3678             CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO)
3679 *
3680 *     initialize rejection loop counter for anomalous processes
3681             IRJANO = 0
3682   800       CONTINUE
3683             IRJANO = IRJANO+1
3684 *
3685 *     temporary fix for ifano problem
3686             IFANO(1) = 0
3687             IFANO(2) = 0
3688 *
3689 *     generate complete hadron/nucleon/photon-nucleon event with PHOJET
3690             CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1)
3691 *
3692 *     for photons: special consistency check for anomalous interactions
3693             IF (IJPROJ.EQ.7) THEN
3694                IF (IRJANO.LT.30) THEN
3695                   IF (IFANO(1).NE.0) THEN
3696 *       here, an anomalous interaction was generated. Check if it
3697 *       was also requested. Otherwise reject this event.
3698                      IF (IDIREC.EQ.0) GOTO 800
3699                   ELSE
3700 *       here, an anomalous interaction was not generated. Check if it
3701 *       was requested in which case we need to reject this event.
3702                      IF (IDIREC.EQ.2) GOTO 800
3703                   ENDIF
3704                ELSE
3705                   WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ',
3706      &                          IRJANO,IDIREC,NEVHKK
3707                ENDIF
3708             ENDIF
3709 *
3710 *     copy back original settings of PHOJET process and min. bias flags
3711             DO 10 K=1,11
3712                IPRON(K,1) = KPRON(K)
3713    10       CONTINUE
3714             ISWMDL(2) = ISWSAV
3715 *
3716 *     check if PHOJET has rejected this event
3717             IF (IREJ1.NE.0) THEN
3718 C              IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3719                WRITE(LOUT,'(1X,A,I4)')
3720      &            'EVENTB:  chain system rejected',IDIREC
3721                CALL PHO_PREVNT(0)
3722                GOTO 9999
3723             ENDIF
3724 *
3725 *     copy partons and strings from PHOJET common back into DTEVT for
3726 *     external fragmentation
3727             MO1 = NC
3728             MO2 = NC+3
3729 *!      uncomment this line for internal phojet-fragmentation
3730 C           CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1)
3731             NPHOSC = NPHOSC+1
3732             CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1)
3733             IF (IREJ1.NE.0) THEN
3734                IF (IOULEV(1).GT.0)
3735      &         WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1'
3736                GOTO 9999
3737             ENDIF
3738 *
3739 *     update statistics counter
3740             ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1
3741 *
3742 *-----------------------------------------------------------------------
3743 *   this interaction involves "remnants"
3744 *
3745          ELSE
3746 *
3747 *     total mass of this system
3748             PPTOT  = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2)
3749             AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT)
3750             IF (AMTOT2.LT.ZERO) THEN
3751                AMTOT = ZERO
3752             ELSE
3753                AMTOT = SQRT(AMTOT2)
3754             ENDIF
3755 *
3756 *     systems with masses larger than elojet are treated with PHOJET
3757             IF (AMTOT.GT.ELOJET) THEN
3758 *
3759 *     initialize PHOJET-variables for remnant/valence-partons
3760 *       projectile parton flavors and valence flag
3761                IHFLD(1,1) = IDHKK(NC)
3762                IHFLD(1,2) = IDHKK(NC+2)
3763                IHFLS(1)   = 0
3764                IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7)
3765      &                            .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1
3766 *       target parton flavors and valence flag
3767                IHFLD(2,1) = IDHKK(NC+1)
3768                IHFLD(2,2) = IDHKK(NC+3)
3769                IHFLS(2)   = 0
3770                IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5)
3771      &                            .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1
3772 *       flag signalizing PHOJET how to treat the remnant:
3773 *         iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld
3774 *         iremn > -1 valence remnant: PHOJET assumes flavors according
3775 *                    to mother particle
3776                IREMN1 = IHFLS(1)-1
3777                IREMN2 = IHFLS(2)-1
3778 *
3779 *     initialize the incoming particles in PHOJET
3780                IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3781                   CALL PHO_SETPAR(1,22,IREMN1,VIRT)
3782                ELSE
3783                   CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO)
3784                ENDIF
3785                CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO)
3786 *
3787 *     calculate Lorentz parameter of the nucleon-nucleon cm-system
3788                PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2)
3789                AMNN   = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) )
3790                BGX    = PTOTNN(1)/AMNN
3791                BGY    = PTOTNN(2)/AMNN
3792                BGZ    = PTOTNN(3)/AMNN
3793                GAM    = PTOTNN(4)/AMNN
3794 *     transform interacting nucleons into nucleon-nucleon cm-system
3795                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3796      &                     PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS,
3797      &                     PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4))
3798                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3799      &                     PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS,
3800      &                     PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4))
3801 *     transform (total) momenta of the proj and targ partons into
3802 *     nucleon-nucleon cm-system
3803                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3804      &                     PP(1),PP(2),PP(3),PP(4),
3805      &                     PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4))
3806                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3807      &                     PT(1),PT(2),PT(3),PT(4),
3808      &                     PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4))
3809 *     energy fractions of the proj and targ partons
3810                XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE)
3811                XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE)
3812 ***
3813 * testprint
3814 c              PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
3815 c    &                        (PPTCMS(2)+PTTCMS(2))**2 +
3816 c    &                        (PPTCMS(3)+PTTCMS(3))**2 )
3817 c              EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
3818 c    &                        (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
3819 c              PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
3820 c    &                        (PPSUB(2)+PTSUB(2))**2 +
3821 c    &                        (PPSUB(3)+PTSUB(3))**2 )
3822 c              EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
3823 c    &                        (PPSUB(4)+PTSUB(4)+PTOTSU) )
3824 ***
3825 *
3826 *     save current settings of PHOJET process and min. bias flags
3827                DO 7 K=1,11
3828                   KPRON(K) = IPRON(K,1)
3829     7          CONTINUE
3830 *     disallow direct photon int. (does not make sense here anyway)
3831                IPRON(8,1) = 0
3832 *     disallow double pomeron processes (due to technical problems
3833 *     in PHOJET, needs to be solved sometime)
3834                IPRON(4,1) = 0
3835 *     disallow diffraction for sea-diquarks
3836                IF ((IABS(IHFLD(1,1)).GT.1100).AND.
3837      &             (IABS(IHFLD(1,2)).GT.1100)) THEN
3838                   IPRON(3,1) = 0
3839                   IPRON(6,1) = 0
3840                ENDIF
3841                IF ((IABS(IHFLD(2,1)).GT.1100).AND.
3842      &             (IABS(IHFLD(2,2)).GT.1100)) THEN
3843                   IPRON(3,1) = 0
3844                   IPRON(5,1) = 0
3845                ENDIF
3846 *
3847 *     we need massless partons: transform them on mass shell
3848                XMP = ZERO
3849                XMT = ZERO
3850                DO 6 K=1,4
3851                   PPTMP(K) = PPSUB(K)
3852                   PTTMP(K) = PTSUB(K)
3853     6          CONTINUE
3854                CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1)
3855                PPSUTO  = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2)
3856                PTSUTO  = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2)
3857                PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+
3858      &                  (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2)
3859 *     total energy of the subsysten after mass transformation
3860 *      (should be the same as before..)
3861                SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)*
3862      &                      (PPSUB(4)+PTSUB(4)+PSUTOT) )
3863 *
3864 *     after mass shell transformation the x_sub - relation has to be
3865 *     corrected. We therefore create "pseudo-momenta" of mother-nucleons.
3866 *
3867 *     The old version was to scale based on the original x_sub and the
3868 *     4-momenta of the subsystem. At very high energy this could lead to
3869 *     "pseudo-cm energies" of the parent system considerably exceeding
3870 *     the true cm energy. Now we keep the true cm energy and calculate
3871 *     new x_sub instead.
3872 C old version  PPTCMS(4) = PPSUB(4)/XPSUB
3873                PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4))
3874                XPSUB = PPSUB(4)/PPTCMS(4)
3875                IF (IJPROJ.EQ.7) THEN
3876                   AMP2  = PHKK(5,MOT)**2
3877                   PTOT1 = SQRT(PPTCMS(4)**2-AMP2)
3878                ELSE
3879 *???????
3880                   PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP))
3881      &                        *(PPTCMS(4)+PHKK(5,MOP)))
3882 C                 PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT))
3883 C    &                        *(PPTCMS(4)+PHKK(5,MOT)))
3884                ENDIF
3885 C old version  PTTCMS(4) = PTSUB(4)/XTSUB
3886                PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4))
3887                XTSUB = PTSUB(4)/PTTCMS(4)
3888                PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT))
3889      &                     *(PTTCMS(4)+PHKK(5,MOT)))
3890                DO 4 K=1,3
3891                   PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO
3892                   PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO
3893     4          CONTINUE
3894 ***
3895 * testprint
3896 *
3897 *     ppnn  / ptnn   - momenta of the int. nucleons (cms, negl. Fermi)
3898 *     ptotnn         - total momentum of the int. nucleons (cms, negl. Fermi)
3899 *     pptcms/ pttcms - momenta of the interacting nucleons (cms)
3900 *     pp1,2 / pt1,2  - momenta of the four partons
3901 *
3902 *     pp    / pt     - total momenta of the pr/ta partons (cms, negl. Fermi)
3903 *     ptot           - total momentum of the four partons (cms, negl. Fermi)
3904 *     ppsub / ptsub  - total momenta of the proj / targ partons (cms)
3905 *
3906 c              PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
3907 c    &                        (PPTCMS(2)+PTTCMS(2))**2 +
3908 c    &                        (PPTCMS(3)+PTTCMS(3))**2 )
3909 c              ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
3910 c    &                        (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
3911 c              PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
3912 c    &                        (PPSUB(2)+PTSUB(2))**2 +
3913 c    &                        (PPSUB(3)+PTSUB(3))**2 )
3914 c              ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
3915 c    &                        (PPSUB(4)+PTSUB(4)+PTOTSU) )
3916 c              IF (ENEWCM/EOLDCM.GT.1.1D0) THEN
3917 c                 WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM
3918 c                 WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU
3919 c                 WRITE(*,*) ' XPSUB,  XTSUB  : ',XPSUB,XTSUB
3920 c              ENDIF
3921 c              BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM
3922 c              BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM
3923 c              BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM
3924 c              BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM
3925 *     transform interacting nucleons into nucleon-nucleon cm-system
3926 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3927 c    &                    PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT,
3928 c    &                     PPNEW1,PPNEW2,PPNEW3,PPNEW4)
3929 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3930 c    &                    PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT,
3931 c    &                     PTNEW1,PTNEW2,PTNEW3,PTNEW4)
3932 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3933 c    &                     PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT,
3934 c    &                     PPSUB1,PPSUB2,PPSUB3,PPSUB4)
3935 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3936 c    &                     PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT,
3937 c    &                     PTSUB1,PTSUB2,PTSUB3,PTSUB4)
3938 c              PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 +
3939 c    &                        (PPNEW2+PTNEW2)**2 +
3940 c    &                        (PPNEW3+PTNEW3)**2 )
3941 c              ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) *
3942 c    &                        (PPNEW4+PTNEW4+PTSTCM) )
3943 c              PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 +
3944 c    &                        (PPSUB2+PTSUB2)**2 +
3945 c    &                        (PPSUB3+PTSUB3)**2 )
3946 c              ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) *
3947 c    &                        (PPSUB4+PTSUB4+PTSTSU) )
3948 C              WRITE(*,*) ' mother cmE :'
3949 C              WRITE(*,*) ETSTCM,ENEWCM
3950 C              WRITE(*,*) ' subsystem cmE :'
3951 C              WRITE(*,*) ETSTSU,ENEWSU
3952 C              WRITE(*,*) ' projectile mother :'
3953 C              WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4
3954 C              WRITE(*,*) ' target mother :'
3955 C              WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4
3956 C              WRITE(*,*) ' projectile subsystem:'
3957 C              WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4
3958 C              WRITE(*,*) ' target subsystem:'
3959 C              WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4
3960 C              WRITE(*,*) ' projectile subsystem should be:'
3961 C              WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0,
3962 C    &                    XPSUB*ETSTCM/2.0D0
3963 C              WRITE(*,*) ' target subsystem should be:'
3964 C              WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0,
3965 C    &                    XTSUB*ETSTCM/2.0D0
3966 C              WRITE(*,*) ' subsystem cmE should be: '
3967 C              WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB
3968 ***
3969 *
3970 *     generate complete remnant - nucleon/remnant event with PHOJET
3971                CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1)
3972 *
3973 *     copy back original settings of PHOJET process flags
3974                DO 11 K=1,11
3975                   IPRON(K,1) = KPRON(K)
3976    11          CONTINUE
3977 *
3978 *     check if PHOJET has rejected this event
3979                IF (IREJ1.NE.0) THEN
3980                   IF (IOULEV(1).GT.0)
3981      &            WRITE(LOUT,'(1X,A)') 'EVENTB:  chain system rejected'
3982                   WRITE(LOUT,*)
3983      &                 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT
3984                   CALL PHO_PREVNT(0)
3985                   GOTO 9999
3986                ENDIF
3987 *
3988 *     copy partons and strings from PHOJET common back into DTEVT for
3989 *     external fragmentation
3990                MO1 = NC
3991                MO2 = NC+3
3992 *!      uncomment this line for internal phojet-fragmentation
3993 C              CALL DT_GETFSP(MO1,MO2,PP,PT,1)
3994                NPHOSC = NPHOSC+1
3995                CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1)
3996                IF (IREJ1.NE.0) THEN
3997                   IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3998      &               'EVENTB: chain system rejected 2'
3999                   GOTO 9999
4000                ENDIF
4001 *
4002 *     update statistics counter
4003                ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1
4004 *
4005 *-----------------------------------------------------------------------
4006 * two-chain approx. for smaller systems
4007 *
4008             ELSE
4009 *
4010                NDTUSC = NDTUSC+1
4011 *   special flag for double-Pomeron statistics
4012                IPOPO = 0
4013 *
4014 *   pick up flavors at the ends of the two chains
4015                IFP1 = IDHKK(NC)
4016                IFT1 = IDHKK(NC+1)
4017                IFP2 = IDHKK(NC+2)
4018                IFT2 = IDHKK(NC+3)
4019 *   ..and the indices of the mothers
4020                MOP1 = NC
4021                MOT1 = NC+1
4022                MOP2 = NC+2
4023                MOT2 = NC+3
4024                CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
4025      &                     IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
4026 *
4027 *   check if this chain system was rejected
4028                IF (IREJ1.GT.0) THEN
4029                   IF (IOULEV(1).GT.0) THEN
4030                      WRITE(LOUT,*) 'rejected 1 in EVENTB'
4031                      WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)')
4032      &                  IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT
4033                   ENDIF
4034                   IRHHA = IRHHA+1
4035                   GOTO 9999
4036                ENDIF
4037 *   the following lines are for sea-sea chains rejected in GETCSY
4038                IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1
4039                ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1
4040             ENDIF
4041 *
4042          ENDIF
4043 *
4044 *     update statistics counter
4045          ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1
4046 *
4047          NC = NC+4
4048 *
4049     2 CONTINUE
4050 *
4051 *-----------------------------------------------------------------------
4052 * treatment of low-mass chains (if there are any)
4053 *
4054       IF (NDTUSC.GT.0) THEN
4055 *
4056 *   correct chains of very low masses for possible resonances
4057          IF (IRESCO.EQ.1) THEN
4058             CALL DT_EVTRES(IREJ1)
4059             IF (IREJ1.GT.0) THEN
4060                IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB'
4061                IRRES(1) = IRRES(1)+1
4062                GOTO 9999
4063             ENDIF
4064          ENDIF
4065 *   fragmentation of low-mass chains
4066 *!  uncomment this line for internal phojet-fragmentation
4067 *   (of course it will still be fragmented by DPMJET-routines but it
4068 *    has to be done here instead of further below)
4069 C        CALL DT_EVTFRA(IREJ1)
4070 C        IF (IREJ1.GT.0) THEN
4071 C           IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB'
4072 C           IRFRAG = IRFRAG+1
4073 C           GOTO 9999
4074 C        ENDIF
4075       ELSE
4076 *! uncomment this line for internal phojet-fragmentation
4077 C        NPOINT(4) = NHKK+1
4078          IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
4079       ENDIF
4080 *
4081 *-----------------------------------------------------------------------
4082 * new di-quark breaking mechanisms
4083 *
4084       MXLEFT = 2
4085       CALL DT_CHASTA(0)
4086       IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
4087      &                        .OR.(PDBSEA(3).GT.0.0D0)) THEN
4088          CALL DT_DIQBRK
4089          MXLEFT = 4
4090       ENDIF
4091 *
4092 *-----------------------------------------------------------------------
4093 * hadronize this event
4094 *
4095 *   hadronize PHOJET chain systems
4096       NPYMAX = 0
4097       NPJE   = NPHOSC/MXPHFR
4098       IF (MXPHFR.LT.MXLEFT) MXLEFT = 2
4099       IF (NPJE.GT.1) THEN
4100          NLEFT = NPHOSC-NPJE*MXPHFR
4101          DO 20 JFRG=1,NPJE
4102             NFRG = JFRG*MXPHFR
4103             IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN
4104                CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4105                IF (IREJ1.GT.0) GOTO 22
4106                NLEFT = 0
4107             ELSE
4108                CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1)
4109                IF (IREJ1.GT.0) GOTO 22
4110             ENDIF
4111             IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4112    20    CONTINUE
4113          IF (NLEFT.GT.0) THEN
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       ELSE
4119          CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4120          IF (IREJ1.GT.0) GOTO 22
4121          IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4122       ENDIF
4123 *
4124 *   check max. filling level of jetset common and
4125 *   reduce mxphfr if necessary
4126       IF (NPYMAX.GT.3000) THEN
4127          IF (NPYMAX.GT.3500) THEN
4128             MXPHFR = MAX(1,MXPHFR-2)
4129          ELSE
4130             MXPHFR = MAX(1,MXPHFR-1)
4131          ENDIF
4132 C        WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR
4133       ENDIF
4134 *
4135 *   hadronize DTUNUC chain systems
4136    23 CONTINUE
4137       IBACK = MXDTFR
4138       CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2)
4139       IF (IREJ2.GT.0) GOTO 22
4140 *
4141 *   check max. filling level of jetset common and
4142 *   reduce mxdtfr if necessary
4143       IF (NPYMEM.GT.3000) THEN
4144          IF (NPYMEM.GT.3500) THEN
4145             MXDTFR = MAX(1,MXDTFR-20)
4146          ELSE
4147             MXDTFR = MAX(1,MXDTFR-10)
4148          ENDIF
4149 C        WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR
4150       ENDIF
4151 *
4152       IF (IBACK.EQ.-1) GOTO 23
4153 *
4154    22 CONTINUE
4155 C     CALL DT_EVTFRG(1,IREJ1)
4156 C     CALL DT_EVTFRG(2,IREJ2)
4157       IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN
4158          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB'
4159          IRFRAG = IRFRAG+1
4160          GOTO 9999
4161       ENDIF
4162 *
4163 * get final state particles from /DTEVTP/
4164 *! uncomment this line for internal phojet-fragmentation
4165 C     CALL DT_GETFSP(IDUM,IDUM,PP,PT,2)
4166
4167       IF (IJPROJ.NE.7)
4168      &   CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3)
4169 C     IF (IREJ3.NE.0) GOTO 9999
4170
4171       RETURN
4172
4173  9999 CONTINUE
4174       IREVT = IREVT+1
4175       IREJ  = 1
4176       RETURN
4177       END
4178
4179 *$ CREATE DT_GETPJE.FOR
4180 *COPY DT_GETPJE
4181 *
4182 *===getpje=============================================================*
4183 *
4184       SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ)
4185
4186 ************************************************************************
4187 * This subroutine copies PHOJET partons and strings from POEVT1 into   *
4188 * DTEVT1.                                                              *
4189 *      MO1,MO2   indices of first and last mother-parton in DTEVT1     *
4190 *      PP,PT     4-momenta of projectile/target being handled by       *
4191 *                PHOJET                                                *
4192 * This version dated 11.12.99 is written by S. Roesler                 *
4193 ************************************************************************
4194
4195       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4196       SAVE
4197       PARAMETER ( LINP = 10 ,
4198      &            LOUT = 6 ,
4199      &            LDAT = 9 )
4200       PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1,
4201      &           ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0)
4202
4203       LOGICAL LFLIP
4204
4205 * event history
4206       PARAMETER (NMXHKK=200000)
4207       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4208      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4209      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4210 * extended event history
4211       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4212      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4213      &                IHIST(2,NMXHKK)
4214 * Lorentz-parameters of the current interaction
4215       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4216      &                UMO,PPCM,EPROJ,PPROJ
4217 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
4218       COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
4219 * flags for input different options
4220       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4221       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4222      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4223 * statistics: double-Pomeron exchange
4224       COMMON /DTFLG2/ INTFLG,IPOPO
4225 * statistics
4226       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
4227      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
4228      &                ICEVTG(8,0:30)
4229 * rejection counter
4230       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
4231      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
4232      &                IREXCI(3),IRDIFF(2),IRINC
4233 C  standard particle data interface
4234       INTEGER NMXHEP
4235       PARAMETER (NMXHEP=4000)
4236       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
4237       DOUBLE PRECISION PHEP,VHEP
4238       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
4239      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
4240      &                VHEP(4,NMXHEP), NSD1, NSD2, NDD
4241 C  extension to standard particle data interface (PHOJET specific)
4242       INTEGER IMPART,IPHIST,ICOLOR
4243       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
4244 C  color string configurations including collapsed strings and hadrons
4245       INTEGER MSTR
4246       PARAMETER (MSTR=500)
4247       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
4248       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
4249      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
4250      &                NNCH(MSTR),IBHAD(MSTR),ISTR
4251 C  general process information
4252       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4253       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4254 C  model switches and parameters
4255       CHARACTER*8 MDLNA
4256       INTEGER ISWMDL,IPAMDL
4257       DOUBLE PRECISION PARMDL
4258       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4259 C  event debugging information
4260       INTEGER NMAXD
4261       PARAMETER (NMAXD=100)
4262       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4263      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4264       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4265      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4266
4267       DIMENSION PP(4),PT(4)
4268       DATA MAXLOP /10000/
4269
4270       INHKK = NHKK
4271       LFLIP = .TRUE.
4272     1 CONTINUE
4273       NPVAL = 0
4274       NTVAL = 0
4275       IREJ  = 0
4276
4277 *   store initial momenta for energy-momentum conservation check
4278       IF (LEMCCK) THEN
4279          CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2)
4280          CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2)
4281       ENDIF
4282 * copy partons and strings from POEVT1 into DTEVT1
4283       DO 11 I=1,ISTR
4284 C        IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN
4285          IF (NCODE(I).EQ.-99) THEN
4286             IDXSTG = NPOS(1,I)
4287             IDSTG  = IDHEP(IDXSTG)
4288             PX = PHEP(1,IDXSTG)
4289             PY = PHEP(2,IDXSTG)
4290             PZ = PHEP(3,IDXSTG)
4291             PE = PHEP(4,IDXSTG)
4292             IF (MODE.LT.0) THEN
4293                ISTAT = 70000+IPJE
4294                CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE,
4295      &                        11,IDSTG,0)
4296                IF (LEMCCK) THEN
4297                   PX = -PX
4298                   PY = -PY
4299                   PZ = -PZ
4300                   PE = -PE
4301                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4302                ENDIF
4303             ELSE
4304                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4305      &                        PPX,PPY,PPZ,PPE)
4306                ISTAT = 70000+IPJE
4307                CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE,
4308      &                        11,IDSTG,0)
4309                IF (LEMCCK) THEN
4310                   PX = -PPX
4311                   PY = -PPY
4312                   PZ = -PPZ
4313                   PE = -PPE
4314                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4315                ENDIF
4316             ENDIF
4317             NOBAM(NHKK)   = 0
4318             IHIST(1,NHKK) = IPHIST(1,IDXSTG)
4319             IHIST(2,NHKK) = 0
4320          ELSEIF (NCODE(I).GE.0) THEN
4321 *   indices of partons and string in POEVT1
4322             IDX1 = ABS(JMOHEP(1,NPOS(1,I)))
4323             IDX2 = ABS(JMOHEP(2,NPOS(1,I)))
4324             IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN
4325                WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2,
4326      &         ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! '
4327                STOP ' GETPJE 1'
4328             ENDIF
4329             IDXSTG = NPOS(1,I)
4330 *   find "mother" string of the string
4331             IDXMS1 = ABS(JMOHEP(1,IDX1))
4332             IDXMS2 = ABS(JMOHEP(1,IDX2))
4333             IF (IDXMS1.NE.IDXMS2) THEN
4334                IDXMS1 = IDXSTG
4335                IDXMS2 = IDXSTG
4336 C              STOP ' GETPJE: IDXMS1.NE.IDXMS2 !'
4337             ENDIF
4338 *   search POEVT1 for the original hadron of the parton
4339             ILOOP = 0
4340             IPOM1 = 0
4341    14       CONTINUE
4342             ILOOP = ILOOP+1
4343             IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1
4344             IDXMS1 = ABS(JMOHEP(1,IDXMS1))
4345             IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND.
4346      &          (ILOOP.LT.MAXLOP)) GOTO 14
4347             IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! '
4348             IPOM2 = 0
4349             ILOOP = 0
4350    15       CONTINUE
4351             ILOOP = ILOOP+1
4352             IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1
4353             IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN
4354                IDXMS2 = ABS(JMOHEP(2,IDXMS2))
4355             ELSE
4356                IDXMS2 = ABS(JMOHEP(1,IDXMS2))
4357             ENDIF
4358             IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND.
4359      &          (ILOOP.LT.MAXLOP)) GOTO 15
4360             IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! '
4361 *   parton 1
4362             IF (IDXMS1.EQ.1) THEN
4363                ISPTN1 = ISTHKK(MO1)
4364                M1PTN1 = MO1
4365                M2PTN1 = MO1+2
4366             ELSE
4367                ISPTN1 = ISTHKK(MO2)
4368                M1PTN1 = MO2-2
4369                M2PTN1 = MO2
4370             ENDIF
4371 *   parton 2
4372             IF (IDXMS2.EQ.1) THEN
4373                ISPTN2 = ISTHKK(MO1)
4374                M1PTN2 = MO1
4375                M2PTN2 = MO1+2
4376             ELSE
4377                ISPTN2 = ISTHKK(MO2)
4378                M1PTN2 = MO2-2
4379                M2PTN2 = MO2
4380             ENDIF
4381 *   check for mis-identified mothers and switch mother indices if necessary
4382             IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6)
4383      &          .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND.
4384      &          (LFLIP)) THEN
4385                IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN
4386                   ISPTN1 = ISTHKK(MO1)
4387                   M1PTN1 = MO1
4388                   M2PTN1 = MO1+2
4389                   ISPTN2 = ISTHKK(MO2)
4390                   M1PTN2 = MO2-2
4391                   M2PTN2 = MO2
4392                ELSE
4393                   ISPTN1 = ISTHKK(MO2)
4394                   M1PTN1 = MO2-2
4395                   M2PTN1 = MO2
4396                   ISPTN2 = ISTHKK(MO1)
4397                   M1PTN2 = MO1
4398                   M2PTN2 = MO1+2
4399                ENDIF
4400             ENDIF
4401 *   register partons in temporary common
4402 *     parton at chain end
4403             PX = PHEP(1,IDX1)
4404             PY = PHEP(2,IDX1)
4405             PZ = PHEP(3,IDX1)
4406             PE = PHEP(4,IDX1)
4407 * flag only partons coming from Pomeron with 41/42
4408 C           IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4409             IF (IPOM1.NE.0) THEN
4410                ISTX = ABS(ISPTN1)/10
4411                IMO  = ABS(ISPTN1)-10*ISTX
4412                ISPTN1 = -(40+IMO)
4413             ELSE
4414                IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN
4415                   ISTX = ABS(ISPTN1)/10
4416                   IMO  = ABS(ISPTN1)-10*ISTX
4417                   IF ((IDHEP(IDX1).EQ.21).OR.
4418      &                (ABS(IPHIST(1,IDX1)).GE.100)) THEN
4419                      ISPTN1 = -(60+IMO)
4420                   ELSE
4421                      ISPTN1 = -(50+IMO)
4422                   ENDIF
4423                ENDIF
4424             ENDIF
4425             IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1
4426             IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1
4427             IF (MODE.LT.0) THEN
4428                CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY,
4429      &                        PZ,PE,0,0,0)
4430             ELSE
4431                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4432      &                        PPX,PPY,PPZ,PPE)
4433                CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY,
4434      &                        PPZ,PPE,0,0,0)
4435             ENDIF
4436             IHIST(1,NHKK) = IPHIST(1,IDX1)
4437             IHIST(2,NHKK) = 0
4438             DO 19 KK=1,4
4439                VHKK(KK,NHKK) = VHKK(KK,M2PTN1)
4440                WHKK(KK,NHKK) = WHKK(KK,M1PTN1)
4441    19       CONTINUE
4442             VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB
4443             WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB
4444             M1STRG = NHKK
4445 *     gluon kinks
4446             NGLUON = IDX2-IDX1-1
4447             IF (NGLUON.GT.0) THEN
4448                DO 17 IGLUON=1,NGLUON
4449                   IDX   = IDX1+IGLUON
4450                   IDXMS = ABS(JMOHEP(1,IDX))
4451                   IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN
4452                      ILOOP = 0
4453    16                CONTINUE
4454                      ILOOP = ILOOP+1
4455                      IDXMS = ABS(JMOHEP(1,IDXMS))
4456                      IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND.
4457      &                   (ILOOP.LT.MAXLOP)) GOTO 16
4458                      IF (ILOOP.EQ.MAXLOP)
4459      &                  WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! '
4460                   ENDIF
4461                   IF (IDXMS.EQ.1) THEN
4462                      ISPTN = ISTHKK(MO1)
4463                      M1PTN = MO1
4464                      M2PTN = MO1+2
4465                   ELSE
4466                      ISPTN = ISTHKK(MO2)
4467                      M1PTN = MO2-2
4468                      M2PTN = MO2
4469                   ENDIF
4470                   PX = PHEP(1,IDX)
4471                   PY = PHEP(2,IDX)
4472                   PZ = PHEP(3,IDX)
4473                   PE = PHEP(4,IDX)
4474                   IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN
4475                      ISTX = ABS(ISPTN)/10
4476                      IMO  = ABS(ISPTN)-10*ISTX
4477                      IF ((IDHEP(IDX).EQ.21).OR.
4478      &                   (ABS(IPHIST(1,IDX)).GE.100)) THEN
4479                         ISPTN = -(60+IMO)
4480                      ELSE
4481                         ISPTN = -(50+IMO)
4482                      ENDIF
4483                   ENDIF
4484                   IF (ISPTN.EQ.-21) NPVAL = NPVAL+1
4485                   IF (ISPTN.EQ.-22) NTVAL = NTVAL+1
4486                   IF (MODE.LT.0) THEN
4487                      CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4488      &                              PX,PY,PZ,PE,0,0,0)
4489                   ELSE
4490                      CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4491      &                              PPX,PPY,PPZ,PPE)
4492                      CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4493      &                              PPX,PPY,PPZ,PPE,0,0,0)
4494                   ENDIF
4495                   IHIST(1,NHKK) = IPHIST(1,IDX)
4496                   IHIST(2,NHKK) = 0
4497                   DO 20 KK=1,4
4498                      VHKK(KK,NHKK) = VHKK(KK,M2PTN)
4499                      WHKK(KK,NHKK) = WHKK(KK,M1PTN)
4500    20             CONTINUE
4501                   VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB
4502                   WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB
4503    17          CONTINUE
4504             ENDIF
4505 *     parton at chain end
4506             PX = PHEP(1,IDX2)
4507             PY = PHEP(2,IDX2)
4508             PZ = PHEP(3,IDX2)
4509             PE = PHEP(4,IDX2)
4510 * flag only partons coming from Pomeron with 41/42
4511 C           IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4512             IF (IPOM2.NE.0) THEN
4513                ISTX = ABS(ISPTN2)/10
4514                IMO  = ABS(ISPTN2)-10*ISTX
4515                ISPTN2 = -(40+IMO)
4516             ELSE
4517                IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN
4518                   ISTX = ABS(ISPTN2)/10
4519                   IMO  = ABS(ISPTN2)-10*ISTX
4520                   IF ((IDHEP(IDX2).EQ.21).OR.
4521      &                (ABS(IPHIST(1,IDX2)).GE.100)) THEN
4522                      ISPTN2 = -(60+IMO)
4523                   ELSE
4524                      ISPTN2 = -(50+IMO)
4525                   ENDIF
4526                ENDIF
4527             ENDIF
4528             IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1
4529             IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1
4530             IF (MODE.LT.0) THEN
4531                CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4532      &                        PX,PY,PZ,PE,0,0,0)
4533             ELSE
4534                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4535      &                        PPX,PPY,PPZ,PPE)
4536                CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4537      &                        PPX,PPY,PPZ,PPE,0,0,0)
4538             ENDIF
4539             IHIST(1,NHKK) = IPHIST(1,IDX2)
4540             IHIST(2,NHKK) = 0
4541             DO 21 KK=1,4
4542                VHKK(KK,NHKK) = VHKK(KK,M2PTN2)
4543                WHKK(KK,NHKK) = WHKK(KK,M1PTN2)
4544    21       CONTINUE
4545             VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB
4546             WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB
4547             M2STRG = NHKK
4548 *   register string
4549             JSTRG = 100*IPROCE+NCODE(I)
4550             PX = PHEP(1,IDXSTG)
4551             PY = PHEP(2,IDXSTG)
4552             PZ = PHEP(3,IDXSTG)
4553             PE = PHEP(4,IDXSTG)
4554             IF (MODE.LT.0) THEN
4555                ISTAT = 70000+IPJE
4556                CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4557      &                        PX,PY,PZ,PE,0,0,0)
4558                IF (LEMCCK) THEN
4559                   PX = -PX
4560                   PY = -PY
4561                   PZ = -PZ
4562                   PE = -PE
4563                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4564                ENDIF
4565             ELSE
4566                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4567      &                        PPX,PPY,PPZ,PPE)
4568                ISTAT = 70000+IPJE
4569                CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4570      &                        PPX,PPY,PPZ,PPE,0,0,0)
4571                IF (LEMCCK) THEN
4572                   PX = -PPX
4573                   PY = -PPY
4574                   PZ = -PPZ
4575                   PE = -PPE
4576                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4577                ENDIF
4578             ENDIF
4579             NOBAM(NHKK)   = 0
4580             IHIST(1,NHKK) = 0
4581             IHIST(2,NHKK) = 0
4582             DO 18 KK=1,4
4583                VHKK(KK,NHKK) = VHKK(KK,MO2)
4584                WHKK(KK,NHKK) = WHKK(KK,MO1)
4585    18       CONTINUE
4586             VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
4587             WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
4588          ENDIF
4589    11 CONTINUE
4590
4591       IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN
4592          NHKK  = INHKK
4593          LFLIP = .FALSE.
4594          GOTO 1
4595       ENDIF
4596
4597       IF (LEMCCK) THEN
4598          IF (UMO.GT.1.0D5) THEN
4599             CHKLEV = 1.0D0
4600          ELSE
4601             CHKLEV = TINY1
4602          ENDIF
4603          CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2)
4604          IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0)
4605       ENDIF
4606
4607 * internal statistics
4608 *   dble-Po statistics.
4609       IF (IPROCE.NE.4) IPOPO = 0
4610
4611       INTFLG = IPROCE
4612       IDCHSY = IDCH(MO1)
4613       IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN
4614          ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1
4615       ELSE
4616          WRITE(LOUT,1000) IPROCE,NEVHKK,MO1
4617  1000    FORMAT(1X,'GETFSP:   warning! incons. process id. (',I2,
4618      &          ') at evt(chain) ',I6,'(',I2,')')
4619       ENDIF
4620       IF (IPROCE.EQ.5) THEN
4621          IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN
4622             ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1
4623          ELSE
4624 C           WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4625  1001       FORMAT(1X,'GETFSP:   warning! incons. diffrac. id. ',
4626      &             '(IPROCE,IDIFR1,IDIFR2=',3I3,')')
4627          ENDIF
4628       ELSEIF (IPROCE.EQ.6) THEN
4629          IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4630             ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1
4631          ELSE
4632 C           WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4633          ENDIF
4634       ELSEIF (IPROCE.EQ.7) THEN
4635          IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND.
4636      &       (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4637             IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1))
4638      &         ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1
4639             IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2))
4640      &         ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1
4641             IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2))
4642      &         ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1
4643             IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1))
4644      &         ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1
4645          ELSE
4646             WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4647          ENDIF
4648       ENDIF
4649       IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3))
4650      &                                                       THEN
4651          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4652          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4653          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4654       ENDIF
4655       ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM
4656       ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM
4657       ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG
4658       ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG)
4659       ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO)
4660
4661       RETURN
4662
4663  9999 CONTINUE
4664       IREJ = 1
4665       RETURN
4666       END
4667
4668 *$ CREATE DT_PHOINI.FOR
4669 *COPY DT_PHOINI
4670 *
4671 *===phoini=============================================================*
4672 *
4673       SUBROUTINE DT_PHOINI
4674
4675 ************************************************************************
4676 * Initialization PHOJET-event generator for nucleon-nucleon interact.  *
4677 * This version dated 16.11.95 is written by S. Roesler                 *
4678 *                                                                      *
4679 * Last change 27.12.2006 by S. Roesler.                                *
4680 ************************************************************************
4681
4682       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4683       SAVE
4684       PARAMETER ( LINP = 10 ,
4685      &            LOUT = 6 ,
4686      &            LDAT = 9 )
4687       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
4688
4689 * nucleon-nucleon event-generator
4690       CHARACTER*8 CMODEL
4691       LOGICAL LPHOIN
4692       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
4693 * particle properties (BAMJET index convention)
4694       CHARACTER*8  ANAME
4695       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
4696      &                IICH(210),IIBAR(210),K1(210),K2(210)
4697 * Lorentz-parameters of the current interaction
4698       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4699      &                UMO,PPCM,EPROJ,PPROJ
4700 * properties of interacting particles
4701       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
4702 * properties of photon/lepton projectiles
4703       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
4704       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
4705 * emulsion treatment
4706       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
4707      &                NCOMPO,IEMUL
4708 * VDM parameter for photon-nucleus interactions
4709       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
4710 * nuclear potential
4711       LOGICAL LFERMI
4712       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
4713      &                EBINDP(2),EBINDN(2),EPOT(2,210),
4714      &                ETACOU(2),ICOUL,LFERMI
4715 * Glauber formalism: flags and parameters for statistics
4716       LOGICAL LPROD
4717       CHARACTER*8 CGLB
4718       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
4719 *
4720 * parameters for cascade calculations:
4721 * maximum mumber of PDF's which can be defined in phojet (limited
4722 * by the dimension of ipdfs in pho_setpdf)
4723       PARAMETER (MAXPDF = 20)
4724 * PDF parametrization and number of set for the first 30 hadrons in
4725 * the bamjet-code list
4726 *   negative numbers mean that the PDF is set in phojet,
4727 *   zero stands for "not a hadron"
4728       DIMENSION IPARPD(30),ISETPD(30)
4729 * PDF parametrization
4730       DATA IPARPD /
4731      &  -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5,
4732      &   5, 5,-5, 5, 5, 0, 0, 0, 0, 0/
4733 * number of set
4734       DATA ISETPD /
4735      &  -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6,
4736      &   6, 6,-2, 2, 2, 0, 0, 0, 0, 0/
4737
4738 **PHOJET105a
4739 C     COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
4740 C     PARAMETER ( MAXPRO = 16 )
4741 C     PARAMETER ( MAXTAB = 20 )
4742 C     COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO),
4743 C    &                MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB
4744 C     CHARACTER*8 MDLNA
4745 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
4746 C     COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15)
4747 **PHOJET110
4748 C  global event kinematics and particle IDs
4749       INTEGER IFPAP,IFPAB
4750       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
4751       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
4752 C  hard cross sections and MC selection weights
4753       INTEGER Max_pro_2
4754       PARAMETER ( Max_pro_2 = 16 )
4755       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
4756      &  MH_acc_1,MH_acc_2
4757       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
4758       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
4759      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
4760      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
4761      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
4762      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
4763 C  model switches and parameters
4764       CHARACTER*8 MDLNA
4765       INTEGER ISWMDL,IPAMDL
4766       DOUBLE PRECISION PARMDL
4767       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4768 C  general process information
4769       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4770       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4771 **
4772       DIMENSION PP(4),PT(4)
4773
4774       LOGICAL LSTART
4775       DATA LSTART /.TRUE./
4776
4777       IJP = IJPROJ
4778       IJT = IJTARG
4779       Q2  = VIRT
4780 * lepton-projectiles: initialize real photon instead
4781       IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN
4782          IJP = 7
4783          Q2  = ZERO
4784       ENDIF
4785       IF (LPHOIN) CALL PHO_INIT(-1,LOUT,IDUM)
4786 * switch Reggeon off
4787 C     IPAMDL(3)= 0
4788       IF (IP.EQ.1) THEN
4789          IFPAP(1) = IDT_IPDGHA(IJP)
4790          IFPAB(1) = IJP
4791       ELSE
4792          IFPAP(1) = 2212
4793          IFPAB(1) = IDT_ICIHAD(IFPAP(1))
4794       ENDIF
4795       PMASS(1) = AAM(IFPAB(1))-SQRT(Q2)
4796       PVIRT(1) = PMASS(1)**2
4797       IF (IT.EQ.1) THEN
4798          IFPAP(2) = IDT_IPDGHA(IJT)
4799          IFPAB(2) = IJT
4800       ELSE
4801          IFPAP(2) = 2212
4802          IFPAB(2) = IDT_ICIHAD(IFPAP(2))
4803       ENDIF
4804       PMASS(2) = AAM(IFPAB(2))
4805       PVIRT(2) = ZERO
4806       DO 1 K=1,4
4807          PP(K) = ZERO
4808          PT(K) = ZERO
4809     1 CONTINUE
4810 * get max. possible momenta of incoming particles to be used for PHOJET ini.
4811       PPF = ZERO
4812       PTF = ZERO
4813       SCPF= 1.5D0
4814       IF (UMO.GE.1.E5) THEN
4815          SCPF= 5.0D0
4816       ENDIF
4817       IF (NCOMPO.GT.0) THEN
4818          DO 2 I=1,NCOMPO
4819             IF (IT.GT.1) THEN
4820                CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0)
4821             ELSE
4822                CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0)
4823             ENDIF
4824             PPFTMP = MAX(PFERMP(1),PFERMN(1))
4825             PTFTMP = MAX(PFERMP(2),PFERMN(2))
4826             IF (PPFTMP.GT.PPF) PPF = PPFTMP
4827             IF (PTFTMP.GT.PTF) PTF = PTFTMP
4828     2    CONTINUE
4829       ELSE
4830          CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
4831          PPF = MAX(PFERMP(1),PFERMN(1))
4832          PTF = MAX(PFERMP(2),PFERMN(2))
4833       ENDIF
4834       PTF = -PTF
4835       PPF = SCPF*PPF
4836       PTF = SCPF*PTF
4837       IF (IJP.EQ.7) THEN
4838          AMP2  = SIGN(PMASS(1)**2,PMASS(1))
4839          PP(3) = PPCM
4840          PP(4) = SQRT(AMP2+PP(3)**2)
4841       ELSE
4842          EPF = SQRT(PPF**2+PMASS(1)**2)
4843          CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2)
4844       ENDIF
4845       ETF = SQRT(PTF**2+PMASS(2)**2)
4846       CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3)
4847       ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
4848      &              (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
4849       IF (LSTART) THEN
4850          WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP
4851  1001    FORMAT(
4852      &      ' DT_PHOINI:    PHOJET initialized for projectile A,Z = ',
4853      &      I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
4854          IF (NCOMPO.GT.0) THEN
4855             WRITE(LOUT,1002) SCPF,PTF,PT
4856          ELSE
4857             WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT
4858          ENDIF
4859  1002    FORMAT(
4860      &      ' DT_PHOINI:    PHOJET initialized for target emulsion  ',
4861      &          /,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
4862  1003    FORMAT(
4863      &      ' DT_PHOINI:    PHOJET initialized for target     A,Z = ',
4864      &      I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
4865          WRITE(LOUT,1004) ECMINI
4866  1004    FORMAT(' E_cm = ',E10.3)
4867          IF (IJP.EQ.8) WRITE(LOUT,1005)
4868  1005    FORMAT(
4869      &      ' DT_PHOINI: warning! proton parameters used for neutron',
4870      &          ' projectile')
4871          LSTART = .FALSE.
4872       ENDIF
4873 * switch off new diffractive cross sections at low energies for nuclei
4874 * (temporary solution)
4875       IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN
4876          WRITE(LOUT,'(1X,A)')
4877      &      ' DT_PHOINI: model-switch 30 for nuclei re-set !'
4878          CALL PHO_SETMDL(30,0,1)
4879       ENDIF
4880 *
4881 C     IF (IJP.EQ.7) THEN
4882 C        AMP2  = SIGN(PMASS(1)**2,PMASS(1))
4883 C        PP(3) = PPCM
4884 C        PP(4) = SQRT(AMP2+PP(3)**2)
4885 C     ELSE
4886 C        PFERMX = ZERO
4887 C        IF (IP.GT.1) PFERMX = 0.5D0
4888 C        EFERMX = SQRT(PFERMX**2+PMASS(1)**2)
4889 C        CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2)
4890 C     ENDIF
4891 C     PFERMX = ZERO
4892 C     IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0
4893 C     EFERMX = SQRT(PFERMX**2+PMASS(2)**2)
4894 C     CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3)
4895 **sr 26.10.96
4896       ISAV = IPAMDL(13)
4897       IF ((ISHAD(2).EQ.1).AND.
4898      &   ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR.
4899      &    (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1
4900 **
4901       CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1)
4902 **sr 26.10.96
4903       IPAMDL(13) = ISAV
4904 **
4905 *
4906 * patch for cascade calculations:
4907 * define parton distribution functions for other hadrons, i.e. other
4908 * then defined already in phojet
4909       IF (IOGLB.EQ.100) THEN
4910          WRITE(LOUT,1006)
4911  1006    FORMAT(/,1X,'PHOINI: additional parton distribution functions',
4912      &          ' assiged (ID,IPAR,ISET)',/)
4913          NPDF = 0
4914          DO 3 I=1,30
4915             IF (IPARPD(I).NE.0) THEN
4916                NPDF = NPDF+1
4917                IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !'
4918                IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN
4919                   IDPDG = IDT_IPDGHA(I)
4920                   IPAR  = IPARPD(I)
4921                   ISET  = ISETPD(I)
4922                   WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET
4923                   CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1)
4924                ENDIF
4925             ENDIF
4926     3    CONTINUE
4927       ENDIF
4928
4929 C     CALL PHO_PHIST(-1,SIGMAX)
4930       IF (IREJ1.NE.0) THEN
4931          WRITE(LOUT,1000)
4932  1000    FORMAT(1X,'PHOINI:   PHOJET event-initialization failed!')
4933          STOP
4934       ENDIF
4935
4936       RETURN
4937       END
4938
4939 *$ CREATE DT_EVENTD.FOR
4940 *COPY DT_EVENTD
4941 *
4942 *===eventd=============================================================*
4943 *
4944       SUBROUTINE DT_EVENTD(IREJ)
4945
4946 ************************************************************************
4947 * Quasi-elastic neutrino nucleus scattering.                           *
4948 * This version dated 29.04.00 is written by S. Roesler.                *
4949 ************************************************************************
4950
4951       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4952       SAVE
4953       PARAMETER ( LINP = 10 ,
4954      &            LOUT = 6 ,
4955      &            LDAT = 9 )
4956       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5)
4957       PARAMETER (SQTINF=1.0D+15)
4958
4959       LOGICAL LFIRST
4960
4961 * event history
4962       PARAMETER (NMXHKK=200000)
4963       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4964      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4965      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4966 * extended event history
4967       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4968      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4969      &                IHIST(2,NMXHKK)
4970 * flags for input different options
4971       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4972       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4973      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4974       PARAMETER (MAXLND=4000)
4975       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
4976 * properties of interacting particles
4977       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
4978 * Lorentz-parameters of the current interaction
4979       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4980      &                UMO,PPCM,EPROJ,PPROJ
4981 * nuclear potential
4982       LOGICAL LFERMI
4983       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
4984      &                EBINDP(2),EBINDN(2),EPOT(2,210),
4985      &                ETACOU(2),ICOUL,LFERMI
4986 * steering flags for qel neutrino scattering modules
4987       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
4988       COMMON /QNPOL/ POLARX(4),PMODUL
4989       INTEGER PYK
4990
4991       DATA LFIRST /.TRUE./
4992
4993       IREJ = 0
4994
4995       IF (LFIRST) THEN
4996          LFIRST = .FALSE.
4997          CALL DT_MASS_INI
4998       ENDIF
4999
5000 * JETSET parameter
5001       CALL DT_INITJS(0)
5002
5003 * interacting target nucleon
5004       LTYP = NEUTYP
5005       IF (NEUDEC.LE.9) THEN
5006          IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN
5007             NUCTYP = 2112
5008             NUCTOP = 2
5009          ELSE
5010             NUCTYP = 2212
5011             NUCTOP = 1
5012          ENDIF
5013       ELSE
5014          RTYP  = DT_RNDM(RTYP)
5015          ZFRAC = DBLE(ITZ)/DBLE(IT)
5016          IF (RTYP.LE.ZFRAC) THEN
5017             NUCTYP = 2212
5018             NUCTOP = 1
5019          ELSE
5020             NUCTYP = 2112
5021             NUCTOP = 2
5022          ENDIF
5023       ENDIF
5024
5025 * select first nucleon in list with matching id and reset all other
5026 * nucleons which have been marked as "wounded" by ININUC
5027       IFOUND = 0
5028       DO 1 I=1,NHKK
5029          IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN
5030             ISTHKK(I) = 12
5031             IFOUND    = 1
5032             IDX = I
5033          ELSE
5034             IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14
5035          ENDIF
5036     1 CONTINUE
5037       IF (IFOUND.EQ.0)
5038      &   STOP ' EVENTD: interacting target nucleon not found! '
5039
5040 * correct position of proj. lepton: assume position of target nucleon
5041       DO 3 I=1,4
5042          VHKK(I,1) = VHKK(I,IDX)
5043          WHKK(I,1) = WHKK(I,IDX)
5044     3 CONTINUE
5045
5046 * load initial momenta for conservation check
5047       IF (LEMCCK) THEN
5048          CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM)
5049          CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX),
5050      &                                                      2,IDUM,IDUM)
5051       ENDIF
5052
5053 * quasi-elastic scattering
5054       IF (NEUDEC.LT.9) THEN
5055          CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),
5056      &                                          PHKK(4,IDX),PHKK(5,IDX))
5057 *  CC event on p or n
5058       ELSEIF (NEUDEC.EQ.10) THEN
5059          CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX),
5060      &                     PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5061 *  NC event on p or n
5062       ELSEIF (NEUDEC.EQ.11) THEN
5063          CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX),
5064      &                     PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5065       ENDIF
5066
5067 * get final state particles from Lund-common and write them into HKKEVT
5068       NPOINT(1) = NHKK+1
5069       NPOINT(4) = NHKK+1
5070       NLINES = PYK(0,1)
5071       NHKK0  = NHKK+1
5072       DO 4 I=4,NLINES
5073          IF (K(I,1).EQ.1) THEN
5074             ID = K(I,2)
5075             PX = P(I,1)
5076             PY = P(I,2)
5077             PZ = P(I,3)
5078             PE = P(I,4)
5079             CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0)
5080             IDBJ = IDT_ICIHAD(ID)
5081             EKIN = PHKK(4,NHKK)-PHKK(5,NHKK)
5082             IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN
5083                IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16
5084             ENDIF
5085             VHKK(1,NHKK) = VHKK(1,IDX)
5086             VHKK(2,NHKK) = VHKK(2,IDX)
5087             VHKK(3,NHKK) = VHKK(3,IDX)
5088             VHKK(4,NHKK) = VHKK(4,IDX)
5089 C           IF (I.EQ.4) THEN
5090 C              WHKK(1,NHKK) = POLARX(1)
5091 C              WHKK(2,NHKK) = POLARX(2)
5092 C              WHKK(3,NHKK) = POLARX(3)
5093 C              WHKK(4,NHKK) = POLARX(4)
5094 C           ELSE
5095                WHKK(1,NHKK) = WHKK(1,IDX)
5096                WHKK(2,NHKK) = WHKK(2,IDX)
5097                WHKK(3,NHKK) = WHKK(3,IDX)
5098                WHKK(4,NHKK) = WHKK(4,IDX)
5099 C           ENDIF
5100             IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
5101          ENDIF
5102     4 CONTINUE
5103
5104       IF (LEMCCK) THEN
5105          CHKLEV = TINY5
5106          CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1)
5107          IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
5108       ENDIF
5109
5110 * transform momenta into cms (as required for inc etc.)
5111       DO 5 I=NHKK0,NHKK
5112          IF (ISTHKK(I).EQ.1) THEN
5113             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3)
5114             PHKK(3,I) = PZ
5115             PHKK(4,I) = PE
5116          ENDIF
5117     5 CONTINUE
5118
5119       RETURN
5120       END
5121
5122 *$ CREATE DT_KKEVNT.FOR
5123 *COPY DT_KKEVNT
5124 *
5125 *===kkevnt=============================================================*
5126 *
5127       SUBROUTINE DT_KKEVNT(KKMAT,IREJ)
5128
5129 ************************************************************************
5130 * Treatment of complete nucleus-nucleus or hadron-nucleus scattering   *
5131 * without nuclear effects (one event).                                 *
5132 * This subroutine is an update of the previous version (KKEVT) written *
5133 * by J. Ranft/ H.-J. Moehring.                                         *
5134 * This version dated 20.04.95 is written by S. Roesler                 *
5135 ************************************************************************
5136
5137       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5138       SAVE
5139       PARAMETER ( LINP = 10 ,
5140      &            LOUT = 6 ,
5141      &            LDAT = 9 )
5142       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10)
5143
5144       PARAMETER ( MAXNCL = 260,
5145      &            MAXVQU = MAXNCL,
5146      &            MAXSQU = 20*MAXVQU,
5147      &            MAXINT = MAXVQU+MAXSQU)
5148 * event history
5149       PARAMETER (NMXHKK=200000)
5150       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5151      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5152      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5153 * extended event history
5154       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5155      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5156      &                IHIST(2,NMXHKK)
5157 * flags for input different options
5158       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5159       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5160      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5161 * rejection counter
5162       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
5163      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
5164      &                IREXCI(3),IRDIFF(2),IRINC
5165 * statistics
5166       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5167      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5168      &                ICEVTG(8,0:30)
5169 * properties of interacting particles
5170       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5171 * Lorentz-parameters of the current interaction
5172       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5173      &                UMO,PPCM,EPROJ,PPROJ
5174 * flags for diffractive interactions (DTUNUC 1.x)
5175       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5176 * interface HADRIN-DPM
5177       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5178 * nucleon-nucleon event-generator
5179       CHARACTER*8 CMODEL
5180       LOGICAL LPHOIN
5181       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
5182 * coordinates of nucleons
5183       COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
5184 * interface between Glauber formalism and DPM
5185       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
5186      &                INTER1(MAXINT),INTER2(MAXINT)
5187 * Glauber formalism: collision properties
5188       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5189      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
5190      &                NCP,NCT
5191 * central particle production, impact parameter biasing
5192       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5193 **temporary
5194 * statistics: Glauber-formalism
5195       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5196 **
5197
5198       DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/
5199
5200       IREJ   = 0
5201       ICREQU = ICREQU+1
5202       NC     = 0
5203
5204     1 CONTINUE
5205       ICSAMP = ICSAMP+1
5206       NC     = NC+1
5207       IF (MOD(NC,10).EQ.0) THEN
5208          WRITE(LOUT,1000) NEVHKK
5209  1000    FORMAT(1X,'KKEVNT: event ',I8,' rejected!')
5210          GOTO 9999
5211       ENDIF
5212
5213 * initialize DTEVT1/DTEVT2
5214       CALL DT_EVTINI
5215
5216 * We need the following only in order to sample nucleon coordinates.
5217 * However we don't have parameters (cross sections, slope etc.)
5218 * for neutrinos available. Therefore switch projectile to proton
5219 * in this case.
5220       IF (MCGENE.EQ.4) THEN
5221          JJPROJ = 1
5222       ELSE
5223          JJPROJ = IJPROJ
5224       ENDIF
5225
5226    10 CONTINUE
5227       IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR.
5228 * make sure that Glauber-formalism is called each time the interaction
5229 * configuration changed
5230      &     (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR.
5231      &     (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN
5232 * sample number of nucleon-nucleon coll. according to Glauber-form.
5233          CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT)
5234          NWTSAM = NN
5235          NWASAM = NP
5236          NWBSAM = NT
5237          NEVOLD = NEVHKK
5238          IPOLD  = IP
5239          ITOLD  = IT
5240          JJPOLD = JJPROJ
5241          EPROLD = EPROJ
5242          NCP    = 0
5243          NCT    = 0
5244
5245          DO 8 I=1, IP
5246             NCP = NCP+JSSH(I)
5247 *           WRITE(6,*)' PROJ.NUCL. ',I,' NCOLL = ',NCP
5248     8 CONTINUE
5249       write(6,*) "why this (1)", NCP, NCT
5250          DO 9 I=1, IT
5251             NCT = NCT +JTSH(I)
5252 *           WRITE(6,*)' TAR.NUCL. ',I,' NCOLL = ',NCT
5253     9 CONTINUE
5254        ENDIF
5255
5256 * force diffractive particle production in h-K interactions
5257       IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND.
5258      &    (IP.EQ.1).AND.(NN.NE.1)) THEN
5259          NEVOLD = 0
5260          GOTO 10
5261       ENDIF
5262
5263 * check number of involved proj. nucl. (NP) if central prod.is requested
5264       IF (ICENTR.GT.0) THEN
5265          CALL DT_CHKCEN(IP,IT,NP,NT,IBACK)
5266          IF (IBACK.GT.0) GOTO 10
5267       ENDIF
5268
5269 * get initial nucleon-configuration in projectile and target
5270 * rest-system (including Fermi-momenta if requested)
5271       CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1)
5272       MODE = 2
5273       IF (EPROJ.LE.EHADTH) MODE = 3
5274       CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE)
5275
5276       IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN
5277
5278 * activate HADRIN at low energies (implemented for h-N scattering only)
5279          IF (EPROJ.LE.EHADHI) THEN
5280             IF (EHADTH.LT.ZERO) THEN
5281 *   smooth transition btwn. DPM and HADRIN
5282                FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO)
5283                RR   = DT_RNDM(FRAC)
5284                IF (RR.GT.FRAC) THEN
5285                   IF (IP.EQ.1) THEN
5286                      CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5287                      IF (IREJ1.GT.0) GOTO 1
5288                      RETURN
5289                   ELSE
5290                      WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5291                   ENDIF
5292                ENDIF
5293             ELSE
5294 *   fixed threshold for onset of production via HADRIN
5295                IF (EPROJ.LE.EHADTH) THEN
5296                   IF (IP.EQ.1) THEN
5297                      CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5298                      IF (IREJ1.GT.0) GOTO 1
5299                      RETURN
5300                   ELSE
5301                      WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5302                   ENDIF
5303                ENDIF
5304             ENDIF
5305          ENDIF
5306  1001    FORMAT(1X,'KKEVNT:   warning! interaction of proj. (m=',
5307      &          I3,') with target (m=',I3,')',/,11X,
5308      &          'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1,
5309      &          'GeV) cannot be handled')
5310
5311 * sampling of momentum-x fractions & flavors of chain ends
5312          CALL DT_SPLPTN(NN)
5313
5314 * Lorentz-transformation of wounded nucleons into nucl.-nucl. cms
5315          CALL DT_NUC2CM
5316
5317 * collect momenta of chain ends and put them into DTEVT1
5318          CALL DT_GETPTN(IP,NN,NCSY,IREJ1)
5319          IF (IREJ1.NE.0) GOTO 1
5320
5321       ENDIF
5322
5323 * handle chains including fragmentation (two-chain approximation)
5324       IF (MCGENE.EQ.1) THEN
5325 *  two-chain approximation
5326          CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1)
5327          IF (IREJ1.NE.0) THEN
5328             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT'
5329             GOTO 1
5330          ENDIF
5331       ELSEIF (MCGENE.EQ.2) THEN
5332 *  multiple-Po exchange including minijets
5333          CALL DT_EVENTB(NCSY,IREJ1)
5334          IF (IREJ1.NE.0) THEN
5335             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT'
5336             GOTO 1
5337          ENDIF
5338       ELSEIF (MCGENE.EQ.3) THEN
5339          STOP ' This version does not contain LEPTO !'
5340       ELSEIF (MCGENE.EQ.4) THEN
5341 *  quasi-elastic neutrino scattering
5342          CALL DT_EVENTD(IREJ1)
5343          IF (IREJ1.NE.0) THEN
5344             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT'
5345             GOTO 1
5346          ENDIF
5347       ELSE
5348          WRITE(LOUT,1002) MCGENE
5349  1002    FORMAT(1X,'KKEVNT:   warning! event-generator',I4,
5350      &         ' not available - program stopped')
5351          STOP
5352       ENDIF
5353
5354       RETURN
5355
5356  9999 CONTINUE
5357       IREJ = 1
5358       RETURN
5359       END
5360
5361 *$ CREATE DT_CHKCEN.FOR
5362 *COPY DT_CHKCEN
5363 *
5364 *===chkcen=============================================================*
5365 *
5366       SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK)
5367
5368 ************************************************************************
5369 * Check of number of involved projectile nucleons if central production*
5370 * is requested.                                                        *
5371 * Adopted from a part of the old KKEVT routine which was written by    *
5372 * J. Ranft/H.-J.Moehring.                                              *
5373 * This version dated 13.01.95 is written by S. Roesler                 *
5374 ************************************************************************
5375
5376       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5377       SAVE
5378       PARAMETER ( LINP = 10 ,
5379      &            LOUT = 6 ,
5380      &            LDAT = 9 )
5381
5382 * statistics
5383       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5384      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5385      &                ICEVTG(8,0:30)
5386 * central particle production, impact parameter biasing
5387       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5388
5389       IBACK = 0
5390
5391 * old version
5392       IF (ICENTR.EQ.2) THEN
5393          IF (IP.LT.IT) THEN
5394             IF (IP.LE.8) THEN
5395                IF (NP.LT.IP-1) IBACK = 1
5396             ELSEIF (IP.LE.16) THEN
5397                IF (NP.LT.IP-2) IBACK = 1
5398             ELSEIF (IP.LE.32) THEN
5399                IF (NP.LT.IP-3) IBACK = 1
5400             ELSEIF (IP.GE.33) THEN
5401                IF (NP.LT.IP-5) IBACK = 1
5402             ENDIF
5403          ELSEIF (IP.EQ.IT) THEN
5404             IF (IP.EQ.32) THEN
5405                IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5406             ELSE
5407                IF (NP.LT.IP-IP/8) IBACK = 1
5408             ENDIF
5409          ELSEIF (ABS(IP-IT).LT.3) THEN
5410             IF (NP.LT.IP-IP/8) IBACK = 1
5411          ENDIF
5412       ELSE
5413 * new version (DPMJET, 5.6.99)
5414          IF (IP.LT.IT) THEN
5415             IF (IP.LE.8) THEN
5416                IF (NP.LT.IP-1) IBACK = 1
5417             ELSEIF (IP.LE.16) THEN
5418                IF (NP.LT.IP-2) IBACK = 1
5419             ELSEIF (IP.LT.32) THEN
5420                IF (NP.LT.IP-3) IBACK = 1
5421             ELSEIF (IP.GE.32) THEN
5422                IF (IT.LE.150) THEN
5423 *   Example: S-Ag
5424                   IF (NP.LT.IP-1) IBACK = 1
5425                ELSE
5426 *   Example: S-Au
5427                   IF (NP.LT.IP) IBACK = 1
5428                ENDIF
5429             ENDIF
5430          ELSEIF (IP.EQ.IT) THEN
5431 *   Example: S-S
5432            IF (IP.EQ.32) THEN
5433               IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5434 *   Example: Pb-Pb
5435            ELSE
5436               IF (NP.LT.IP-IP/4) IBACK = 1
5437            ENDIF
5438          ELSEIF (ABS(IP-IT).LT.3) THEN
5439             IF (NP.LT.IP-IP/8) IBACK = 1
5440          ENDIF
5441       ENDIF
5442
5443       ICCPRO = ICCPRO+1
5444
5445       RETURN
5446       END
5447
5448 *$ CREATE DT_ININUC.FOR
5449 *COPY DT_ININUC
5450 *
5451 *===ininuc=============================================================*
5452 *
5453       SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE)
5454
5455 ************************************************************************
5456 * Samples initial configuration of nucleons in nucleus with mass NMASS *
5457 * including Fermi-momenta (if reqested).                               *
5458 *          ID             BAMJET-code for hadrons (instead of nuclei)  *
5459 *          NMASS          mass number of nucleus (number of nucleons)  *
5460 *          NCH            charge of nucleus                            *
5461 *          COORD(3,NMASS) coordinates of nucleons inside nucleus in fm *
5462 *          JS(NMASS) > 0  nucleon undergoes nucleon-nucleon interact.  *
5463 *          IMODE = 1      projectile nucleus                           *
5464 *                = 2      target     nucleus                           *
5465 *                = 3      target     nucleus (E_lab<E_thr for HADRIN)  *
5466 * Adopted from a part of the old KKEVT routine which was written by    *
5467 * J. Ranft/H.-J.Moehring.                                              *
5468 * This version dated 13.01.95 is written by S. Roesler                 *
5469 ************************************************************************
5470
5471       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5472       SAVE
5473       PARAMETER ( LINP = 10 ,
5474      &            LOUT = 6 ,
5475      &            LDAT = 9 )
5476       PARAMETER (FM2MM=1.0D-12)
5477
5478       PARAMETER ( MAXNCL = 260,
5479      &            MAXVQU = MAXNCL,
5480      &            MAXSQU = 20*MAXVQU,
5481      &            MAXINT = MAXVQU+MAXSQU)
5482 * event history
5483       PARAMETER (NMXHKK=200000)
5484       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5485      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5486      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5487 * extended event history
5488       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5489      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5490      &                IHIST(2,NMXHKK)
5491 * flags for input different options
5492       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5493       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5494      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5495 * auxiliary common for chain system storage (DTUNUC 1.x)
5496       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5497 * nuclear potential
5498       LOGICAL LFERMI
5499       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5500      &                EBINDP(2),EBINDN(2),EPOT(2,210),
5501      &                ETACOU(2),ICOUL,LFERMI
5502 * properties of photon/lepton projectiles
5503       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5504 * particle properties (BAMJET index convention)
5505       CHARACTER*8  ANAME
5506       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5507      &                IICH(210),IIBAR(210),K1(210),K2(210)
5508 * Glauber formalism: collision properties
5509       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5510      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
5511      &                NCP,NCT
5512 * flavors of partons (DTUNUC 1.x)
5513       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5514      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5515      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
5516      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5517      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
5518      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5519      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
5520 * interface HADRIN-DPM
5521       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5522
5523       DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL)
5524
5525 * number of neutrons
5526       NNEU = NMASS-NCH
5527 * initializations
5528       NP = 0
5529       NN = 0
5530       DO 1 K=1,4
5531          PFTOT(K) = 0.0D0
5532     1 CONTINUE
5533       MODE   = IMODE
5534       IF (IMODE.GT.2) MODE = 2
5535 **sr 29.5. new NPOINT(1)-definition
5536 C     IF (IMODE.GE.2) NPOINT(1) = NHKK+1
5537 **
5538       NHADRI = 0
5539       NC     = NHKK
5540
5541 * get initial configuration
5542       DO 2 I=1,NMASS
5543          NHKK = NHKK+1
5544          IF (JS(I).GT.0) THEN
5545             ISTHKK(NHKK) = 10+MODE
5546             IF (IMODE.EQ.3) THEN
5547 *   additional treatment if HADRIN-generator is requested
5548                NHADRI = NHADRI+1
5549                IF (NHADRI.EQ.1) IDXTA  = NHKK
5550                IF (NHADRI.GT.1) ISTHKK(NHKK) = 14
5551             ENDIF
5552          ELSE
5553             ISTHKK(NHKK) = 12+MODE
5554          ENDIF
5555          IF (NMASS.GE.2) THEN
5556 *   treatment for nuclei
5557             FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS)
5558             RR   = DT_RNDM(FRAC)
5559             IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN
5560                IDX = 8
5561                NN  = NN+1
5562             ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN
5563                IDX = 1
5564                NP  = NP+1
5565             ELSEIF (NN.LT.NNEU) THEN
5566                IDX = 8
5567                NN  = NN+1
5568             ELSEIF (NP.LT.NCH)  THEN
5569                IDX = 1
5570                NP  = NP+1
5571             ENDIF
5572             IDHKK(NHKK) = IDT_IPDGHA(IDX)
5573             IDBAM(NHKK) = IDX
5574             IF (MODE.EQ.1) THEN
5575                IPOSP(I)  = NHKK
5576                KKPROJ(I) = IDX
5577             ELSE
5578                IPOST(I)  = NHKK
5579                KKTARG(I) = IDX
5580             ENDIF
5581             IF (IDX.EQ.1) THEN
5582                PFER = PFERMP(MODE)
5583                PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1))
5584             ELSE
5585                PFER = PFERMN(MODE)
5586                PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8))
5587             ENDIF
5588             CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX)
5589             DO 3 K=1,4
5590                PFTOT(K) = PFTOT(K)+PF(K)
5591                PHKK(K,NHKK) = PF(K)
5592     3       CONTINUE
5593             PHKK(5,NHKK) = AAM(IDX)
5594          ELSE
5595 *   treatment for hadrons
5596             IDHKK(NHKK)  = IDT_IPDGHA(ID)
5597             IDBAM(NHKK)  = ID
5598             PHKK(4,NHKK) = AAM(ID)
5599             PHKK(5,NHKK) = AAM(ID)
5600 C* VDM assumption
5601 C            IF (IDHKK(NHKK).EQ.22) THEN
5602 C               PHKK(4,NHKK) = AAM(33)
5603 C               PHKK(5,NHKK) = AAM(33)
5604 C            ENDIF
5605             IF (MODE.EQ.1) THEN
5606                IPOSP(I)  = NHKK
5607                KKPROJ(I) = ID
5608                PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
5609             ELSE
5610                IPOST(I)  = NHKK
5611                KKTARG(I) = ID
5612             ENDIF
5613          ENDIF
5614          DO 4 K=1,3
5615             VHKK(K,NHKK) = COORD(K,I)*FM2MM
5616             WHKK(K,NHKK) = COORD(K,I)*FM2MM
5617     4    CONTINUE
5618          IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM
5619          IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM
5620          VHKK(4,NHKK) = 0.0D0
5621          WHKK(4,NHKK) = 0.0D0
5622     2 CONTINUE
5623
5624 * balance Fermi-momenta
5625       IF (NMASS.GE.2) THEN
5626          DO 5 I=1,NMASS
5627             NC = NC+1
5628             DO 6 K=1,3
5629                PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
5630     6       CONTINUE
5631             PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
5632      &                        PHKK(2,NC)**2+PHKK(3,NC)**2)
5633     5    CONTINUE
5634       ENDIF
5635
5636       RETURN
5637       END
5638
5639 *$ CREATE DT_FER4M.FOR
5640 *COPY DT_FER4M
5641 *
5642 *===fer4m==============================================================*
5643 *
5644       SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
5645
5646 ************************************************************************
5647 * Sampling of nucleon Fermi-momenta from distributions at T=0.         *
5648 *                                   processed by S. Roesler, 17.10.95  *
5649 ************************************************************************
5650
5651       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5652       SAVE
5653       PARAMETER ( LINP = 10 ,
5654      &            LOUT = 6 ,
5655      &            LDAT = 9 )
5656
5657       LOGICAL LSTART
5658
5659 * particle properties (BAMJET index convention)
5660       CHARACTER*8  ANAME
5661       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5662      &                IICH(210),IIBAR(210),K1(210),K2(210)
5663 * nuclear potential
5664       LOGICAL LFERMI
5665       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5666      &                EBINDP(2),EBINDN(2),EPOT(2,210),
5667      &                ETACOU(2),ICOUL,LFERMI
5668
5669       DATA LSTART /.TRUE./
5670
5671       ILOOP = 0
5672       IF (LFERMI) THEN
5673          IF (LSTART) THEN
5674             WRITE(LOUT,1000)
5675  1000       FORMAT(/,1X,'FER4M:   sampling of Fermi-momenta activated')
5676             LSTART = .FALSE.
5677          ENDIF
5678     1    CONTINUE
5679          CALL DT_DFERMI(PABS)
5680          PABS = PFERM*PABS
5681 C        IF (PABS.GE.PBIND) THEN
5682 C           ILOOP = ILOOP+1
5683 C           IF (MOD(ILOOP,500).EQ.0) THEN
5684 C              WRITE(LOUT,1001) PABS,PBIND,ILOOP
5685 C1001          FORMAT(1X,'FER4M:    Fermi-mom. corr. for binding',
5686 C    &                ' energy ',2E12.3,I6)
5687 C           ENDIF
5688 C           GOTO 1
5689 C        ENDIF
5690          CALL DT_DPOLI(POLC,POLS)
5691          CALL DT_DSFECF(SFE,CFE)
5692          CXTA = POLS*CFE
5693          CYTA = POLS*SFE
5694          CZTA = POLC
5695          ET   = SQRT(PABS*PABS+AAM(KT)**2)
5696          PXT  = CXTA*PABS
5697          PYT  = CYTA*PABS
5698          PZT  = CZTA*PABS
5699       ELSE
5700          ET   = AAM(KT)
5701          PXT  = 0.0D0
5702          PYT  = 0.0D0
5703          PZT  = 0.0D0
5704       ENDIF
5705
5706       RETURN
5707       END
5708
5709 *$ CREATE DT_NUC2CM.FOR
5710 *COPY DT_NUC2CM
5711 *
5712 *===nuc2cm=============================================================*
5713 *
5714       SUBROUTINE DT_NUC2CM
5715
5716 ************************************************************************
5717 * Lorentz-transformation of all wounded nucleons from Lab. to nucl.-   *
5718 * nucl. cms. (This subroutine replaces NUCMOM.)                        *
5719 * This version dated 15.01.95 is written by S. Roesler                 *
5720 ************************************************************************
5721
5722       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5723       SAVE
5724       PARAMETER ( LINP = 10 ,
5725      &            LOUT = 6 ,
5726      &            LDAT = 9 )
5727       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
5728
5729 * event history
5730       PARAMETER (NMXHKK=200000)
5731       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5732      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5733      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5734 * extended event history
5735       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5736      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5737      &                IHIST(2,NMXHKK)
5738 * statistics
5739       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5740      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5741      &                ICEVTG(8,0:30)
5742 * properties of photon/lepton projectiles
5743       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5744 * particle properties (BAMJET index convention)
5745       CHARACTER*8  ANAME
5746       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5747      &                IICH(210),IIBAR(210),K1(210),K2(210)
5748 * Glauber formalism: collision properties
5749       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5750      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
5751      &                NCP,NCT
5752 **temporary
5753 * statistics: Glauber-formalism
5754       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5755 **
5756
5757       ICWP = 0
5758       ICWT = 0
5759       NWTACC = 0
5760       NWAACC = 0
5761       NWBACC = 0
5762
5763       NPOINT(1) = NHKK+1
5764       NEND      = NHKK
5765       DO 1 I=1,NEND
5766          IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN
5767             IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1
5768             IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1
5769             MODE = ISTHKK(I)-9
5770 C            IF (IDHKK(I).EQ.22) THEN
5771 C* VDM assumption
5772 C               PEIN = AAM(33)
5773 C               IDB  = 33
5774 C            ELSE
5775 C               PEIN = PHKK(4,I)
5776 C               IDB  = IDBAM(I)
5777 C            ENDIF
5778 C            CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
5779 C     &           PX,PY,PZ,PE,IDB,MODE)
5780             IF (PHKK(5,I).GT.ZERO) THEN
5781                CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
5782      &              PX,PY,PZ,PE,IDBAM(I),MODE)
5783             ELSE
5784                PX = PGAMM(1)
5785                PY = PGAMM(2)
5786                PZ = PGAMM(3)
5787                PE = PGAMM(4)
5788             ENDIF
5789             IST = ISTHKK(I)-2
5790             ID  = IDHKK(I)
5791 C* VDM assumption
5792 C            IF (ID.EQ.22) ID = 113
5793             CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0)
5794             IF (ISTHKK(I).EQ.11) ICWP = ICWP+1
5795             IF (ISTHKK(I).EQ.12) ICWT = ICWT+1
5796          ENDIF
5797     1 CONTINUE
5798
5799       NWTACC = MAX(NWAACC,NWBACC)
5800       ICDPR  = ICDPR+ICWP
5801       ICDTA  = ICDTA+ICWT
5802 **temporary
5803       IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
5804          CALL DT_EVTOUT(4)
5805          STOP
5806       ENDIF
5807
5808       RETURN
5809       END
5810
5811 *$ CREATE DT_SPLPTN.FOR
5812 *COPY DT_SPLPTN
5813 *
5814 *===splptn=============================================================*
5815 *
5816       SUBROUTINE DT_SPLPTN(NN)
5817
5818 ************************************************************************
5819 * SamPLing of ParToN momenta and flavors.                              *
5820 * This version dated 15.01.95 is written by S. Roesler                 *
5821 ************************************************************************
5822
5823       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5824       SAVE
5825       PARAMETER ( LINP = 10 ,
5826      &            LOUT = 6 ,
5827      &            LDAT = 9 )
5828
5829 * Lorentz-parameters of the current interaction
5830       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5831      &                UMO,PPCM,EPROJ,PPROJ
5832
5833 * sample flavors of sea-quarks
5834       CALL DT_SPLFLA(NN,1)
5835
5836 * sample x-values of partons at chain ends
5837       ECM = UMO
5838       CALL DT_XKSAMP(NN,ECM)
5839
5840 * samle flavors
5841       CALL DT_SPLFLA(NN,2)
5842
5843       RETURN
5844       END
5845
5846 *$ CREATE DT_SPLFLA.FOR
5847 *COPY DT_SPLFLA
5848 *
5849 *===splfla=============================================================*
5850 *
5851       SUBROUTINE DT_SPLFLA(NN,MODE)
5852
5853 ************************************************************************
5854 * SamPLing of FLAvors of partons at chain ends.                        *
5855 * This subroutine replaces FLKSAA/FLKSAM.                              *
5856 *            NN            number of nucleon-nucleon interactions      *
5857 *            MODE = 1      sea-flavors                                 *
5858 *                 = 2      valence-flavors                             *
5859 * Based on the original version written by J. Ranft/H.-J. Moehring.    *
5860 * This version dated 16.01.95 is written by S. Roesler                 *
5861 ************************************************************************
5862
5863       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5864       SAVE
5865       PARAMETER ( LINP = 10 ,
5866      &            LOUT = 6 ,
5867      &            LDAT = 9 )
5868
5869       PARAMETER ( MAXNCL = 260,
5870      &            MAXVQU = MAXNCL,
5871      &            MAXSQU = 20*MAXVQU,
5872      &            MAXINT = MAXVQU+MAXSQU)
5873 * flavors of partons (DTUNUC 1.x)
5874       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5875      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5876      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
5877      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5878      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
5879      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5880      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
5881 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5882       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
5883      &                IXPV,IXPS,IXTV,IXTS,
5884      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
5885      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
5886      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
5887      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
5888      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
5889      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
5890      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
5891      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
5892 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5893       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
5894      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
5895 * particle properties (BAMJET index convention)
5896       CHARACTER*8  ANAME
5897       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5898      &                IICH(210),IIBAR(210),K1(210),K2(210)
5899 * various options for treatment of partons (DTUNUC 1.x)
5900 * (chain recombination, Cronin,..)
5901       LOGICAL LCO2CR,LINTPT
5902       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
5903      &                LCO2CR,LINTPT
5904
5905       IF (MODE.EQ.1) THEN
5906 * sea-flavors
5907          DO 1 I=1,NN
5908             IPSQ(I)  = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5909             IPSAQ(I) = -IPSQ(I)
5910     1    CONTINUE
5911          DO 2 I=1,NN
5912             ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5913             ITSAQ(I)= -ITSQ(I)
5914     2    CONTINUE
5915       ELSEIF (MODE.EQ.2) THEN
5916 * valence flavors
5917          DO 3 I=1,IXPV
5918             CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
5919     3    CONTINUE
5920          DO 4 I=1,IXTV
5921             CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
5922     4    CONTINUE
5923       ENDIF
5924
5925       RETURN
5926       END
5927
5928 *$ CREATE DT_GETPTN.FOR
5929 *COPY DT_GETPTN
5930 *
5931 *===getptn=============================================================*
5932 *
5933       SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
5934
5935 ************************************************************************
5936 * This subroutine collects partons at chain ends from temporary        *
5937 * commons and puts them into DTEVT1.                                   *
5938 * This version dated 15.01.95 is written by S. Roesler                 *
5939 ************************************************************************
5940
5941       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5942       SAVE
5943       PARAMETER ( LINP = 10 ,
5944      &            LOUT = 6 ,
5945      &            LDAT = 9 )
5946       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
5947
5948       LOGICAL LCHK
5949
5950       PARAMETER ( MAXNCL = 260,
5951      &            MAXVQU = MAXNCL,
5952      &            MAXSQU = 20*MAXVQU,
5953      &            MAXINT = MAXVQU+MAXSQU)
5954 * event history
5955       PARAMETER (NMXHKK=200000)
5956       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5957      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5958      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5959 * extended event history
5960       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5961      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5962      &                IHIST(2,NMXHKK)
5963 * flags for input different options
5964       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5965       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5966      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5967 * auxiliary common for chain system storage (DTUNUC 1.x)
5968       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5969 * statistics
5970       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5971      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5972      &                ICEVTG(8,0:30)
5973 * flags for diffractive interactions (DTUNUC 1.x)
5974       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5975 * x-values of partons (DTUNUC 1.x)
5976       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
5977      &                XTVQ(MAXVQU),XTVD(MAXVQU),
5978      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
5979      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
5980 * flavors of partons (DTUNUC 1.x)
5981       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5982      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5983      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
5984      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5985      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
5986      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5987      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
5988 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5989       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
5990      &                IXPV,IXPS,IXTV,IXTS,
5991      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
5992      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
5993      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
5994      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
5995      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
5996      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
5997      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
5998      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
5999 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6000       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
6001      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
6002
6003       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
6004
6005       DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
6006
6007       IREJ      = 0
6008       NCSY      = 0
6009       NPOINT(2) = NHKK+1
6010
6011 * sea-sea chains
6012       DO 10 I=1,NSS
6013          IF (ISKPCH(1,I).EQ.99) GOTO 10
6014          ICCHAI(1,1) = ICCHAI(1,1)+2
6015          IDXP = INTSS1(I)
6016          IDXT = INTSS2(I)
6017          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6018          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6019          DO 11 K=1,4
6020             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6021             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6022             PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6023             PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6024    11    CONTINUE
6025          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6026      &                                  +(PP1(3)+PT1(3))**2)
6027          ECH   = PP1(4)+PT1(4)
6028          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6029          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6030      &                                  +(PP2(3)+PT2(3))**2)
6031          ECH   = PP2(4)+PT2(4)
6032          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6033          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6034             AM1 = SQRT(AM1)
6035             AM2 = SQRT(AM2)
6036             IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
6037 C              WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6038  5000          FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
6039             ENDIF
6040          ELSE
6041             WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6042          ENDIF
6043          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6044          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6045          IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6046          IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6047          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6048      &                                                    0,0,1)
6049          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6050      &                                                    0,0,1)
6051          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6052      &                                                    0,0,1)
6053          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6054      &                                                    0,0,1)
6055          NCSY = NCSY+1
6056    10 CONTINUE
6057
6058 * disea-sea chains
6059       DO 20 I=1,NDS
6060          IF (ISKPCH(2,I).EQ.99) GOTO 20
6061          ICCHAI(1,2) = ICCHAI(1,2)+2
6062          IDXP = INTDS1(I)
6063          IDXT = INTDS2(I)
6064          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6065          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6066          DO 21 K=1,4
6067             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6068             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6069             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6070             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6071    21    CONTINUE
6072          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6073      &                                  +(PP1(3)+PT1(3))**2)
6074          ECH   = PP1(4)+PT1(4)
6075          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6076          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6077      &                                  +(PP2(3)+PT2(3))**2)
6078          ECH   = PP2(4)+PT2(4)
6079          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6080          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6081             AM1 = SQRT(AM1)
6082             AM2 = SQRT(AM2)
6083             IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6084 C              WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6085  5001          FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
6086             ENDIF
6087          ELSE
6088             WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6089          ENDIF
6090          IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6091          IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6092          IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6093          IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6094          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6095      &                                                    0,0,2)
6096          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6097      &                                                    0,0,2)
6098          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6099      &                                                    0,0,2)
6100          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6101      &                                                    0,0,2)
6102          NCSY = NCSY+1
6103    20 CONTINUE
6104
6105 * sea-disea chains
6106       DO 30 I=1,NSD
6107          IF (ISKPCH(3,I).EQ.99) GOTO 30
6108          ICCHAI(1,3) = ICCHAI(1,3)+2
6109          IDXP = INTSD1(I)
6110          IDXT = INTSD2(I)
6111          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6112          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6113          DO 31 K=1,4
6114             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6115             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6116             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6117             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6118    31    CONTINUE
6119          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6120      &                                  +(PP1(3)+PT1(3))**2)
6121          ECH   = PP1(4)+PT1(4)
6122          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6123          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6124      &                                  +(PP2(3)+PT2(3))**2)
6125          ECH   = PP2(4)+PT2(4)
6126          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6127          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6128             AM1 = SQRT(AM1)
6129             AM2 = SQRT(AM2)
6130             IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6131 C              WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6132  5002          FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
6133             ENDIF
6134          ELSE
6135             WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6136          ENDIF
6137          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6138          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6139          IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6140          IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6141          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6142      &                                                    0,0,3)
6143          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6144      &                                                    0,0,3)
6145          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6146      &                                                    0,0,3)
6147          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6148      &                                                    0,0,3)
6149          NCSY = NCSY+1
6150    30 CONTINUE
6151
6152 * disea-valence chains
6153       DO 50 I=1,NDV
6154          IF (ISKPCH(5,I).EQ.99) GOTO 50
6155          ICCHAI(1,5) = ICCHAI(1,5)+2
6156          IDXP = INTDV1(I)
6157          IDXT = INTDV2(I)
6158          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6159          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6160          DO 51 K=1,4
6161             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6162             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6163             PT1(K) = XTVQ(IDXT) *PHKK(K,MOT)
6164             PT2(K) = XTVD(IDXT) *PHKK(K,MOT)
6165    51    CONTINUE
6166          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6167      &                                  +(PP1(3)+PT1(3))**2)
6168          ECH   = PP1(4)+PT1(4)
6169          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6170          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6171      &                                  +(PP2(3)+PT2(3))**2)
6172          ECH   = PP2(4)+PT2(4)
6173          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6174          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6175             AM1 = SQRT(AM1)
6176             AM2 = SQRT(AM2)
6177             IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6178 C              WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6179  5003          FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
6180             ENDIF
6181          ELSE
6182             WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6183          ENDIF
6184          IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6185          IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6186          IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6187          IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6188          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6189      &                                                    0,0,5)
6190          CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6191      &                                                    0,0,5)
6192          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6193      &                                                    0,0,5)
6194          CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6195      &                                                    0,0,5)
6196          NCSY = NCSY+1
6197    50 CONTINUE
6198
6199 * valence-sea chains
6200       DO 60 I=1,NVS
6201          IF (ISKPCH(6,I).EQ.99) GOTO 60
6202          ICCHAI(1,6) = ICCHAI(1,6)+2
6203          IDXP = INTVS1(I)
6204          IDXT = INTVS2(I)
6205          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6206          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6207          DO 61 K=1,4
6208             PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6209             PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6210             PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6211             PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6212    61    CONTINUE
6213          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6214          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6215          IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6216          IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6217          CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6218          IF (LCHK) THEN
6219             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6220      &                                                       0,0,6)
6221             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6222      &                                                       0,0,6)
6223             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6224      &                                                       0,0,6)
6225             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6226      &                                                       0,0,6)
6227             PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6228      &                                     +(PP1(3)+PT1(3))**2)
6229             ECH   = PP1(4)+PT1(4)
6230             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6231             PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6232      &                                     +(PP2(3)+PT2(3))**2)
6233             ECH   = PP2(4)+PT2(4)
6234             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6235          ELSE
6236             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6237      &                                                       0,0,6)
6238             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6239      &                                                       0,0,6)
6240             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6241      &                                                       0,0,6)
6242             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6243      &                                                       0,0,6)
6244             PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6245      &                                     +(PP1(3)+PT2(3))**2)
6246             ECH   = PP1(4)+PT2(4)
6247             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6248             PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6249      &                                     +(PP2(3)+PT1(3))**2)
6250             ECH   = PP2(4)+PT1(4)
6251             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6252          ENDIF
6253          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6254             AM1 = SQRT(AM1)
6255             AM2 = SQRT(AM2)
6256             IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
6257 C              WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6258  5004          FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
6259             ENDIF
6260          ELSE
6261             WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6262          ENDIF
6263          NCSY = NCSY+1
6264    60 CONTINUE
6265
6266 * sea-valence chains
6267       DO 40 I=1,NSV
6268          IF (ISKPCH(4,I).EQ.99) GOTO 40
6269          ICCHAI(1,4) = ICCHAI(1,4)+2
6270          IDXP = INTSV1(I)
6271          IDXT = INTSV2(I)
6272          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6273          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6274          DO 41 K=1,4
6275             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6276             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6277             PT1(K) = XTVD(IDXT) *PHKK(K,MOT)
6278             PT2(K) = XTVQ(IDXT) *PHKK(K,MOT)
6279    41    CONTINUE
6280          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6281      &                                  +(PP1(3)+PT1(3))**2)
6282          ECH   = PP1(4)+PT1(4)
6283          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6284          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6285      &                                  +(PP2(3)+PT2(3))**2)
6286          ECH   = PP2(4)+PT2(4)
6287          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6288          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6289             AM1 = SQRT(AM1)
6290             AM2 = SQRT(AM2)
6291             IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
6292 C              WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6293  5005          FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
6294             ENDIF
6295          ELSE
6296             WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6297          ENDIF
6298          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6299          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6300          IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6301          IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6302          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6303      &                                                    0,0,4)
6304          CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6305      &                                                    0,0,4)
6306          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6307      &                                                    0,0,4)
6308          CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6309      &                                                    0,0,4)
6310          NCSY = NCSY+1
6311    40 CONTINUE
6312
6313 * valence-disea chains
6314       DO 70 I=1,NVD
6315          IF (ISKPCH(7,I).EQ.99) GOTO 70
6316          ICCHAI(1,7) = ICCHAI(1,7)+2
6317          IDXP = INTVD1(I)
6318          IDXT = INTVD2(I)
6319          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6320          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6321          DO 71 K=1,4
6322             PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6323             PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6324             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6325             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6326    71    CONTINUE
6327          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6328          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6329          IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6330          IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6331          CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6332          IF (LCHK) THEN
6333             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6334      &                                                       0,0,7)
6335             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6336      &                                                       0,0,7)
6337             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6338      &                                                       0,0,7)
6339             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6340      &                                                       0,0,7)
6341             PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6342      &                                     +(PP1(3)+PT1(3))**2)
6343             ECH   = PP1(4)+PT1(4)
6344             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6345             PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6346      &                                     +(PP2(3)+PT2(3))**2)
6347             ECH   = PP2(4)+PT2(4)
6348             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6349          ELSE
6350             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6351      &                                                       0,0,7)
6352             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6353      &                                                       0,0,7)
6354             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6355      &                                                       0,0,7)
6356             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6357      &                                                       0,0,7)
6358             PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6359      &                                     +(PP1(3)+PT2(3))**2)
6360             ECH   = PP1(4)+PT2(4)
6361             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6362             PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6363      &                                     +(PP2(3)+PT1(3))**2)
6364             ECH   = PP2(4)+PT1(4)
6365             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6366          ENDIF
6367          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6368             AM1 = SQRT(AM1)
6369             AM2 = SQRT(AM2)
6370             IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6371 C              WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6372  5006          FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
6373             ENDIF
6374          ELSE
6375             WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6376          ENDIF
6377          NCSY = NCSY+1
6378    70 CONTINUE
6379
6380 * valence-valence chains
6381       DO 80 I=1,NVV
6382          IF (ISKPCH(8,I).EQ.99) GOTO 80
6383          ICCHAI(1,8) = ICCHAI(1,8)+2
6384          IDXP = INTVV1(I)
6385          IDXT = INTVV2(I)
6386          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6387          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6388          DO 81 K=1,4
6389             PP1(K) = XPVQ(IDXP)*PHKK(K,MOP)
6390             PP2(K) = XPVD(IDXP)*PHKK(K,MOP)
6391             PT1(K) = XTVD(IDXT)*PHKK(K,MOT)
6392             PT2(K) = XTVQ(IDXT)*PHKK(K,MOT)
6393    81    CONTINUE
6394          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6395          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6396          IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6397          IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6398
6399 * check for diffractive event
6400          IDIFF = 0
6401          IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
6402      &        (IP.EQ.1).AND.(NN.EQ.1)) THEN
6403             DO 800 K=1,4
6404                PP(K) = PP1(K)+PP2(K)
6405                PT(K) = PT1(K)+PT2(K)
6406   800       CONTINUE
6407             ISTCK = NHKK
6408             CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
6409      &                  IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
6410 C           IF (IREJ1.NE.0) GOTO 9999
6411             IF (IREJ1.NE.0) THEN
6412                IDIFF = 0
6413                NHKK  = ISTCK
6414             ENDIF
6415          ELSE
6416             IDIFF = 0
6417          ENDIF
6418
6419          IF (IDIFF.EQ.0) THEN
6420 *   valence-valence chain system
6421             CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6422             IF (LCHK) THEN
6423 *    baryon-baryon
6424                CALL DT_EVTPUT(-21,IFP1,MOP,0,
6425      &                     PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6426                CALL DT_EVTPUT(-22,IFT1,MOT,0,
6427      &                     PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6428                CALL DT_EVTPUT(-21,IFP2,MOP,0,
6429      &                     PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6430                CALL DT_EVTPUT(-22,IFT2,MOT,0,
6431      &                     PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6432                PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6433      &                                        +(PP1(3)+PT1(3))**2)
6434                ECH   = PP1(4)+PT1(4)
6435                AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6436                PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6437      &                                        +(PP2(3)+PT2(3))**2)
6438                ECH   = PP2(4)+PT2(4)
6439                AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6440             ELSE
6441 *    antibaryon-baryon
6442                CALL DT_EVTPUT(-21,IFP1,MOP,0,
6443      &                     PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6444                CALL DT_EVTPUT(-22,IFT2,MOT,0,
6445      &                     PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6446                CALL DT_EVTPUT(-21,IFP2,MOP,0,
6447      &                     PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6448                CALL DT_EVTPUT(-22,IFT1,MOT,0,
6449      &                     PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6450                PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6451      &                                        +(PP1(3)+PT2(3))**2)
6452                ECH   = PP1(4)+PT2(4)
6453                AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6454                PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6455      &                                        +(PP2(3)+PT1(3))**2)
6456                ECH   = PP2(4)+PT1(4)
6457                AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6458             ENDIF
6459             IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6460                AM1 = SQRT(AM1)
6461                AM2 = SQRT(AM2)
6462                IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
6463 C                 WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6464  5007             FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
6465                ENDIF
6466             ELSE
6467                WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6468             ENDIF
6469             NCSY = NCSY+1
6470          ENDIF
6471    80 CONTINUE
6472       IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
6473
6474 * energy-momentum & flavor conservation check
6475       IF (ABS(IDIFF).NE.1) THEN
6476          IF (IDIFF.NE.0) THEN
6477             IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0,
6478      &                                              1,3,10,IREJ)
6479          ELSE
6480             IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
6481      &                                              1,3,10,IREJ)
6482          ENDIF
6483          IF (IREJ.NE.0) THEN
6484             CALL DT_EVTOUT(4)
6485             STOP
6486          ENDIF
6487       ENDIF
6488
6489       RETURN
6490
6491  9999 CONTINUE
6492       IREJ  = 1
6493       RETURN
6494       END
6495
6496 *$ CREATE DT_CHKCSY.FOR
6497 *COPY DT_CHKCSY
6498 *
6499 *===chkcsy=============================================================*
6500 *
6501       SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
6502
6503 ************************************************************************
6504 * CHeCk Chain SYstem for consistency of partons at chain ends.         *
6505 *            ID1,ID2        PDG-numbers of partons at chain ends       *
6506 *            LCHK = .true.  consistent chain                           *
6507 *                 = .false. inconsistent chain                         *
6508 * This version dated 18.01.95 is written by S. Roesler                 *
6509 ************************************************************************
6510
6511       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6512       SAVE
6513       PARAMETER ( LINP = 10 ,
6514      &            LOUT = 6 ,
6515      &            LDAT = 9 )
6516
6517       LOGICAL LCHK
6518
6519       LCHK = .TRUE.
6520
6521 * q-aq chain
6522       IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN
6523          IF (ID1*ID2.GT.0) LCHK = .FALSE.
6524 * q-qq, aq-aqaq chain
6525       ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR.
6526      &        ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN
6527          IF (ID1*ID2.LT.0) LCHK = .FALSE.
6528 * qq-aqaq chain
6529       ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
6530          IF (ID1*ID2.GT.0) LCHK = .FALSE.
6531       ENDIF
6532
6533       RETURN
6534       END
6535
6536 *$ CREATE DT_EVENTA.FOR
6537 *COPY DT_EVENTA
6538 *
6539 *===eventa=============================================================*
6540 *
6541       SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
6542
6543 ************************************************************************
6544 * Treatment of nucleon-nucleon interactions in a two-chain             *
6545 * approximation.                                                       *
6546 *  (input) ID       BAMJET-index of projectile hadron (in case of      *
6547 *                   h-K scattering)                                    *
6548 *          IP/IT    mass number of projectile/target nucleus           *
6549 *          NCSY     number of two chain systems                        *
6550 *          IREJ     rejection flag                                     *
6551 * This version dated 15.01.95 is written by S. Roesler                 *
6552 ************************************************************************
6553
6554       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6555       SAVE
6556       PARAMETER ( LINP = 10 ,
6557      &            LOUT = 6 ,
6558      &            LDAT = 9 )
6559       PARAMETER (TINY10=1.0D-10)
6560
6561 * event history
6562       PARAMETER (NMXHKK=200000)
6563       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6564      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6565      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6566 * extended event history
6567       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6568      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6569      &                IHIST(2,NMXHKK)
6570 * rejection counter
6571       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6572      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6573      &                IREXCI(3),IRDIFF(2),IRINC
6574 * flags for diffractive interactions (DTUNUC 1.x)
6575       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6576 * particle properties (BAMJET index convention)
6577       CHARACTER*8  ANAME
6578       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6579      &                IICH(210),IIBAR(210),K1(210),K2(210)
6580 * flags for input different options
6581       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6582       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6583      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6584 * various options for treatment of partons (DTUNUC 1.x)
6585 * (chain recombination, Cronin,..)
6586       LOGICAL LCO2CR,LINTPT
6587       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6588      &                LCO2CR,LINTPT
6589
6590       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
6591
6592       IREJ      = 0
6593       NPOINT(3) = NHKK+1
6594
6595 * skip following treatment for low-mass diffraction
6596       IF (ABS(IFLAGD).EQ.1) THEN
6597          NPOINT(3) = NPOINT(2)
6598          GOTO 5
6599       ENDIF
6600
6601 * multiple scattering of chain ends
6602       IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
6603       IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
6604
6605       NC = NPOINT(2)
6606 * get a two-chain system from DTEVT1
6607       DO 3 I=1,NCSY
6608          IFP1 = IDHKK(NC)
6609          IFT1 = IDHKK(NC+1)
6610          IFP2 = IDHKK(NC+2)
6611          IFT2 = IDHKK(NC+3)
6612          DO 4 K=1,4
6613             PP1(K) = PHKK(K,NC)
6614             PT1(K) = PHKK(K,NC+1)
6615             PP2(K) = PHKK(K,NC+2)
6616             PT2(K) = PHKK(K,NC+3)
6617     4    CONTINUE
6618          MOP1 = NC
6619          MOT1 = NC+1
6620          MOP2 = NC+2
6621          MOT2 = NC+3
6622          CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
6623      &               IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
6624          IF (IREJ1.GT.0) THEN
6625             IRHHA = IRHHA+1
6626             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
6627             GOTO 9999
6628          ENDIF
6629          NC = NC+4
6630     3 CONTINUE
6631
6632 * meson/antibaryon projectile:
6633 * sample single-chain valence-valence systems (Reggeon contrib.)
6634       IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN
6635          IF (IIBAR(ID).LE.0) CALL DT_VV2SCH
6636       ENDIF
6637
6638       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6639 * check DTEVT1 for remaining resonance mass corrections
6640          CALL DT_EVTRES(IREJ1)
6641          IF (IREJ1.GT.0) THEN
6642             IRRES(1) = IRRES(1)+1
6643             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA'
6644             GOTO 9999
6645          ENDIF
6646       ENDIF
6647
6648 * assign p_t to two-"chain" systems consisting of two resonances only
6649 * since only entries for chains will be affected, this is obsolete
6650 * in case of JETSET-fragmetation
6651       CALL DT_RESPT
6652
6653 * combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
6654       IF (LCO2CR) CALL DT_COM2CR
6655
6656     5 CONTINUE
6657
6658 * fragmentation of the complete event
6659 **uncomment for internal phojet-fragmentation
6660 C     CALL DT_EVTFRA(IREJ1)
6661       CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
6662       IF (IREJ1.GT.0) THEN
6663          IRFRAG = IRFRAG+1
6664          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
6665          GOTO 9999
6666       ENDIF
6667
6668 * decay of possible resonances (should be obsolete)
6669       CALL DT_DECAY1
6670
6671       RETURN
6672
6673  9999 CONTINUE
6674       IREVT = IREVT+1
6675       IREJ  = 1
6676       RETURN
6677       END
6678
6679 *$ CREATE DT_GETCSY.FOR
6680 *COPY DT_GETCSY
6681 *
6682 *===getcsy=============================================================*
6683 *
6684       SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
6685      &                  IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
6686
6687 ************************************************************************
6688 * This version dated 15.01.95 is written by S. Roesler                 *
6689 ************************************************************************
6690
6691       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6692       SAVE
6693       PARAMETER ( LINP = 10 ,
6694      &            LOUT = 6 ,
6695      &            LDAT = 9 )
6696       PARAMETER (TINY10=1.0D-10)
6697
6698 * event history
6699       PARAMETER (NMXHKK=200000)
6700       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6701      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6702      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6703 * extended event history
6704       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6705      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6706      &                IHIST(2,NMXHKK)
6707 * rejection counter
6708       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6709      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6710      &                IREXCI(3),IRDIFF(2),IRINC
6711 * flags for input different options
6712       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6713       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6714      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6715 * flags for diffractive interactions (DTUNUC 1.x)
6716       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6717
6718       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
6719      &          IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
6720
6721       IREJ  = 0
6722
6723 * get quark content of partons
6724       DO 1 I=1,2
6725          IFP1(I) = 0
6726          IFP2(I) = 0
6727          IFT1(I) = 0
6728          IFT2(I) = 0
6729     1 CONTINUE
6730       IFP1(1) = IDT_IPDG2B(IFPR1,1,2)
6731       IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2)
6732       IFP2(1) = IDT_IPDG2B(IFPR2,1,2)
6733       IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2)
6734       IFT1(1) = IDT_IPDG2B(IFTA1,1,2)
6735       IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2)
6736       IFT2(1) = IDT_IPDG2B(IFTA2,1,2)
6737       IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2)
6738
6739 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
6740       IDCH1 = 2
6741       IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1
6742       IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3
6743       IDCH2 = 2
6744       IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1
6745       IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3
6746
6747 * store initial configuration for energy-momentum cons. check
6748       IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
6749
6750 * sample intrinsic p_t at chain-ends
6751       CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2,
6752      &            PT1,IFTA1,IFT1,PT2,IFTA2,IFT2,
6753      &            AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1)
6754       IF (IREJ1.NE.0) THEN
6755          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY'
6756          IRPT = IRPT+1
6757          GOTO 9999
6758       ENDIF
6759
6760 C      IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6761 C         IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
6762 C* check second chain for resonance
6763 C            CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6764 C     &                  AMCH2,AMCH2N,IDCH2,IREJ1)
6765 C            IF (IREJ1.NE.0) GOTO 9999
6766 C            IF (IDR2.NE.0) THEN
6767 C               CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6768 C     &                     AMCH2,AMCH2N,AMCH1,IREJ1)
6769 C               IF (IREJ1.NE.0) GOTO 9999
6770 C            ENDIF
6771 C* check first chain for resonance
6772 C            CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6773 C     &                  AMCH1,AMCH1N,IDCH1,IREJ1)
6774 C            IF (IREJ1.NE.0) GOTO 9999
6775 C            IF (IDR1.NE.0) IDR1 = 100*IDR1
6776 C         ELSE
6777 C* check first chain for resonance
6778 C            CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6779 C     &                  AMCH1,AMCH1N,IDCH1,IREJ1)
6780 C            IF (IREJ1.NE.0) GOTO 9999
6781 C            IF (IDR1.NE.0) THEN
6782 C               CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6783 C     &                     AMCH1,AMCH1N,AMCH2,IREJ1)
6784 C               IF (IREJ1.NE.0) GOTO 9999
6785 C            ENDIF
6786 C* check second chain for resonance
6787 C            CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6788 C     &                  AMCH2,AMCH2N,IDCH2,IREJ1)
6789 C            IF (IREJ1.NE.0) GOTO 9999
6790 C            IF (IDR2.NE.0) IDR2 = 100*IDR2
6791 C         ENDIF
6792 C      ENDIF
6793
6794       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6795 * check chains for resonances
6796          CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6797      &               AMCH1,AMCH1N,IDCH1,IREJ1)
6798          IF (IREJ1.NE.0) GOTO 9999
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 * change kinematics corresponding to resonance-masses
6803          IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN
6804             CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6805      &                                 AMCH1,AMCH1N,AMCH2,IREJ1)
6806             IF (IREJ1.GT.0) GOTO 9999
6807             IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6808             CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6809      &                  AMCH2,AMCH2N,IDCH2,IREJ1)
6810             IF (IREJ1.NE.0) GOTO 9999
6811             IF (IDR2.NE.0) IDR2 = 100*IDR2
6812          ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN
6813             CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6814      &                                 AMCH2,AMCH2N,AMCH1,IREJ1)
6815             IF (IREJ1.GT.0) GOTO 9999
6816             IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6817             CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6818      &                  AMCH1,AMCH1N,IDCH1,IREJ1)
6819             IF (IREJ1.NE.0) GOTO 9999
6820             IF (IDR1.NE.0) IDR1 = 100*IDR1
6821          ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN
6822             AMDIF1 = ABS(AMCH1-AMCH1N)
6823             AMDIF2 = ABS(AMCH2-AMCH2N)
6824             IF (AMDIF2.LT.AMDIF1) THEN
6825                CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6826      &                                    AMCH2,AMCH2N,AMCH1,IREJ1)
6827                IF (IREJ1.GT.0) GOTO 9999
6828                IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6829                CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),
6830      &                     IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1)
6831                IF (IREJ1.NE.0) GOTO 9999
6832                IF (IDR1.NE.0) IDR1 = 100*IDR1
6833             ELSE
6834                CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6835      &                                    AMCH1,AMCH1N,AMCH2,IREJ1)
6836                IF (IREJ1.GT.0) GOTO 9999
6837                IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6838                CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),
6839      &                     IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1)
6840                IF (IREJ1.NE.0) GOTO 9999
6841                IF (IDR2.NE.0) IDR2 = 100*IDR2
6842             ENDIF
6843          ENDIF
6844       ENDIF
6845
6846 * store final configuration for energy-momentum cons. check
6847       IF (LEMCCK) THEN
6848          CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM)
6849          CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
6850          IF (IREJ1.NE.0) GOTO 9999
6851       ENDIF
6852
6853 * put partons and chains into DTEVT1
6854       DO 10 I=1,4
6855          PCH1(I) = PP1(I)+PT1(I)
6856          PCH2(I) = PP2(I)+PT2(I)
6857    10 CONTINUE
6858       CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2),
6859      &                                      PP1(3),PP1(4),0,0,0)
6860       CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2),
6861      &                                      PT1(3),PT1(4),0,0,0)
6862       KCH = 100+IDCH(MOP1)*10+1
6863       CALL DT_EVTPUT(KCH,88888,-2,-1,
6864      &           PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1))
6865       CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2),
6866      &                                      PP2(3),PP2(4),0,0,0)
6867       CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2),
6868      &                                      PT2(3),PT2(4),0,0,0)
6869       KCH = KCH+1
6870       CALL DT_EVTPUT(KCH,88888,-2,-1,
6871      &           PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
6872
6873       RETURN
6874
6875  9999 CONTINUE
6876       IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN
6877 * "cancel" sea-sea chains
6878          CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1)
6879          IF (IREJ1.NE.0) GOTO 9998
6880 **sr 16.5. flag for EVENTB
6881          IREJ = -1
6882          RETURN
6883       ENDIF
6884  9998 CONTINUE
6885       IREJ = 1
6886       RETURN
6887       END
6888
6889 *$ CREATE DT_CHKINE.FOR
6890 *COPY DT_CHKINE
6891 *
6892 *===chkine=============================================================*
6893 *
6894       SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
6895      &                  AMCH1,AMCH1N,AMCH2,IREJ)
6896
6897 ************************************************************************
6898 * This subroutine replaces CORMOM.                                     *
6899 * This version dated 05.01.95 is written by S. Roesler                 *
6900 ************************************************************************
6901
6902       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6903       SAVE
6904       PARAMETER ( LINP = 10 ,
6905      &            LOUT = 6 ,
6906      &            LDAT = 9 )
6907       PARAMETER (TINY10=1.0D-10)
6908
6909 * flags for input different options
6910       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6911       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6912      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6913 * rejection counter
6914       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6915      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6916      &                IREXCI(3),IRDIFF(2),IRINC
6917
6918       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
6919      &          PP1I(4),PP2I(4),PT1I(4),PT2I(4)
6920
6921       IREJ  = 0
6922       JMSHL = IMSHL
6923
6924       SCALE  = AMCH1N/MAX(AMCH1,TINY10)
6925       DO 10 I=1,4
6926          PP1(I) = PP1I(I)
6927          PP2(I) = PP2I(I)
6928          PT1(I) = PT1I(I)
6929          PT2(I) = PT2I(I)
6930          PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I)
6931          PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I)
6932          PP1(I) = SCALE*PP1(I)
6933          PT1(I) = SCALE*PT1(I)
6934    10 CONTINUE
6935       IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR.
6936      &    (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997
6937
6938       ECH = PP2(4)+PT2(4)
6939       PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+
6940      &                               (PP2(3)+PT2(3))**2 )
6941       AMCH22 = (ECH-PCH)*(ECH+PCH)
6942       IF (AMCH22.LT.0.0D0) THEN
6943          IF (IOULEV(1).GT.0)
6944      &      WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
6945          GOTO 9997
6946       ENDIF
6947
6948       AMCH1 = AMCH1N
6949       AMCH2 = SQRT(AMCH22)
6950
6951 * put partons again on mass shell
6952    13 CONTINUE
6953       XM1 = 0.0D0
6954       XM2 = 0.0D0
6955       IF (JMSHL.EQ.1) THEN
6956          XM1 = PYMASS(IFP1)
6957          XM2 = PYMASS(IFT1)
6958       ENDIF
6959       CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
6960       IF (IREJ1.NE.0) THEN
6961          IF (JMSHL.EQ.0) GOTO 9998
6962          JMSHL = 0
6963          GOTO 13
6964       ENDIF
6965       JMSHL = IMSHL
6966       DO 11 I=1,4
6967          PP1(I) = P1(I)
6968          PT1(I) = P2(I)
6969    11 CONTINUE
6970    14 CONTINUE
6971       XM1 = 0.0D0
6972       XM2 = 0.0D0
6973       IF (JMSHL.EQ.1) THEN
6974          XM1 = PYMASS(IFP2)
6975          XM2 = PYMASS(IFT2)
6976       ENDIF
6977       CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
6978       IF (IREJ1.NE.0) THEN
6979          IF (JMSHL.EQ.0) GOTO 9998
6980          JMSHL = 0
6981          GOTO 14
6982       ENDIF
6983       DO 12 I=1,4
6984          PP2(I) = P1(I)
6985          PT2(I) = P2(I)
6986    12 CONTINUE
6987       DO 15 I=1,4
6988          PP1I(I) = PP1(I)
6989          PP2I(I) = PP2(I)
6990          PT1I(I) = PT1(I)
6991          PT2I(I) = PT2(I)
6992    15 CONTINUE
6993       RETURN
6994
6995  9997 IRCHKI(1) = IRCHKI(1)+1
6996 **sr
6997 C     GOTO 9999
6998       IREJ = -1
6999       RETURN
7000 **
7001  9998 IRCHKI(2) = IRCHKI(2)+1
7002
7003  9999 CONTINUE
7004       IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
7005       IREJ = 1
7006       RETURN
7007       END
7008
7009 *$ CREATE DT_CH2RES.FOR
7010 *COPY DT_CH2RES
7011 *
7012 *===ch2res=============================================================*
7013 *
7014       SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
7015      &                  AM,AMN,IMODE,IREJ)
7016
7017 ************************************************************************
7018 * Check chains for resonance production.                               *
7019 * This subroutine replaces COMCMA/COBCMA/COMCM2                        *
7020 *    input:                                                            *
7021 *          IF1,2,3,4    input flavors (q,aq in any order)              *
7022 *          AM           chain mass                                     *
7023 *          MODE = 1     check q-aq chain for meson-resonance           *
7024 *               = 2     check q-qq, aq-aqaq chain for baryon-resonance *
7025 *               = 3     check qq-aqaq chain for lower mass cut         *
7026 *    output:                                                           *
7027 *          IDR = 0      no resonances found                            *
7028 *              = -1     pseudoscalar meson/octet baryon                *
7029 *              = 1      vector-meson/decuplet baryon                   *
7030 *          IDXR         BAMJET-index of corresponding resonance        *
7031 *          AMN          mass of corresponding resonance                *
7032 *                                                                      *
7033 *          IREJ         rejection flag                                 *
7034 * This version dated 06.01.95 is written by S. Roesler                 *
7035 ************************************************************************
7036
7037       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7038       SAVE
7039       PARAMETER ( LINP = 10 ,
7040      &            LOUT = 6 ,
7041      &            LDAT = 9 )
7042
7043 * particle properties (BAMJET index convention)
7044       CHARACTER*8  ANAME
7045       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7046      &                IICH(210),IIBAR(210),K1(210),K2(210)
7047 * quark-content to particle index conversion (DTUNUC 1.x)
7048       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
7049      &                IA08(6,21),IA10(6,21)
7050 * rejection counter
7051       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7052      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7053      &                IREXCI(3),IRDIFF(2),IRINC
7054 * flags for input different options
7055       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7056       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7057      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7058
7059       DIMENSION IF(4),JF(4)
7060
7061 **sr 4.7. test
7062 C     DATA AMLOM,AMLOB /0.08D0,0.2D0/
7063       DATA AMLOM,AMLOB /0.1D0,0.7D0/
7064 **
7065 C     DATA AMLOM,AMLOB /0.001D0,0.001D0/
7066
7067       MODE = ABS(IMODE)
7068
7069       IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN
7070          WRITE(LOUT,1000) MODE
7071  1000    FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/,
7072      &          1X,'        program stopped')
7073          STOP
7074       ENDIF
7075
7076       AMX  = AM
7077       IREJ = 0
7078       IDR  = 0
7079       IDXR = 0
7080       AMN  = AMX
7081       IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
7082       IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
7083
7084       IF(1) = IF1
7085       IF(2) = IF2
7086       IF(3) = IF3
7087       IF(4) = IF4
7088       NF = 0
7089       DO 100 I=1,4
7090          IF (IF(I).NE.0) THEN
7091             NF = NF+1
7092             JF(NF) = IF(I)
7093          ENDIF
7094   100 CONTINUE
7095       IF (NF.LE.MODE) THEN
7096          WRITE(LOUT,1001) MODE,IF
7097  1001    FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ',
7098      &   I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4)
7099          GOTO 9999
7100       ENDIF
7101
7102       GOTO (1,2,3) MODE
7103
7104 * check for meson resonance
7105     1 CONTINUE
7106       IFQ  = JF(1)
7107       IFAQ = ABS(JF(2))
7108       IF (JF(2).GT.0) THEN
7109          IFQ  = JF(2)
7110          IFAQ = ABS(JF(1))
7111       ENDIF
7112       IFPS = IMPS(IFAQ,IFQ)
7113       IFV  = IMVE(IFAQ,IFQ)
7114       AMPS = AAM(IFPS)
7115       AMV  = AAM(IFV)
7116       AMHI = AMV+0.3D0
7117       IF (AMX.LT.AMV) THEN
7118          IF (AMX.LT.AMPS) THEN
7119             IF (IMODE.GT.0) THEN
7120                IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999
7121             ELSE
7122                IF (AMX.LT.0.8D0*AMPS) GOTO 9999
7123             ENDIF
7124             LOMRES = LOMRES+1
7125          ENDIF
7126 *    replace chain by pseudoscalar meson
7127          IDR  = -1
7128          IDXR = IFPS
7129          AMN  = AMPS
7130       ELSEIF (AMX.LT.AMHI) THEN
7131 *    replace chain by vector-meson
7132          IDR  = 1
7133          IDXR = IFV
7134          AMN  = AMV
7135       ENDIF
7136       RETURN
7137
7138 * check for baryon resonance
7139     2 CONTINUE
7140       CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
7141       AM8  = AAM(JB8)
7142       AM10 = AAM(JB10)
7143       AMHI = AM10+0.3D0
7144       IF (AMX.LT.AM10) THEN
7145          IF (AMX.LT.AM8) THEN
7146             IF (IMODE.GT.0) THEN
7147                IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999
7148             ELSE
7149                IF (AMX.LT.0.8D0*AM8) GOTO 9999
7150             ENDIF
7151             LOBRES = LOBRES+1
7152          ENDIF
7153 *    replace chain by oktet baryon
7154          IDR  = -1
7155          IDXR = JB8
7156          AMN  = AM8
7157       ELSEIF (AMX.LT.AMHI) THEN
7158          IDR  = 1
7159          IDXR = JB10
7160          AMN  = AM10
7161       ENDIF
7162       RETURN
7163
7164 * check qq-aqaq for lower mass cut
7165     3 CONTINUE
7166 *   empirical definition of AMHI to allow for (b-antib)-pair prod.
7167       AMHI = 2.5D0
7168       IF (AMX.LT.AMHI) GOTO 9999
7169       RETURN
7170
7171  9999 CONTINUE
7172       IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
7173      &    WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
7174       IREJ = 1
7175       IRRES(2) = IRRES(2)+1
7176       RETURN
7177       END
7178
7179 *$ CREATE DT_RJSEAC.FOR
7180 *COPY DT_RJSEAC
7181 *
7182 *===rjseac=============================================================*
7183 *
7184       SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
7185
7186 ************************************************************************
7187 * ReJection of SEA-sea Chains.                                         *
7188 *         MOP1/2       entries of projectile sea-partons in DTEVT1     *
7189 *         MOT1/2       entries of projectile sea-partons in DTEVT1     *
7190 * This version dated 16.01.95 is written by S. Roesler                 *
7191 ************************************************************************
7192
7193       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7194       SAVE
7195       PARAMETER ( LINP = 10 ,
7196      &            LOUT = 6 ,
7197      &            LDAT = 9 )
7198       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
7199
7200 * event history
7201       PARAMETER (NMXHKK=200000)
7202       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7203      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7204      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7205 * extended event history
7206       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7207      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7208      &                IHIST(2,NMXHKK)
7209 * statistics
7210       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7211      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7212      &                ICEVTG(8,0:30)
7213
7214       DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
7215
7216       IREJ = 0
7217
7218 * projectile sea q-aq-pair
7219 *    indices of sea-pair
7220       IDXSEA(1,1) = MOP1
7221       IDXSEA(1,2) = MOP2
7222 *    index of mother-nucleon
7223       IDXNUC(1)   = JMOHKK(1,MOP1)
7224 *    status of valence quarks to be corrected
7225       ISTVAL(1)   = -21
7226
7227 * target sea q-aq-pair
7228 *    indices of sea-pair
7229       IDXSEA(2,1) = MOT1
7230       IDXSEA(2,2) = MOT2
7231 *    index of mother-nucleon
7232       IDXNUC(2)   = JMOHKK(1,MOT1)
7233 *    status of valence quarks to be corrected
7234       ISTVAL(2)   = -22
7235
7236       DO 1 N=1,2
7237          IDONE = 0
7238          DO 2 I=NPOINT(2),NHKK
7239             IF ((ISTHKK(I).EQ.ISTVAL(N)).AND.
7240      &          (JMOHKK(1,I).EQ.IDXNUC(N)))   THEN
7241 * valence parton found
7242 *    inrease 4-momentum by sea 4-momentum
7243                DO 3 K=1,4
7244                   PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
7245      &                                  PHKK(K,IDXSEA(N,2))
7246     3          CONTINUE
7247                PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
7248      &                              PHKK(2,I)**2-PHKK(3,I)**2))
7249 *    "cancel" sea-pair
7250                DO 4 J=1,2
7251                   ISTHKK(IDXSEA(N,J))   = 100
7252                   IDHKK(IDXSEA(N,J))    = 0
7253                   JMOHKK(1,IDXSEA(N,J)) = 0
7254                   JMOHKK(2,IDXSEA(N,J)) = 0
7255                   JDAHKK(1,IDXSEA(N,J)) = 0
7256                   JDAHKK(2,IDXSEA(N,J)) = 0
7257                   DO 5 K=1,4
7258                      PHKK(K,IDXSEA(N,J)) = ZERO
7259                      VHKK(K,IDXSEA(N,J)) = ZERO
7260                      WHKK(K,IDXSEA(N,J)) = ZERO
7261     5             CONTINUE
7262                   PHKK(5,IDXSEA(N,J)) = ZERO
7263     4          CONTINUE
7264                IDONE = 1
7265             ENDIF
7266     2    CONTINUE
7267          IF (IDONE.NE.1) THEN
7268             WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2
7269  1000       FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event',
7270      &                '-record!',/,1X,'        sea-quark pairs   ',
7271      &                2I5,4X,2I5,'   could not be canceled!')
7272             GOTO 9999
7273          ENDIF
7274     1 CONTINUE
7275       ICRJSS = ICRJSS+1
7276       RETURN
7277
7278  9999 CONTINUE
7279       IREJ = 1
7280       RETURN
7281       END
7282
7283 *$ CREATE DT_VV2SCH.FOR
7284 *COPY DT_VV2SCH
7285 *
7286 *===vv2sch=============================================================*
7287 *
7288       SUBROUTINE DT_VV2SCH
7289
7290 ************************************************************************
7291 * Change Valence-Valence chain systems to Single CHain systems for     *
7292 * hadron-nucleus collisions with meson or antibaryon projectile.       *
7293 * (Reggeon contribution)                                               *
7294 * The single chain system is approximately treated as one chain and a  *
7295 * meson at rest.                                                       *
7296 * This version dated 18.01.95 is written by S. Roesler                 *
7297 ************************************************************************
7298
7299       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7300       SAVE
7301       PARAMETER ( LINP = 10 ,
7302      &            LOUT = 6 ,
7303      &            LDAT = 9 )
7304       PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
7305
7306       LOGICAL LSTART
7307
7308 * event history
7309       PARAMETER (NMXHKK=200000)
7310       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7311      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7312      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7313 * extended event history
7314       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7315      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7316      &                IHIST(2,NMXHKK)
7317 * flags for input different options
7318       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7319       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7320      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7321 * statistics
7322       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7323      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7324      &                ICEVTG(8,0:30)
7325
7326       DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
7327      &          PCH2(4)
7328
7329       DATA LSTART /.TRUE./
7330
7331       IFSC  = 0
7332       IF (LSTART) THEN
7333          WRITE(LOUT,1000)
7334  1000    FORMAT(/,1X,'VV2SCH:  Reggeon contribution to valance-',
7335      &          'valence chains treated')
7336          LSTART = .FALSE.
7337       ENDIF
7338
7339       NSTOP = NHKK
7340
7341 * get index of first chain
7342       DO 1 I=NPOINT(3),NHKK
7343          IF (IDHKK(I).EQ.88888) THEN
7344             NC = I
7345             GOTO 2
7346          ENDIF
7347     1 CONTINUE
7348
7349     2 CONTINUE
7350       IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)
7351      &                        .AND.(NC.LT.NSTOP)) THEN
7352 * get valence-valence chains
7353          IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN
7354 *   get "mother"-hadron indices
7355             MO1   = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC)))
7356             MO2   = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC)))
7357             KPROJ = IDT_ICIHAD(IDHKK(MO1))
7358             KTARG = IDT_ICIHAD(IDHKK(MO2))
7359 *   Lab momentum of projectile hadron
7360             CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3)
7361             PTOT  = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+
7362      &                                  PHKK(3,MO1)**2)
7363
7364             SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
7365             IF (DT_RNDM(PTOT).LE.SICHAP) THEN
7366                ICVV2S = ICVV2S+1
7367 *   single chain requested
7368 *      get flavors of chain-end partons
7369                MO(1) = JMOHKK(1,NC)
7370                MO(2) = JMOHKK(2,NC)
7371                MO(3) = JMOHKK(1,NC+3)
7372                MO(4) = JMOHKK(2,NC+3)
7373                DO 3 I=1,4
7374                   IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
7375                   IF(I,2) = 0
7376                   IF (ABS(IDHKK(MO(I))).GE.1000)
7377      &               IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
7378     3          CONTINUE
7379 *      which one is the q-aq chain?
7380 *        N1,N1+1 - DTEVT1-entries for q-aq system
7381 *        N2,N2+1 - DTEVT1-entries for the other chain
7382                IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN
7383                   K1 = 1
7384                   K2 = 3
7385                   N1 = NC-2
7386                   N2 = NC+1
7387                ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
7388                   K1 = 3
7389                   K2 = 1
7390                   N1 = NC+1
7391                   N2 = NC-2
7392                ELSE
7393                   GOTO 10
7394                ENDIF
7395                DO 4 K=1,4
7396                   PP1(K) = PHKK(K,N1)
7397                   PT1(K) = PHKK(K,N1+1)
7398                   PP2(K) = PHKK(K,N2)
7399                   PT2(K) = PHKK(K,N2+1)
7400     4          CONTINUE
7401                AMCH1 = PHKK(5,N1+2)
7402                AMCH2 = PHKK(5,N2+2)
7403 *      get meson-identity corresponding to flavors of q-aq chain
7404                ITMP   = IRESRJ
7405                IRESRJ = 0
7406                CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1,
7407      &                     ZERO,AMCH1N,1,IDUM)
7408                IRESRJ = ITMP
7409 *      change kinematics of chains
7410                CALL DT_CHKINE(PP1,IDHKK(N1),  PP2,IDHKK(N2),
7411      &                     PT1,IDHKK(N1+1),PT2,IDHKK(N2+1),
7412      &                     AMCH1,AMCH1N,AMCH2,IREJ1)
7413                IF (IREJ1.NE.0) GOTO 10
7414 *      check second chain for resonance
7415                IDCHAI = 2
7416                IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3
7417                CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2),
7418      &                     IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1)
7419                IF (IREJ1.NE.0) GOTO 10
7420                IF (IDR2.NE.0) IDR2 = 100*IDR2
7421 *      add partons and chains to DTEVT1
7422                DO 5 K=1,4
7423                   PCH1(K) = PP1(K)+PT1(K)
7424                   PCH2(K) = PP2(K)+PT2(K)
7425     5          CONTINUE
7426                CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2),
7427      &                                             PP1(3),PP1(4),0,0,0)
7428                CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1),
7429      &                                      PT1(2),PT1(3),PT1(4),0,0,0)
7430                KCH = ISTHKK(N1+2)+100
7431                CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3),
7432      &                     PCH1(4),IDR1,IDXR1,IDCH(N1+2))
7433                IDHKK(N1+2) = 22222
7434                CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2),
7435      &                                             PP2(3),PP2(4),0,0,0)
7436                CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1),
7437      &                                      PT2(2),PT2(3),PT2(4),0,0,0)
7438                KCH = ISTHKK(N2+2)+100
7439                CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3),
7440      &                     PCH2(4),IDR2,IDXR2,IDCH(N2+2))
7441                IDHKK(N2+2) = 22222
7442             ENDIF
7443          ENDIF
7444       ELSE
7445          GOTO 11
7446       ENDIF
7447    10 CONTINUE
7448       NC = NC+6
7449       GOTO 2
7450
7451    11 CONTINUE
7452
7453       RETURN
7454       END
7455
7456 *$ CREATE DT_PHNSCH.FOR
7457 *COPY DT_PHNSCH
7458 *
7459 *=== phnsch ===========================================================*
7460 *
7461       DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB )
7462
7463 *----------------------------------------------------------------------*
7464 *                                                                      *
7465 *     Probability for Hadron Nucleon Single CHain interactions:        *
7466 *                                                                      *
7467 *     Created on 30 december 1993  by    Alfredo Ferrari & Paola Sala  *
7468 *                                                   Infn - Milan       *
7469 *                                                                      *
7470 *     Last change on 04-jan-94     by    Alfredo Ferrari               *
7471 *                                                                      *
7472 *             modified by J.R.for use in DTUNUC  6.1.94                *
7473 *                                                                      *
7474 *     Input variables:                                                 *
7475 *                      Kp = hadron projectile index (Part numbering    *
7476 *                           scheme)                                    *
7477 *                   Ktarg = target nucleon index (1=proton, 8=neutron) *
7478 *                    Plab = projectile laboratory momentum (GeV/c)     *
7479 *     Output variable:                                                 *
7480 *                  Phnsch = probability per single chain (particle     *
7481 *                           exchange) interactions                     *
7482 *                                                                      *
7483 *----------------------------------------------------------------------*
7484
7485       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7486       SAVE
7487
7488       PARAMETER ( LUNOUT = 6  )
7489       PARAMETER ( LUNERR = 6  )
7490       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
7491       PARAMETER ( ZERZER = 0.D+00 )
7492       PARAMETER ( ONEONE = 1.D+00 )
7493       PARAMETER ( TWOTWO = 2.D+00 )
7494       PARAMETER ( FIVFIV = 5.D+00 )
7495       PARAMETER ( HLFHLF = 0.5D+00 )
7496
7497       PARAMETER ( NALLWP = 39   )
7498       PARAMETER ( IDMAXP = 210  )
7499
7500       DIMENSION ICHRGE(39),AM(39)
7501
7502 * particle properties (BAMJET index convention)
7503       CHARACTER*8  ANAME
7504       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7505      &                IICH(210),IIBAR(210),K1(210),K2(210)
7506
7507       DIMENSION KPTOIP(210)
7508 * auxiliary common for reggeon exchange (DTUNUC 1.x)
7509       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
7510      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
7511      &                IQTCHR(-6:6),MQUARK(3,39)
7512
7513       DIMENSION SGTCOE (5,33), IHLP (NALLWP)
7514       DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15)
7515 CPH      SAVE SGTCOE, IHLP
7516 CPH      SAVE IQFSC1, IQFSC2, IQBSC1, IQBSC2
7517       EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1))
7518       EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11))
7519       EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19))
7520
7521 * Conversion from part to paprop numbering
7522       DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
7523      & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
7524      & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
7525
7526 *  1=baryon, 2=pion, 3=kaon, 4=antibaryon:
7527       DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
7528      &    2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
7529 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
7530       DATA  SGTCO1  /
7531 * 1st reaction: gamma p total
7532      &0.147 D+00, ZERZER  , ZERZER   , 0.0022D+00, -0.0170D+00,
7533 * 2nd reaction: gamma d total
7534      &0.300 D+00, ZERZER  , ZERZER   , 0.0095D+00, -0.057 D+00,
7535 * 3rd reaction: pi+ p total
7536      &16.4  D+00, 19.3D+00, -0.42D+00, 0.19  D+00, ZERZER     ,
7537 * 4th reaction: pi- p total
7538      &33.0  D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03  D+00,
7539 * 5th reaction: pi+/- d total
7540      &56.8  D+00, 42.2D+00, -1.45D+00, 0.65  D+00, -5.39  D+00,
7541 * 6th reaction: K+ p total
7542      &18.1  D+00, ZERZER  , ZERZER   , 0.26  D+00, -1.0   D+00,
7543 * 7th reaction: K+ n total
7544      &18.7  D+00, ZERZER  , ZERZER   , 0.21  D+00, -0.89  D+00,
7545 * 8th reaction: K+ d total
7546      &34.2  D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99  D+00,
7547 * 9th reaction: K- p total
7548      &32.1  D+00, ZERZER  , ZERZER   , 0.66  D+00, -5.6   D+00,
7549 * 10th reaction: K- n total
7550      &25.2  D+00, ZERZER  , ZERZER   , 0.38  D+00, -2.9   D+00/
7551 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
7552       DATA  SGTCO2  /
7553 * 11th reaction: K- d total
7554      &57.6  D+00, ZERZER  , ZERZER   , 1.17  D+00, -9.5   D+00,
7555 * 12th reaction: p p total
7556      &48.0  D+00, ZERZER  , ZERZER   , 0.522 D+00, -4.51  D+00,
7557 * 13th reaction: p n total
7558      &47.30 D+00, ZERZER  , ZERZER   , 0.513 D+00, -4.27  D+00,
7559 * 14th reaction: p d total
7560      &91.3  D+00, ZERZER  , ZERZER   , 1.05  D+00, -8.8   D+00,
7561 * 15th reaction: pbar p total
7562      &38.4  D+00, 77.6D+00, -0.64D+00, 0.26  D+00, -1.2   D+00,
7563 * 16th reaction: pbar n total
7564      &ZERZER    ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7   D+00,
7565 * 17th reaction: pbar d total
7566      &112.  D+00, 125.D+00, -1.08D+00, 1.14  D+00, -12.4  D+00,
7567 * 18th reaction: Lamda p total
7568      &30.4  D+00, ZERZER  , ZERZER   , ZERZER    , 1.6    D+00/
7569 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
7570       DATA SGTCO3  /
7571 * 19th reaction: pi+ p elastic
7572      &ZERZER    , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER     ,
7573 * 20th reaction: pi- p elastic
7574      &1.76  D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER     ,
7575 * 21st reaction: K+ p elastic
7576      &5.0   D+00, 8.1 D+00, -1.8 D+00, 0.16  D+00, -1.3   D+00,
7577 * 22nd reaction: K- p elastic
7578      &7.3   D+00, ZERZER  , ZERZER   , 0.29  D+00, -2.40  D+00,
7579 * 23rd reaction: p p elastic
7580      &11.9  D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85  D+00,
7581 * 24th reaction: p d elastic
7582      &16.1  D+00, ZERZER  , ZERZER   , 0.32  D+00, -3.4   D+00,
7583 * 25th reaction: pbar p elastic
7584      &10.2  D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28  D+00,
7585 * 26th reaction: pbar p elastic bis
7586      &10.6  D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41  D+00,
7587 * 27th reaction: pbar n elastic
7588      &36.5  D+00, ZERZER  , ZERZER   , ZERZER    , -11.9  D+00,
7589 * 28th reaction: Lamda p elastic
7590      &12.3  D+00, ZERZER  , ZERZER   , ZERZER    , -2.4   D+00,
7591 * 29th reaction: K- p ela bis
7592      &7.24  D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35  D+00,
7593 * 30th reaction: pi- p cx
7594      &ZERZER    ,0.912D+00, -1.22D+00, ZERZER    , ZERZER     ,
7595 * 31st reaction: K- p cx
7596      &ZERZER    , 3.39D+00, -1.75D+00, ZERZER    , ZERZER     ,
7597 * 32nd reaction: K+ n cx
7598      &ZERZER    , 7.18D+00, -2.01D+00, ZERZER    , ZERZER     ,
7599 * 33rd reaction: pbar p cx
7600      &ZERZER    , 18.8D+00, -2.01D+00, ZERZER    , ZERZER     /
7601 *
7602 *  +-------------------------------------------------------------------*
7603          ICHRGE(KTARG)=IICH(KTARG)
7604          AM    (KTARG)=AAM (KTARG)
7605 *  |  Check for pi0 (d-dbar)
7606       IF ( KP .NE. 26 ) THEN
7607          IP  = KPTOIP (KP)
7608          IF(IP.EQ.0)IP=1
7609          ICHRGE(IP)=IICH(KP)
7610          AM    (IP)=AAM (KP)
7611 *  |
7612 *  +-------------------------------------------------------------------*
7613 *  |
7614       ELSE
7615          IP = 23
7616          ICHRGE(IP)=0
7617       END IF
7618 *  |
7619 *  +-------------------------------------------------------------------*
7620 *  +-------------------------------------------------------------------*
7621 *  |  No such interactions for baryon-baryon
7622       IF ( IIBAR (KP) .GT. 0 ) THEN
7623          DT_PHNSCH = ZERZER
7624          RETURN
7625 *  |
7626 *  +-------------------------------------------------------------------*
7627 *  |  No "annihilation" diagram possible for K+ p/n
7628       ELSE IF ( IP .EQ. 15 ) THEN
7629          DT_PHNSCH = ZERZER
7630          RETURN
7631 *  |
7632 *  +-------------------------------------------------------------------*
7633 *  |  No "annihilation" diagram possible for K0 p/n
7634       ELSE IF ( IP .EQ. 24 ) THEN
7635          DT_PHNSCH = ZERZER
7636          RETURN
7637 *  |
7638 *  +-------------------------------------------------------------------*
7639 *  |  No "annihilation" diagram possible for Omebar p/n
7640       ELSE IF ( IP .GE. 38 ) THEN
7641          DT_PHNSCH = ZERZER
7642          RETURN
7643       END IF
7644 *  |
7645 *  +-------------------------------------------------------------------*
7646 *  +-------------------------------------------------------------------*
7647 *  |  If the momentum is larger than 50 GeV/c, compute the single
7648 *  |  chain probability at 50 GeV/c and extrapolate to the present
7649 *  |  momentum according to 1/sqrt(s)
7650 *  |  sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
7651 *  |  P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
7652 *  |  sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
7653 *  |  sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
7654 *  |                        x sqrt(s/s(50))
7655 *  |  P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
7656       IF ( PLAB .GT. 50.D+00 ) THEN
7657          PLA    = 50.D+00
7658          AMPSQ  = AM (IP)**2
7659          AMTSQ  = AM (KTARG)**2
7660          EPROJ  = SQRT ( PLAB**2 + AMPSQ )
7661          UMOSQ  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7662          EPROJ  = SQRT ( PLA**2 + AMPSQ )
7663          UMO50  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7664          UMORAT = SQRT ( UMOSQ / UMO50 )
7665 *  |
7666 *  +-------------------------------------------------------------------*
7667 *  |  P < 3 GeV/c
7668       ELSE IF ( PLAB .LT. 3.D+00 ) THEN
7669          PLA    = 3.D+00
7670          AMPSQ  = AM (IP)**2
7671          AMTSQ  = AM (KTARG)**2
7672          EPROJ  = SQRT ( PLAB**2 + AMPSQ )
7673          UMOSQ  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7674          EPROJ  = SQRT ( PLA**2 + AMPSQ )
7675          UMO50  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7676          UMORAT = SQRT ( UMOSQ / UMO50 )
7677 *  |
7678 *  +-------------------------------------------------------------------*
7679 *  |  P < 50 GeV/c
7680       ELSE
7681          PLA    = PLAB
7682          UMORAT = ONEONE
7683       END IF
7684 *  |
7685 *  +-------------------------------------------------------------------*
7686       ALGPLA = LOG (PLA)
7687 *  +-------------------------------------------------------------------*
7688 *  |  Pions:
7689       IF ( IHLP (IP) .EQ. 2 ) THEN
7690          ACOF = SGTCOE (1,3)
7691          BCOF = SGTCOE (2,3)
7692          ENNE = SGTCOE (3,3)
7693          CCOF = SGTCOE (4,3)
7694          DCOF = SGTCOE (5,3)
7695 *  |  Compute the pi+ p total cross section:
7696          SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7697      &          + DCOF * ALGPLA
7698          ACOF = SGTCOE (1,19)
7699          BCOF = SGTCOE (2,19)
7700          ENNE = SGTCOE (3,19)
7701          CCOF = SGTCOE (4,19)
7702          DCOF = SGTCOE (5,19)
7703 *  |  Compute the pi+ p elastic cross section:
7704          SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7705      &          + DCOF * ALGPLA
7706 *  |  Compute the pi+ p inelastic cross section:
7707          SPPPIN = SPPPTT - SPPPEL
7708          ACOF = SGTCOE (1,4)
7709          BCOF = SGTCOE (2,4)
7710          ENNE = SGTCOE (3,4)
7711          CCOF = SGTCOE (4,4)
7712          DCOF = SGTCOE (5,4)
7713 *  |  Compute the pi- p total cross section:
7714          SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7715      &          + DCOF * ALGPLA
7716          ACOF = SGTCOE (1,20)
7717          BCOF = SGTCOE (2,20)
7718          ENNE = SGTCOE (3,20)
7719          CCOF = SGTCOE (4,20)
7720          DCOF = SGTCOE (5,20)
7721 *  |  Compute the pi- p elastic cross section:
7722          SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7723      &          + DCOF * ALGPLA
7724 *  |  Compute the pi- p inelastic cross section:
7725          SPMPIN = SPMPTT - SPMPEL
7726          SIGDIA = SPMPIN - SPPPIN
7727 *  |  +----------------------------------------------------------------*
7728 *  |  |  Charged pions: besides isospin consideration it is supposed
7729 *  |  |                 that (pi+ n)el is almost equal to (pi- p)el
7730 *  |  |                 and  (pi+ p)el "    "     "    "  (pi- n)el
7731 *  |  |                 and all are almost equal among each others
7732 *  |  |                 (reasonable above 5 GeV/c)
7733          IF ( ICHRGE (IP) .NE. 0 ) THEN
7734             KHELP = KTARG / 8
7735             JREAC = 3 + 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 total cross section:
7742             SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7743      &             + DCOF * ALGPLA
7744             JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP
7745             ACOF = SGTCOE (1,JREAC)
7746             BCOF = SGTCOE (2,JREAC)
7747             ENNE = SGTCOE (3,JREAC)
7748             CCOF = SGTCOE (4,JREAC)
7749             DCOF = SGTCOE (5,JREAC)
7750 *  |  |  Compute the elastic cross section:
7751             SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7752      &             + DCOF * ALGPLA
7753 *  |  |  Compute the inelastic cross section:
7754             SHNCIN = SHNCTT - SHNCEL
7755 *  |  |  Number of diagrams:
7756             NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP
7757 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7758             IQFSC1 = 1 + IP - 13
7759             IQFSC2 = 0
7760             IQBSC1 = 1 + KHELP
7761             IQBSC2 = 1 + IP - 13
7762 *  |  |
7763 *  |  +----------------------------------------------------------------*
7764 *  |  |  pi0: besides isospin consideration it is supposed that the
7765 *  |  |       elastic cross section is not very different from
7766 *  |  |       pi+ p and/or pi- p (reasonable above 5 GeV/c)
7767          ELSE
7768             KHELP  = KTARG / 8
7769             K2HLP  = ( KP - 23 ) / 3
7770 *  |  |  Number of diagrams:
7771 *  |  |  For u ubar (k2hlp=0):
7772 *           NDIAGR = 2 - KHELP
7773 *  |  |  For d dbar (k2hlp=1):
7774 *           NDIAGR = 2 + KHELP - K2HLP
7775             NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP
7776             SHNCIN = HLFHLF * ( SPPPIN + SPMPIN )
7777 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7778             IQFSC1 = 1 + K2HLP
7779             IQFSC2 = 0
7780             IQBSC1 = 1 + KHELP
7781             IQBSC2 = 2 - K2HLP
7782          END IF
7783 *  |  |
7784 *  |  +----------------------------------------------------------------*
7785 *  |                                                   end pi's
7786 *  +-------------------------------------------------------------------*
7787 *  |  Kaons:
7788       ELSE IF ( IHLP (IP) .EQ. 3 ) THEN
7789          ACOF = SGTCOE (1,6)
7790          BCOF = SGTCOE (2,6)
7791          ENNE = SGTCOE (3,6)
7792          CCOF = SGTCOE (4,6)
7793          DCOF = SGTCOE (5,6)
7794 *  |  Compute the K+ p total cross section:
7795          SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7796      &          + DCOF * ALGPLA
7797          ACOF = SGTCOE (1,21)
7798          BCOF = SGTCOE (2,21)
7799          ENNE = SGTCOE (3,21)
7800          CCOF = SGTCOE (4,21)
7801          DCOF = SGTCOE (5,21)
7802 *  |  Compute the K+ p elastic cross section:
7803          SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7804      &          + DCOF * ALGPLA
7805 *  |  Compute the K+ p inelastic cross section:
7806          SKPPIN = SKPPTT - SKPPEL
7807          ACOF = SGTCOE (1,9)
7808          BCOF = SGTCOE (2,9)
7809          ENNE = SGTCOE (3,9)
7810          CCOF = SGTCOE (4,9)
7811          DCOF = SGTCOE (5,9)
7812 *  |  Compute the K- p total cross section:
7813          SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7814      &          + DCOF * ALGPLA
7815          ACOF = SGTCOE (1,22)
7816          BCOF = SGTCOE (2,22)
7817          ENNE = SGTCOE (3,22)
7818          CCOF = SGTCOE (4,22)
7819          DCOF = SGTCOE (5,22)
7820 *  |  Compute the K- p elastic cross section:
7821          SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7822      &          + DCOF * ALGPLA
7823 *  |  Compute the K- p inelastic cross section:
7824          SKMPIN = SKMPTT - SKMPEL
7825          SIGDIA = HLFHLF * ( SKMPIN - SKPPIN )
7826 *  |  +----------------------------------------------------------------*
7827 *  |  |  Charged Kaons: actually only K-
7828          IF ( ICHRGE (IP) .NE. 0 ) THEN
7829             KHELP = KTARG / 8
7830 *  |  |  +-------------------------------------------------------------*
7831 *  |  |  |  Proton target:
7832             IF ( KHELP .EQ. 0 ) THEN
7833                SHNCIN = SKMPIN
7834 *  |  |  |  Number of diagrams:
7835                NDIAGR = 2
7836 *  |  |  |
7837 *  |  |  +-------------------------------------------------------------*
7838 *  |  |  |  Neutron target: besides isospin consideration it is supposed
7839 *  |  |  |              that (K- n)el is almost equal to (K- p)el
7840 *  |  |  |              (reasonable above 5 GeV/c)
7841             ELSE
7842                ACOF = SGTCOE (1,10)
7843                BCOF = SGTCOE (2,10)
7844                ENNE = SGTCOE (3,10)
7845                CCOF = SGTCOE (4,10)
7846                DCOF = SGTCOE (5,10)
7847 *  |  |  |  Compute the total cross section:
7848                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7849      &                + DCOF * ALGPLA
7850 *  |  |  |  Compute the elastic cross section:
7851                SHNCEL = SKMPEL
7852 *  |  |  |  Compute the inelastic cross section:
7853                SHNCIN = SHNCTT - SHNCEL
7854 *  |  |  |  Number of diagrams:
7855                NDIAGR = 1
7856             END IF
7857 *  |  |  |
7858 *  |  |  +-------------------------------------------------------------*
7859 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7860             IQFSC1 = 3
7861             IQFSC2 = 0
7862             IQBSC1 = 1 + KHELP
7863             IQBSC2 = 2
7864 *  |  |
7865 *  |  +----------------------------------------------------------------*
7866 *  |  |  K0's: (actually only K0bar)
7867          ELSE
7868             KHELP  = KTARG / 8
7869 *  |  |  +-------------------------------------------------------------*
7870 *  |  |  |  Proton target: (K0bar p)in supposed to be given by
7871 *  |  |  |                 (K- p)in - Sig_diagr
7872             IF ( KHELP .EQ. 0 ) THEN
7873                SHNCIN = SKMPIN - SIGDIA
7874 *  |  |  |  Number of diagrams:
7875                NDIAGR = 1
7876 *  |  |  |
7877 *  |  |  +-------------------------------------------------------------*
7878 *  |  |  |  Neutron target: (K0bar n)in supposed to be given by
7879 *  |  |  |                 (K- n)in + Sig_diagr
7880 *  |  |  |              besides isospin consideration it is supposed
7881 *  |  |  |              that (K- n)el is almost equal to (K- p)el
7882 *  |  |  |              (reasonable above 5 GeV/c)
7883             ELSE
7884                ACOF = SGTCOE (1,10)
7885                BCOF = SGTCOE (2,10)
7886                ENNE = SGTCOE (3,10)
7887                CCOF = SGTCOE (4,10)
7888                DCOF = SGTCOE (5,10)
7889 *  |  |  |  Compute the total cross section:
7890                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7891      &                + DCOF * ALGPLA
7892 *  |  |  |  Compute the elastic cross section:
7893                SHNCEL = SKMPEL
7894 *  |  |  |  Compute the inelastic cross section:
7895                SHNCIN = SHNCTT - SHNCEL + SIGDIA
7896 *  |  |  |  Number of diagrams:
7897                NDIAGR = 2
7898             END IF
7899 *  |  |  |
7900 *  |  |  +-------------------------------------------------------------*
7901 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7902             IQFSC1 = 3
7903             IQFSC2 = 0
7904             IQBSC1 = 1
7905             IQBSC2 = 1 + KHELP
7906          END IF
7907 *  |  |
7908 *  |  +----------------------------------------------------------------*
7909 *  |                                                   end Kaon's
7910 *  +-------------------------------------------------------------------*
7911 *  |  Antinucleons:
7912       ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN
7913 *  |  For momenta between 3 and 5 GeV/c the use of tabulated data
7914 *  |  should be implemented!
7915          ACOF = SGTCOE (1,15)
7916          BCOF = SGTCOE (2,15)
7917          ENNE = SGTCOE (3,15)
7918          CCOF = SGTCOE (4,15)
7919          DCOF = SGTCOE (5,15)
7920 *  |  Compute the pbar p total cross section:
7921          SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7922      &          + DCOF * ALGPLA
7923          IF ( PLA .LT. FIVFIV ) THEN
7924             JREAC = 26
7925          ELSE
7926             JREAC = 25
7927          END IF
7928          ACOF = SGTCOE (1,JREAC)
7929          BCOF = SGTCOE (2,JREAC)
7930          ENNE = SGTCOE (3,JREAC)
7931          CCOF = SGTCOE (4,JREAC)
7932          DCOF = SGTCOE (5,JREAC)
7933 *  |  Compute the pbar p elastic cross section:
7934          SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7935      &          + DCOF * ALGPLA
7936 *  |  Compute the pbar p inelastic cross section:
7937          SAPPIN = SAPPTT - SAPPEL
7938          ACOF = SGTCOE (1,12)
7939          BCOF = SGTCOE (2,12)
7940          ENNE = SGTCOE (3,12)
7941          CCOF = SGTCOE (4,12)
7942          DCOF = SGTCOE (5,12)
7943 *  |  Compute the p p total cross section:
7944          SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7945      &          + DCOF * ALGPLA
7946          ACOF = SGTCOE (1,23)
7947          BCOF = SGTCOE (2,23)
7948          ENNE = SGTCOE (3,23)
7949          CCOF = SGTCOE (4,23)
7950          DCOF = SGTCOE (5,23)
7951 *  |  Compute the p p elastic cross section:
7952          SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7953      &          + DCOF * ALGPLA
7954 *  |  Compute the K- p inelastic cross section:
7955          SPPINE = SPPTOT - SPPELA
7956          SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV
7957          KHELP  = KTARG / 8
7958 *  |  +----------------------------------------------------------------*
7959 *  |  |  Pbar:
7960          IF ( ICHRGE (IP) .NE. 0 ) THEN
7961             NDIAGR = 5 - KHELP
7962 *  |  |  +-------------------------------------------------------------*
7963 *  |  |  |  Proton target:
7964             IF ( KHELP .EQ. 0 ) THEN
7965 *  |  |  |  Number of diagrams:
7966                SHNCIN = SAPPIN
7967                PUUBAR = 0.8D+00
7968 *  |  |  |
7969 *  |  |  +-------------------------------------------------------------*
7970 *  |  |  |  Neutron target: it is supposed that (ap n)el is almost equal
7971 *  |  |  |                  to (ap p)el (reasonable above 5 GeV/c)
7972             ELSE
7973                ACOF = SGTCOE (1,16)
7974                BCOF = SGTCOE (2,16)
7975                ENNE = SGTCOE (3,16)
7976                CCOF = SGTCOE (4,16)
7977                DCOF = SGTCOE (5,16)
7978 *  |  |  |  Compute the total cross section:
7979                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7980      &                + DCOF * ALGPLA
7981 *  |  |  |  Compute the elastic cross section:
7982                SHNCEL = SAPPEL
7983 *  |  |  |  Compute the inelastic cross section:
7984                SHNCIN = SHNCTT - SHNCEL
7985                PUUBAR = HLFHLF
7986             END IF
7987 *  |  |  |
7988 *  |  |  +-------------------------------------------------------------*
7989 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7990 *  |  |  there are different possibilities, make a random choiche:
7991             IQFSC1 = -1
7992             RNCHEN = DT_RNDM(PUUBAR)
7993             IF ( RNCHEN .LT. PUUBAR ) THEN
7994                IQFSC2 = -2
7995             ELSE
7996                IQFSC2 = -1
7997             END IF
7998             IQBSC1 = -IQFSC1 + KHELP
7999             IQBSC2 = -IQFSC2
8000 *  |  |
8001 *  |  +----------------------------------------------------------------*
8002 *  |  |  nbar:
8003          ELSE
8004             NDIAGR = 4 + KHELP
8005 *  |  |  +-------------------------------------------------------------*
8006 *  |  |  |  Proton target: (nbar p)in supposed to be given by
8007 *  |  |  |                 (pbar p)in - Sig_diagr
8008             IF ( KHELP .EQ. 0 ) THEN
8009                SHNCIN = SAPPIN - SIGDIA
8010                PDDBAR = HLFHLF
8011 *  |  |  |
8012 *  |  |  +-------------------------------------------------------------*
8013 *  |  |  |  Neutron target: (nbar n)el is supposed to be equal to
8014 *  |  |  |                  (pbar p)el (reasonable above 5 GeV/c)
8015             ELSE
8016 *  |  |  |  Compute the total cross section:
8017                SHNCTT = SAPPTT
8018 *  |  |  |  Compute the elastic cross section:
8019                SHNCEL = SAPPEL
8020 *  |  |  |  Compute the inelastic cross section:
8021                SHNCIN = SHNCTT - SHNCEL
8022                PDDBAR = 0.8D+00
8023             END IF
8024 *  |  |  |
8025 *  |  |  +-------------------------------------------------------------*
8026 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8027 *  |  |  there are different possibilities, make a random choiche:
8028             IQFSC1 = -2
8029             RNCHEN = DT_RNDM(RNCHEN)
8030             IF ( RNCHEN .LT. PDDBAR ) THEN
8031                IQFSC2 = -1
8032             ELSE
8033                IQFSC2 = -2
8034             END IF
8035             IQBSC1 = -IQFSC1 + KHELP - 1
8036             IQBSC2 = -IQFSC2
8037          END IF
8038 *  |  |
8039 *  |  +----------------------------------------------------------------*
8040 *  |
8041 *  +-------------------------------------------------------------------*
8042 *  |  Others: not yet implemented
8043       ELSE
8044          SIGDIA = ZERZER
8045          SHNCIN = ONEONE
8046          NDIAGR = 0
8047          DT_PHNSCH = ZERZER
8048          RETURN
8049       END IF
8050 *  |                                                   end others
8051 *  +-------------------------------------------------------------------*
8052       DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN
8053       IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1)
8054      &       + IQECHR (IQBSC2)
8055       IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1)
8056      &       + IQBCHR (IQBSC2)
8057       IQECHC = IQECHC / 3
8058       IQBCHC = IQBCHC / 3
8059       IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1)
8060      &       + IQSCHR (IQBSC2)
8061       IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP))
8062      &       + IQSCHR (MQUARK(3,IP))
8063 *  +-------------------------------------------------------------------*
8064 *  |  Consistency check:
8065       IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN
8066          WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla',
8067      &                         DT_PHNSCH,KP,KTARG,PLA,' ****'
8068          WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla',
8069      &                         DT_PHNSCH,KP,KTARG,PLA,' ****'
8070          DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER )
8071          DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE )
8072       END IF
8073 *  |
8074 *  +-------------------------------------------------------------------*
8075 *  +-------------------------------------------------------------------*
8076 *  |  Consistency check:
8077       IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG)
8078      &     .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN
8079          WRITE (LUNOUT,*)
8080      &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8081      &      IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8082          WRITE (LUNERR,*)
8083      &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8084      &      IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8085       END IF
8086 *  |
8087 *  +-------------------------------------------------------------------*
8088 *  P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8089       IF ( UMORAT .GT. ONEPLS )
8090      &   DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH
8091      &                                 - ONEONE ) * UMORAT + ONEONE )
8092       RETURN
8093 *
8094       ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 )
8095       DT_SCHQUA = ONEONE
8096       JQFSC1 = IQFSC1
8097       JQFSC2 = IQFSC2
8098       JQBSC1 = IQBSC1
8099       JQBSC2 = IQBSC2
8100 *=== End of function Phnsch ===========================================*
8101       RETURN
8102       END
8103
8104 *$ CREATE DT_RESPT.FOR
8105 *COPY DT_RESPT
8106 *
8107 *===respt==============================================================*
8108 *
8109       SUBROUTINE DT_RESPT
8110
8111 ************************************************************************
8112 * Check DTEVT1 for two-resonance systems and sample intrinsic p_t.     *
8113 * This version dated 18.01.95 is written by S. Roesler                 *
8114 ************************************************************************
8115
8116       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8117       SAVE
8118       PARAMETER ( LINP = 10 ,
8119      &            LOUT = 6 ,
8120      &            LDAT = 9 )
8121       PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8122
8123 * event history
8124       PARAMETER (NMXHKK=200000)
8125       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8126      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8127      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8128 * extended event history
8129       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8130      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8131      &                IHIST(2,NMXHKK)
8132
8133 * get index of first chain
8134       DO 1 I=NPOINT(3),NHKK
8135          IF (IDHKK(I).EQ.88888) THEN
8136             NC = I
8137             GOTO 2
8138          ENDIF
8139     1 CONTINUE
8140
8141     2 CONTINUE
8142       IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN
8143 C        WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3)
8144 * skip VV-,SS- systems
8145          IF ((IDCH(NC  ).NE.1).AND.(IDCH(NC  ).NE.8).AND.
8146      &       (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN
8147 * check if both "chains" are resonances
8148             IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN
8149                CALL DT_SAPTRE(NC,NC+3)
8150             ENDIF
8151          ENDIF
8152       ELSE
8153          GOTO 3
8154       ENDIF
8155       NC = NC+6
8156       GOTO 2
8157
8158     3 CONTINUE
8159
8160       RETURN
8161       END
8162
8163 *$ CREATE DT_EVTRES.FOR
8164 *COPY DT_EVTRES
8165 *
8166 *===evtres=============================================================*
8167 *
8168       SUBROUTINE DT_EVTRES(IREJ)
8169
8170 ************************************************************************
8171 * This version dated 14.12.94 is written by S. Roesler                 *
8172 ************************************************************************
8173
8174       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8175       SAVE
8176       PARAMETER ( LINP = 10 ,
8177      &            LOUT = 6 ,
8178      &            LDAT = 9 )
8179       PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10)
8180
8181 * event history
8182       PARAMETER (NMXHKK=200000)
8183       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8184      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8185      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8186 * extended event history
8187       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8188      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8189      &                IHIST(2,NMXHKK)
8190 * flags for input different options
8191       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8192       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8193      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8194 * particle properties (BAMJET index convention)
8195       CHARACTER*8  ANAME
8196       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
8197      &                IICH(210),IIBAR(210),K1(210),K2(210)
8198
8199       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2)
8200
8201       IREJ = 0
8202
8203       DO 1 I=NPOINT(3),NHKK
8204          IF (ABS(IDRES(I)).GE.100) THEN
8205             AMMX = 0.0D0
8206             DO 2 J=NPOINT(3),NHKK
8207                IF (IDHKK(J).EQ.88888) THEN
8208                   IF (PHKK(5,J).GT.AMMX) THEN
8209                      AMMX = PHKK(5,J)
8210                      IMMX = J
8211                   ENDIF
8212                ENDIF
8213     2       CONTINUE
8214             IF (IDRES(IMMX).NE.0) THEN
8215                IF (IOULEV(3).GT.0) THEN
8216                   WRITE(LOUT,'(1X,A)')
8217      &               'EVTRES: no chain for correc. found'
8218 C                 GOTO 6
8219                   GOTO 9999
8220                ELSE
8221                   GOTO 9999
8222                ENDIF
8223             ENDIF
8224             IMO11  = JMOHKK(1,I)
8225             IMO12  = JMOHKK(2,I)
8226             IF (PHKK(3,IMO11).LT.0.0D0) THEN
8227                IMO11 = JMOHKK(2,I)
8228                IMO12 = JMOHKK(1,I)
8229             ENDIF
8230             IMO21  = JMOHKK(1,IMMX)
8231             IMO22  = JMOHKK(2,IMMX)
8232             IF (PHKK(3,IMO21).LT.0.0D0) THEN
8233                IMO21 = JMOHKK(2,IMMX)
8234                IMO22 = JMOHKK(1,IMMX)
8235             ENDIF
8236             AMCH1  = PHKK(5,I)
8237             AMCH1N = AAM(IDXRES(I))
8238
8239             IFPR1 = IDHKK(IMO11)
8240             IFPR2 = IDHKK(IMO21)
8241             IFTA1 = IDHKK(IMO12)
8242             IFTA2 = IDHKK(IMO22)
8243             DO 4 J=1,4
8244                PP1(J) = PHKK(J,IMO11)
8245                PP2(J) = PHKK(J,IMO21)
8246                PT1(J) = PHKK(J,IMO12)
8247                PT2(J) = PHKK(J,IMO22)
8248     4       CONTINUE
8249 * store initial configuration for energy-momentum cons. check
8250             IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1)
8251 * correct kinematics of second chain
8252             CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
8253      &                  AMCH1,AMCH1N,AMCH2,IREJ1)
8254             IF (IREJ1.NE.0) GOTO 9999
8255 * check now this chain for resonance mass
8256             IFP(1) = IDT_IPDG2B(IFPR2,1,2)
8257             IFP(2) = 0
8258             IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2)
8259             IFT(1) = IDT_IPDG2B(IFTA2,1,2)
8260             IFT(2) = 0
8261             IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2)
8262             IDCH2 = 2
8263             IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1
8264             IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3
8265             CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2,
8266      &                  AMCH2,AMCH2N,IDCH2,IREJ1)
8267             IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN
8268                IF (IOULEV(1).GT.0)
8269      &            WRITE(LOUT,*) ' correction for resonance not poss.'
8270 **sr test
8271 C              GOTO 1
8272 C              GOTO 9999
8273 **
8274             ENDIF
8275 * store final configuration for energy-momentum cons. check
8276             IF (LEMCCK) THEN
8277                CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1)
8278                CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
8279                IF (IREJ1.NE.0) GOTO 9999
8280             ENDIF
8281             DO 5 J=1,4
8282                PHKK(J,IMO11) = PP1(J)
8283                PHKK(J,IMO21) = PP2(J)
8284                PHKK(J,IMO12) = PT1(J)
8285                PHKK(J,IMO22) = PT2(J)
8286     5       CONTINUE
8287 * correct entries of chains
8288             DO 3 K=1,4
8289                PHKK(K,I)    = PHKK(K,IMO11)+PHKK(K,IMO12)
8290                PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22)
8291     3       CONTINUE
8292             AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2
8293             AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2-
8294      &            PHKK(3,IMMX)**2
8295 * ?? the following should now be obsolete
8296 **sr test
8297 C           IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN
8298             IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8299 **
8300                WRITE(LOUT,'(1X,A,4G10.3)')
8301      &          'EVTRES: inonsistent mass-corr.',AM1,AM2
8302 C              GOTO 9999
8303                GOTO 1
8304             ENDIF
8305             PHKK(5,I)    = SQRT(AM1)
8306             PHKK(5,IMMX) = SQRT(AM2)
8307             IDRES(I)     = IDRES(I)/100
8308             IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR.
8309      &          (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN
8310                WRITE(LOUT,'(1X,A,4G10.3)')
8311      &          'EVTRES: inconsistent chain-masses',
8312      &          PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2
8313                GOTO 9999
8314             ENDIF
8315          ENDIF
8316     1 CONTINUE
8317     6 CONTINUE
8318       RETURN
8319
8320  9999 CONTINUE
8321       IREJ = 1
8322       RETURN
8323       END
8324
8325 *$ CREATE DT_GETSPT.FOR
8326 *COPY DT_GETSPT
8327 *
8328 *===getspt=============================================================*
8329 *
8330       SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2,
8331      &                  PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2,
8332      &                  AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ)
8333
8334 ************************************************************************
8335 * This version dated 12.12.94 is written by S. Roesler                 *
8336 ************************************************************************
8337
8338       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8339       SAVE
8340       PARAMETER ( LINP = 10 ,
8341      &            LOUT = 6 ,
8342      &            LDAT = 9 )
8343       PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)
8344
8345 * various options for treatment of partons (DTUNUC 1.x)
8346 * (chain recombination, Cronin,..)
8347       LOGICAL LCO2CR,LINTPT
8348       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8349      &                LCO2CR,LINTPT
8350 * flags for input different options
8351       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8352       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8353      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8354 * flags for diffractive interactions (DTUNUC 1.x)
8355       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
8356
8357       DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4),
8358      &          PT2(4),PT2I(4),P1(4),P2(4),
8359      &          IFP1(2),IFP2(2),IFT1(2),IFT2(2),
8360      &          PTOTI(4),PTOTF(4),DIFF(4)
8361
8362       IC   = 0
8363       IREJ = 0
8364 C     B33P = 4.0D0
8365 C     B33T = 4.0D0
8366 C     IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
8367 C     IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
8368       REDU = 1.0D0
8369 C     B33P = 3.5D0
8370 C     B33T = 3.5D0
8371       B33P = 4.0D0
8372       B33T = 4.0D0
8373       IF (IDIFF.NE.0) THEN
8374          B33P = 16.0D0
8375          B33T = 16.0D0
8376       ENDIF
8377
8378       DO 1 I=1,4
8379          PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I)
8380          PP1(I)   = PP1I(I)
8381          PP2(I)   = PP2I(I)
8382          PT1(I)   = PT1I(I)
8383          PT2(I)   = PT2I(I)
8384     1 CONTINUE
8385 * get initial chain masses
8386       PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8387      &                               +(PP1(3)+PT1(3))**2)
8388       ECH   = PP1(4)+PT1(4)
8389       AM1   = (ECH+PTOCH)*(ECH-PTOCH)
8390       PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8391      &                               +(PP2(3)+PT2(3))**2)
8392       ECH   = PP2(4)+PT2(4)
8393       AM2   = (ECH+PTOCH)*(ECH-PTOCH)
8394       IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8395          IF (IOULEV(1).GT.0)
8396      &   WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1',
8397      &                              AM1,AM2
8398          GOTO 9999
8399       ENDIF
8400       AM1  = SQRT(AM1)
8401       AM2  = SQRT(AM2)
8402       AM1N = ZERO
8403       AM2N = ZERO
8404
8405       MODE = 0
8406 C      IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
8407 C        MODE = 0
8408 C      ELSE
8409 C         MODE = 1
8410 C         IF (AM1.LT.0.6) THEN
8411 C            B33P = 10.0D0
8412 C         ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
8413 CC           B33P = 4.0D0
8414 C         ENDIF
8415 C         IF (AM2.LT.0.6) THEN
8416 C            B33T = 10.0D0
8417 C         ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
8418 CC           B33T = 4.0D0
8419 C         ENDIF
8420 C      ENDIF
8421
8422 * check chain masses for very low mass chains
8423 C     CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8424 C    &            AM1,DUM,-IDCH1,IREJ1)
8425 C     CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8426 C    &            AM2,DUM,-IDCH2,IREJ2)
8427 C     IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
8428 C        B33P = 20.0D0
8429 C        B33T = 20.0D0
8430 C     ENDIF
8431
8432       JMSHL = IMSHL
8433
8434     2 CONTINUE
8435       IC = IC+1
8436       IF (MOD(IC,15).EQ.0) B33P  = 2.0D0*B33P
8437       IF (MOD(IC,15).EQ.0) B33T  = 2.0D0*B33T
8438       IF (MOD(IC,18).EQ.0) REDU  = 0.0D0
8439 C     IF (MOD(IC,19).EQ.0) JMSHL = 0
8440       IF (MOD(IC,20).EQ.0) GOTO 7
8441 C        WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
8442 C        RETURN
8443 C        GOTO 9999
8444 C     ENDIF
8445
8446 * get transverse momentum
8447       IF (LINTPT) THEN
8448          ES   = -2.0D0/(B33P**2)
8449      &          *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8450          HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0)
8451          HPSP = HPSP*REDU
8452          ES   = -2.0D0/(B33T**2)
8453      &          *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8454          HPST = SQRT(ES*ES+2.0D0*ES*0.94D0)
8455          HPST = HPST*REDU
8456       ELSE
8457          HPSP = ZERO
8458          HPST = ZERO
8459       ENDIF
8460       CALL DT_DSFECF(SFE1,CFE1)
8461       CALL DT_DSFECF(SFE2,CFE2)
8462       IF (MODE.EQ.0) THEN
8463          PP1(1) = PP1I(1)+HPSP*CFE1
8464          PP1(2) = PP1I(2)+HPSP*SFE1
8465          PP2(1) = PP2I(1)-HPSP*CFE1
8466          PP2(2) = PP2I(2)-HPSP*SFE1
8467          PT1(1) = PT1I(1)+HPST*CFE2
8468          PT1(2) = PT1I(2)+HPST*SFE2
8469          PT2(1) = PT2I(1)-HPST*CFE2
8470          PT2(2) = PT2I(2)-HPST*SFE2
8471       ELSE
8472          PP1(1) = PP1I(1)+HPSP*CFE1
8473          PP1(2) = PP1I(2)+HPSP*SFE1
8474          PT1(1) = PT1I(1)-HPSP*CFE1
8475          PT1(2) = PT1I(2)-HPSP*SFE1
8476          PP2(1) = PP2I(1)+HPST*CFE2
8477          PP2(2) = PP2I(2)+HPST*SFE2
8478          PT2(1) = PT2I(1)-HPST*CFE2
8479          PT2(2) = PT2I(2)-HPST*SFE2
8480       ENDIF
8481
8482 * put partons on mass shell
8483       XMP1 = 0.0D0
8484       XMT1 = 0.0D0
8485       IF (JMSHL.EQ.1) THEN
8486          XMP1 = PYMASS(IFPR1)
8487          XMT1 = PYMASS(IFTA1)
8488       ENDIF
8489       CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1)
8490       IF (IREJ1.NE.0) GOTO 2
8491       DO 3 I=1,4
8492          PTOTF(I) = P1(I)+P2(I)
8493          PP1(I)   = P1(I)
8494          PT1(I)   = P2(I)
8495     3 CONTINUE
8496       XMP2 = 0.0D0
8497       XMT2 = 0.0D0
8498       IF (JMSHL.EQ.1) THEN
8499          XMP2 = PYMASS(IFPR2)
8500          XMT2 = PYMASS(IFTA2)
8501       ENDIF
8502       CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1)
8503       IF (IREJ1.NE.0) GOTO 2
8504       DO 4 I=1,4
8505          PTOTF(I) = PTOTF(I)+P1(I)+P2(I)
8506          PP2(I)   = P1(I)
8507          PT2(I)   = P2(I)
8508     4 CONTINUE
8509
8510 * check consistency
8511       DO 5 I=1,4
8512          DIFF(I) = PTOTI(I)-PTOTF(I)
8513     5 CONTINUE
8514       IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR.
8515      &    (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN
8516          WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF
8517          GOTO 9999
8518       ENDIF
8519       PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2)
8520       AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) ))
8521       PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2)
8522       AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) ))
8523       PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2)
8524       AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) ))
8525       PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2)
8526       AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) ))
8527       IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR.
8528      &    (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3))
8529      &                                                           THEN
8530          WRITE(LOUT,'(1X,A,2(4G10.3,/))')
8531      &     'GETSPT: inconsistent masses',
8532      &     AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2
8533 * sr 22.11.00: commented. It should only have inconsistent masses for
8534 * ultrahigh energies due to rounding problems
8535 C        GOTO 9999
8536       ENDIF
8537
8538 * get chain masses
8539       PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8540      &                               +(PP1(3)+PT1(3))**2)
8541       ECH   = PP1(4)+PT1(4)
8542       AM1N  = (ECH+PTOCH)*(ECH-PTOCH)
8543       PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8544      &                               +(PP2(3)+PT2(3))**2)
8545       ECH   = PP2(4)+PT2(4)
8546       AM2N  = (ECH+PTOCH)*(ECH-PTOCH)
8547       IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN
8548          IF (IOULEV(1).GT.0)
8549      &   WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2',
8550      &                              AM1N,AM2N
8551          GOTO 2
8552       ENDIF
8553       AM1N = SQRT(AM1N)
8554       AM2N = SQRT(AM2N)
8555
8556 * check chain masses for very low mass chains
8557       CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8558      &            AM1N,DUM,-IDCH1,IREJ1)
8559       IF (IREJ1.NE.0) GOTO 2
8560       CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8561      &            AM2N,DUM,-IDCH2,IREJ2)
8562       IF (IREJ2.NE.0) GOTO 2
8563
8564     7 CONTINUE
8565       IF (AM1N.GT.ZERO) THEN
8566          AM1 = AM1N
8567          AM2 = AM2N
8568       ENDIF
8569       DO 6 I=1,4
8570          PP1I(I)   = PP1(I)
8571          PP2I(I)   = PP2(I)
8572          PT1I(I)   = PT1(I)
8573          PT2I(I)   = PT2(I)
8574     6 CONTINUE
8575
8576       RETURN
8577
8578  9999 CONTINUE
8579       IREJ = 1
8580       RETURN
8581       END
8582
8583 *$ CREATE DT_SAPTRE.FOR
8584 *COPY DT_SAPTRE
8585 *
8586 *===saptre=============================================================*
8587 *
8588       SUBROUTINE DT_SAPTRE(IDX1,IDX2)
8589
8590 ************************************************************************
8591 * p-t sampling for two-resonance systems. ("BAMJET-like" method)       *
8592 *        IDX1,IDX2       indices of resonances ("chains") in DTEVT1    *
8593 * Adopted from the original SAPTRE written by J. Ranft.                *
8594 * This version dated 18.01.95 is written by S. Roesler                 *
8595 ************************************************************************
8596
8597       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8598       SAVE
8599       PARAMETER ( LINP = 10 ,
8600      &            LOUT = 6 ,
8601      &            LDAT = 9 )
8602       PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8603
8604 * event history
8605       PARAMETER (NMXHKK=200000)
8606       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8607      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8608      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8609 * extended event history
8610       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8611      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8612      &                IHIST(2,NMXHKK)
8613 * flags for input different options
8614       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8615       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8616      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8617
8618       DIMENSION PA1(4),PA2(4),P1(4),P2(4)
8619
8620       DATA B3 /4.0D0/
8621
8622       ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1)
8623       ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2)
8624       ESMAX  = MIN(ESMAX1,ESMAX2)
8625       IF (ESMAX.LE.0.05D0) RETURN
8626
8627       HMA    = PHKK(5,IDX1)
8628       DO 1 K=1,4
8629          PA1(K) = PHKK(K,IDX1)
8630          PA2(K) = PHKK(K,IDX2)
8631     1 CONTINUE
8632
8633       IF (LEMCCK) THEN
8634          CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM)
8635          CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM)
8636       ENDIF
8637
8638       EXEB   = 0.0D0
8639       IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX)
8640       BEXP   = HMA*(1.0D0-EXEB)/B3
8641       AXEXP  = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2
8642       WA     = AXEXP/(BEXP+AXEXP)
8643       XAB    = DT_RNDM(WA)
8644    10 CONTINUE
8645 * ES is the transverse kinetic energy
8646       IF (XAB.LT.WA)THEN
8647         X  = DT_RNDM(WA)
8648         Y  = DT_RNDM(WA)
8649         ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7)
8650       ELSE
8651         X  = DT_RNDM(Y)
8652         ES = ABS(-LOG(X+TINY7)/B3)
8653       ENDIF
8654       IF (ES.GT.ESMAX) GOTO 10
8655       ES  = ES+HMA
8656 * transverse momentum
8657       HPS = SQRT((ES-HMA)*(ES+HMA))
8658
8659       CALL DT_DSFECF(SFE,CFE)
8660       HPX = HPS*CFE
8661       HPY = HPS*SFE
8662       PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY
8663       PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY
8664       IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN
8665
8666 C     PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3))
8667 C     PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3))
8668       PA1(1) = PA1(1)+HPX
8669       PA1(2) = PA1(2)+HPY
8670       PA2(1) = PA2(1)-HPX
8671       PA2(2) = PA2(2)-HPY
8672
8673 * put resonances on mass-shell again
8674       XM1 = PHKK(5,IDX1)
8675       XM2 = PHKK(5,IDX2)
8676       CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1)
8677       IF (IREJ1.NE.0) RETURN
8678
8679       IF (LEMCCK) THEN
8680          CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM)
8681          CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM)
8682          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1)
8683          IF (IREJ1.NE.0) RETURN
8684       ENDIF
8685
8686       DO 2 K=1,4
8687          PHKK(K,IDX1) = P1(K)
8688          PHKK(K,IDX2) = P2(K)
8689     2 CONTINUE
8690
8691       RETURN
8692       END
8693
8694 *$ CREATE DT_CRONIN.FOR
8695 *COPY DT_CRONIN
8696 *
8697 *===cronin=============================================================*
8698 *
8699       SUBROUTINE DT_CRONIN(INCL)
8700
8701 ************************************************************************
8702 * Cronin-Effect. Multiple scattering of partons at chain ends.         *
8703 *             INCL = 1     multiple sc. in projectile                  *
8704 *                  = 2     multiple sc. in target                      *
8705 * This version dated 05.01.96 is written by S. Roesler.                *
8706 ************************************************************************
8707
8708       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8709       SAVE
8710       PARAMETER ( LINP = 10 ,
8711      &            LOUT = 6 ,
8712      &            LDAT = 9 )
8713       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8714
8715 * event history
8716       PARAMETER (NMXHKK=200000)
8717       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8718      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8719      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8720 * extended event history
8721       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8722      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8723      &                IHIST(2,NMXHKK)
8724 * rejection counter
8725       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8726      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8727      &                IREXCI(3),IRDIFF(2),IRINC
8728 * Glauber formalism: collision properties
8729       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
8730      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
8731      &                NCP,NCT
8732       DIMENSION R(3),PIN(4),POUT(4),DEV(4)
8733
8734       DO 1 K=1,4
8735          DEV(K) = ZERO
8736     1 CONTINUE
8737
8738       DO 2 I=NPOINT(2),NHKK
8739          IF (ISTHKK(I).LT.0) THEN
8740 * get z-position of the chain
8741             R(1) = VHKK(1,I)*1.0D12
8742             IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC
8743             R(2) = VHKK(2,I)*1.0D12
8744             IDXNU = JMOHKK(1,I)
8745             IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) )
8746      &                             IDXNU = JMOHKK(1,I-1)
8747             IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) )
8748      &                             IDXNU = JMOHKK(1,I+1)
8749             R(3) = VHKK(3,IDXNU)*1.0D12
8750 * position of target parton the chain is connected to
8751             DO 3 K=1,4
8752                PIN(K) = PHKK(K,I)
8753     3       CONTINUE
8754 * multiple scattering of parton with DTEVT1-index I
8755             CALL DT_CROMSC(PIN,R,POUT,INCL)
8756 **testprint
8757 C           IF (NEVHKK.EQ.5) THEN
8758 C              AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2
8759 C              AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2
8760 C              AMIN = SIGN(SQRT(ABS(AMIN)),AMIN)
8761 C              AMOU = SIGN(SQRT(ABS(AMOU)),AMOU)
8762 C              WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU
8763 C              WRITE(6,'(A,4E15.5)')'PIN:       ',PIN
8764 C              WRITE(6,'(A,4E15.5)')'POUT:      ',POUT
8765 C           ENDIF
8766 **
8767 * increase accumulator by energy-momentum difference
8768             DO 4 K=1,4
8769                DEV(K)    = DEV(K)+POUT(K)-PIN(K)
8770                PHKK(K,I) = POUT(K)
8771     4       CONTINUE
8772             PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8773      &                           PHKK(2,I)**2-PHKK(3,I)**2))
8774          ENDIF
8775     2 CONTINUE
8776
8777 * dump accumulator to momenta of valence partons
8778       NVAL = 0
8779       ETOT = 0.0D0
8780       DO 5 I=NPOINT(2),NHKK
8781          IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8782             NVAL = NVAL+1
8783             ETOT = ETOT+PHKK(4,I)
8784          ENDIF
8785     5 CONTINUE
8786 C     WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4)
8787  1000 FORMAT(1X,'CRONIN :  number of val. partons ',I4,/,
8788      &       9X,4E12.4)
8789       DO 6 I=NPOINT(2),NHKK
8790          IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8791             E = PHKK(4,I)
8792             DO 7 K=1,4
8793 C              PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL)
8794                PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT
8795     7       CONTINUE
8796             PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8797      &                           PHKK(2,I)**2-PHKK(3,I)**2))
8798          ENDIF
8799     6 CONTINUE
8800
8801       RETURN
8802       END
8803
8804 *$ CREATE DT_CROMSC.FOR
8805 *COPY DT_CROMSC
8806 *
8807 *===cromsc=============================================================*
8808 *
8809       SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL)
8810
8811 ************************************************************************
8812 * Cronin-Effect. Multiple scattering of one parton passing through     *
8813 * nuclear matter.                                                      *
8814 *            PIN(4)       input 4-momentum of parton                   *
8815 *            POUT(4)      4-momentum of parton after mult. scatt.      *
8816 *            R(3)         spatial position of parton in target nucleus *
8817 *            INCL = 1     multiple sc. in projectile                   *
8818 *                 = 2     multiple sc. in target                       *
8819 * This is a revised version of the original version written by J. Ranft*
8820 * This version dated 17.01.95 is written by S. Roesler.                *
8821 ************************************************************************
8822
8823       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8824       SAVE
8825       PARAMETER ( LINP = 10 ,
8826      &            LOUT = 6 ,
8827      &            LDAT = 9 )
8828       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8829
8830       LOGICAL LSTART
8831
8832 * rejection counter
8833       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8834      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8835      &                IREXCI(3),IRDIFF(2),IRINC
8836 * Glauber formalism: collision properties
8837       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
8838      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
8839      &                NCP,NCT
8840 * various options for treatment of partons (DTUNUC 1.x)
8841 * (chain recombination, Cronin,..)
8842       LOGICAL LCO2CR,LINTPT
8843       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8844      &                LCO2CR,LINTPT
8845
8846       DIMENSION PIN(4),POUT(4),R(3)
8847
8848       DATA LSTART /.TRUE./
8849
8850       IRCRON(1) = IRCRON(1)+1
8851
8852       IF (LSTART) THEN
8853          WRITE(LOUT,1000) CRONCO
8854  1000    FORMAT(/,1X,'CROMSC:  multiple scattering of chain ends',
8855      &          ' treated',/,10X,'with parameter CRONCO = ',F5.2)
8856          LSTART = .FALSE.
8857       ENDIF
8858
8859       NCBACK = 0
8860       RNCL   = RPROJ
8861       IF (INCL.EQ.2) RNCL = RTARG
8862
8863 * Lorentz-transformation into Lab.
8864       MODE = -(INCL+1)
8865       CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE)
8866
8867       PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2)
8868       IF (PTOT.LE.8.0D0) GOTO 9997
8869
8870 * direction cosines of parton before mult. scattering
8871       COSX = PIN(1)/PTOT
8872       COSY = PIN(2)/PTOT
8873       COSZ = PZ/PTOT
8874
8875       RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2
8876       IF (RTESQ.GE.-TINY3) GOTO 9999
8877
8878 * calculate distance (DIST) from R to surface of nucleus (radius RNCL)
8879 * in the direction of particle motion
8880
8881       A    = COSX*R(1)+COSY*R(2)+COSZ*R(3)
8882       TMP  = A**2-RTESQ
8883       IF (TMP.LT.ZERO) GOTO 9998
8884       DIST = -A+SQRT(TMP)
8885
8886 * multiple scattering angle
8887       THETO = CRONCO*SQRT(DIST)/PTOT
8888       IF (THETO.GT.0.1D0) THETO=0.1D0
8889
8890     1 CONTINUE
8891 * Gaussian sampling of spatial angle
8892       CALL DT_RANNOR(R1,R2)
8893       THETA = ABS(R1*THETO)
8894       IF (THETA.GT.0.3D0) GOTO 9997
8895       CALL DT_DSFECF(SFE,CFE)
8896       COSTH = COS(THETA)
8897       SINTH = SIN(THETA)
8898
8899 * new direction cosines
8900       CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE,
8901      &                               COSXN,COSYN,COSZN)
8902
8903       POUT(1) = COSXN*PTOT
8904       POUT(2) = COSYN*PTOT
8905       PZ      = COSZN*PTOT
8906 * Lorentz-transformation into nucl.-nucl. cms
8907       MODE = INCL+1
8908       CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE)
8909
8910 C     IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
8911 C     IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN
8912       IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN
8913          THETO = THETO/2.0D0
8914          NCBACK = NCBACK+1
8915          IF (MOD(NCBACK,200).EQ.0) THEN
8916             WRITE(LOUT,1001) THETO,PIN,POUT
8917  1001       FORMAT(1X,'CROMSC: inconsistent scattering angle ',
8918      &             E12.4,/,1X,'        PIN :',4E12.4,/,
8919      &             1X,'       POUT:',4E12.4)
8920             GOTO 9997
8921          ENDIF
8922          GOTO 1
8923       ENDIF
8924
8925       RETURN
8926
8927  9997 IRCRON(2) = IRCRON(2)+1
8928       GOTO 9999
8929  9998 IRCRON(3) = IRCRON(3)+1
8930
8931  9999 CONTINUE
8932       DO 100 K=1,4
8933          POUT(K) = PIN(K)
8934   100 CONTINUE
8935       RETURN
8936       END
8937
8938 *$ CREATE DT_COM2CR.FOR
8939 *COPY DT_COM2CR
8940 *
8941 *===com2sr=============================================================*
8942 *
8943       SUBROUTINE DT_COM2CR
8944
8945 ************************************************************************
8946 * COMbine q-aq chains to Color Ropes (qq-aqaq).                        *
8947 *        CUTOF      parameter determining minimum number of not        *
8948 *                   combined q-aq chains                               *
8949 * This subroutine replaces KKEVCC etc.                                 *
8950 * This version dated 11.01.95 is written by S. Roesler.                *
8951 ************************************************************************
8952
8953       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8954       SAVE
8955       PARAMETER ( LINP = 10 ,
8956      &            LOUT = 6 ,
8957      &            LDAT = 9 )
8958
8959 * event history
8960       PARAMETER (NMXHKK=200000)
8961       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8962      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8963      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8964 * extended event history
8965       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8966      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8967      &                IHIST(2,NMXHKK)
8968 * statistics
8969       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
8970      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
8971      &                ICEVTG(8,0:30)
8972 * various options for treatment of partons (DTUNUC 1.x)
8973 * (chain recombination, Cronin,..)
8974       LOGICAL LCO2CR,LINTPT
8975       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8976      &                LCO2CR,LINTPT
8977
8978       DIMENSION IDXQA(248),IDXAQ(248)
8979
8980       ICCHAI(1,9) = ICCHAI(1,9)+1
8981       NQA = 0
8982       NAQ = 0
8983 * scan DTEVT1 for q-aq, aq-q chains
8984       DO 10 I=NPOINT(3),NHKK
8985 * skip "chains" which are resonances
8986          IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN
8987             MO1 = JMOHKK(1,I)
8988             MO2 = JMOHKK(2,I)
8989             IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN
8990 * q-aq, aq-q chain found, keep index
8991                IF (IDHKK(MO1).GT.0) THEN
8992                   NQA = NQA+1
8993                   IDXQA(NQA) = I
8994                ELSE
8995                   NAQ = NAQ+1
8996                   IDXAQ(NAQ) = I
8997                ENDIF
8998             ENDIF
8999          ENDIF
9000    10 CONTINUE
9001
9002 * minimum number of q-aq chains requested for the same projectile/
9003 * target
9004       NCHMIN = IDT_NPOISS(CUTOF)
9005
9006 * combine q-aq chains of the same projectile
9007       CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1)
9008 * combine q-aq chains of the same target
9009       CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2)
9010 * combine aq-q chains of the same projectile
9011       CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1)
9012 * combine aq-q chains of the same target
9013       CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2)
9014
9015       RETURN
9016       END
9017
9018 *$ CREATE DT_SCN4CR.FOR
9019 *COPY DT_SCN4CR
9020 *
9021 *===scn4cr=============================================================*
9022 *
9023       SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE)
9024
9025 ************************************************************************
9026 * SCan q-aq chains for Color Ropes.                                    *
9027 * This version dated 11.01.95 is written by S. Roesler.                *
9028 ************************************************************************
9029
9030       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9031       SAVE
9032       PARAMETER ( LINP = 10 ,
9033      &            LOUT = 6 ,
9034      &            LDAT = 9 )
9035
9036 * event history
9037       PARAMETER (NMXHKK=200000)
9038       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9039      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9040      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9041 * extended event history
9042       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9043      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9044      &                IHIST(2,NMXHKK)
9045
9046       DIMENSION IDXCH(248),IDXJN(248)
9047
9048       DO 1 I=1,NCH
9049          IF (IDXCH(I).GT.0) THEN
9050             NJOIN = 1
9051             IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I))))
9052             IDXJN(NJOIN) = I
9053             IF (I.LT.NCH) THEN
9054                DO 2 J=I+1,NCH
9055                   IF (IDXCH(J).GT.0) THEN
9056                      IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J))))
9057                      IF (IDXMO.EQ.IDXMO1) THEN
9058                         NJOIN = NJOIN+1
9059                         IDXJN(NJOIN) = J
9060                      ENDIF
9061                   ENDIF
9062     2          CONTINUE
9063             ENDIF
9064             IF (NJOIN.GE.NCHMIN+2) THEN
9065                NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0)
9066                DO 3 J=1,2*NJ,2
9067                   CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1)
9068                   IF (IREJ1.NE.0) GOTO 3
9069                   IDXCH(IDXJN(J))   = 0
9070                   IDXCH(IDXJN(J+1)) = 0
9071     3          CONTINUE
9072             ENDIF
9073          ENDIF
9074     1 CONTINUE
9075
9076       RETURN
9077       END
9078
9079 *$ CREATE DT_JOIN.FOR
9080 *COPY DT_JOIN
9081 *
9082 *===join===============================================================*
9083 *
9084       SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ)
9085
9086 ************************************************************************
9087 * This subroutine joins two q-aq chains to one qq-aqaq chain.          *
9088 *     IDX1, IDX2       DTEVT1 indices of chains to be joined           *
9089 * This version dated 11.01.95 is written by S. Roesler.                *
9090 ************************************************************************
9091
9092       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9093       SAVE
9094       PARAMETER ( LINP = 10 ,
9095      &            LOUT = 6 ,
9096      &            LDAT = 9 )
9097
9098 * event history
9099       PARAMETER (NMXHKK=200000)
9100       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9101      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9102      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9103 * extended event history
9104       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9105      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9106      &                IHIST(2,NMXHKK)
9107 * flags for input different options
9108       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9109       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9110      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9111 * statistics
9112       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9113      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9114      &                ICEVTG(8,0:30)
9115
9116       DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4)
9117
9118       IREJ   = 0
9119
9120       IDX(1) = IDX1
9121       IDX(2) = IDX2
9122       DO 1 I=1,2
9123          DO 2 J=1,2
9124             MO(I,J) = JMOHKK(J,IDX(I))
9125             ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2)
9126     2    CONTINUE
9127     1 CONTINUE
9128
9129 * check consistency
9130       IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR.
9131      &    (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR.
9132      &    ((ID(1,1)*ID(2,1)).LT.0).OR.
9133      &    ((ID(1,2)*ID(2,2)).LT.0)) THEN
9134          WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1),
9135      &                    MO(2,2)
9136  1000    FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':',
9137      &             2I5,' chain ',I4,':',2I5)
9138       ENDIF
9139
9140 * join chains
9141       DO 3 K=1,4
9142          PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))
9143          PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))
9144     3 CONTINUE
9145       IF1  = IDT_IB2PDG(ID(1,1),ID(2,1),2)
9146       IF2  = IDT_IB2PDG(ID(1,2),ID(2,2),2)
9147       IST1 = ISTHKK(MO(1,1))
9148       IST2 = ISTHKK(MO(1,2))
9149
9150 * put partons again on mass shell
9151       XM1 = 0.0D0
9152       XM2 = 0.0D0
9153       IF (IMSHL.EQ.1) THEN
9154          XM1 = PYMASS(IF1)
9155          XM2 = PYMASS(IF2)
9156       ENDIF
9157       CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1)
9158       IF (IREJ1.NE.0) GOTO 9999
9159       DO 4 I=1,4
9160          PP(I) = P1(I)
9161          PT(I) = P2(I)
9162     4 CONTINUE
9163
9164 * store new partons in DTEVT1
9165       CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4),
9166      &                                                       0,0,0)
9167       CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4),
9168      &                                                       0,0,0)
9169       DO 5 K=1,4
9170          PCH(K) = PP(K)+PT(K)
9171     5 CONTINUE
9172
9173 * check new chain for lower mass limit
9174       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
9175          AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2))
9176          CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM,
9177      &               AMCH,AMCHN,3,IREJ1)
9178          IF (IREJ1.NE.0) THEN
9179             NHKK = NHKK-2
9180             GOTO 9999
9181          ENDIF
9182       ENDIF
9183
9184       ICCHAI(2,9) = ICCHAI(2,9)+1
9185 * store new chain in DTEVT1
9186       KCH = 191
9187       CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9)
9188       IDHKK(IDX(1)) = 22222
9189       IDHKK(IDX(2)) = 22222
9190 * special treatment for space-time coordinates
9191       DO 6 K=1,4
9192          VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0
9193          WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0
9194     6 CONTINUE
9195       RETURN
9196
9197  9999 CONTINUE
9198       IREJ = 1
9199       RETURN
9200       END
9201
9202 *$ CREATE DT_XSGLAU.FOR
9203 *COPY DT_XSGLAU
9204 *
9205 *===xsglau=============================================================*
9206 *
9207       SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX)
9208
9209 ************************************************************************
9210 * Total, elastic, quasi-elastic, inelastic cross sections according to *
9211 * Glauber's approach.                                                  *
9212 *  NA / NB     mass numbers of proj./target nuclei                     *
9213 *  JJPROJ      bamjet-index of projectile (=1 in case of proj.nucleus) *
9214 *  XI,Q2I,ECMI kinematical variables x, Q^2, E_cm                      *
9215 *  IE,IQ       indices of energy and virtuality (the latter for gamma  *
9216 *              projectiles only)                                       *
9217 *  NIDX        index of projectile/target nucleus                      *
9218 * This version dated 17.3.98  is written by S. Roesler                 *
9219 ************************************************************************
9220
9221       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9222       SAVE
9223       PARAMETER ( LINP = 10 ,
9224      &            LOUT = 6 ,
9225      &            LDAT = 9 )
9226
9227       COMPLEX*16 CZERO,CONE,CTWO
9228       CHARACTER*12 CFILE
9229       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9230      &           ONETHI=ONE/THREE,TINY25=1.0D-25)
9231       PARAMETER (TWOPI  = 6.283185307179586454D+00,
9232      &           PI     = TWOPI/TWO,
9233      &           GEV2MB = 0.38938D0,
9234      &           GEV2FM = 0.1972D0,
9235      &           ALPHEM = ONE/137.0D0,
9236 * proton mass
9237      &           AMP    = 0.938D0,
9238      &           AMP2   = AMP**2,
9239 * approx. nucleon radius
9240      &           RNUCLE = 1.12D0)
9241
9242 * particle properties (BAMJET index convention)
9243       CHARACTER*8  ANAME
9244       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
9245      &                IICH(210),IIBAR(210),K1(210),K2(210)
9246       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9247       PARAMETER ( MAXNCL = 260,
9248      &            MAXVQU = MAXNCL,
9249      &            MAXSQU = 20*MAXVQU,
9250      &            MAXINT = MAXVQU+MAXSQU)
9251 * Glauber formalism: parameters
9252       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9253      &                BMAX(NCOMPX),BSTEP(NCOMPX),
9254      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9255      &                NSITEB,NSTATB
9256 * Glauber formalism: cross sections
9257       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
9258      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
9259      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
9260      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
9261      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
9262      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
9263      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
9264      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
9265      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
9266      &                BSLOPE,NEBINI,NQBINI
9267 * Glauber formalism: flags and parameters for statistics
9268       LOGICAL LPROD
9269       CHARACTER*8 CGLB
9270       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
9271 * nucleon-nucleon event-generator
9272       CHARACTER*8 CMODEL
9273       LOGICAL LPHOIN
9274       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
9275 * VDM parameter for photon-nucleus interactions
9276       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
9277 * parameters for hA-diffraction
9278       COMMON /DTDIHA/ DIBETA,DIALPH
9279
9280       COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL),
9281      &           OMPP11,OMPP12,OMPP21,OMPP22,
9282      &           DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP,
9283      &           PPTMP1,PPTMP2
9284       COMPLEX*16 C,CA,CI
9285       DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL),
9286      &          COOP2(3,MAXNCL),COOT2(3,MAXNCL),
9287      &          BPROD(KSITEB)
9288
9289       PARAMETER (NPOINT=16)
9290       DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
9291
9292       LOGICAL LFIRST,LOPEN
9293       DATA LFIRST,LOPEN /.TRUE.,.FALSE./
9294
9295       NTARG = ABS(NIDX)
9296 * for quasi-elastic neutrino scattering set projectile to proton
9297 * it should not have an effect since the whole Glauber-formalism is
9298 * not needed for these interactions..
9299       IF (MCGENE.EQ.4) THEN
9300          IJPROJ = 1
9301       ELSE
9302          IJPROJ = JJPROJ
9303       ENDIF
9304
9305       IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN
9306          I = INDEX(CGLB,' ')
9307          IF (I.EQ.0) THEN
9308             CFILE = CGLB//'.glb'
9309             OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN')
9310          ELSEIF (I.GT.1) THEN
9311             CFILE = CGLB(1:I-1)//'.glb'
9312             OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN')
9313          ELSE
9314             STOP 'XSGLAU 1'
9315          ENDIF
9316          LOPEN = .TRUE.
9317       ENDIF
9318
9319       CZERO  = DCMPLX(ZERO,ZERO)
9320       CONE   = DCMPLX(ONE,ZERO)
9321       CTWO   = DCMPLX(TWO,ZERO)
9322       NEBINI = IE
9323       NQBINI = IQ
9324
9325 * re-define kinematics
9326       S  = ECMI**2
9327       Q2 = Q2I
9328       X  = XI
9329 *  g(Q2=0)-A, h-A, A-A scattering
9330       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9331          Q2 = 0.0001D0
9332          X  = Q2/(S+Q2-AMP2)
9333 *  g(Q2>0)-A scattering
9334       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN
9335          X  = Q2/(S+Q2-AMP2)
9336       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9337          Q2 = (S-AMP2)*X/(ONE-X)
9338       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
9339          S  = Q2*(ONE-X)/X+AMP2
9340       ELSE
9341          WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X
9342          STOP
9343       ENDIF
9344       ECMNN(IE) = SQRT(S)
9345       Q2G(IQ)   = Q2
9346       XNU = (S+Q2-AMP2)/(TWO*AMP)
9347
9348 * parameters determining statistics in evaluating Glauber-xsection
9349       NSTATB = JSTATB
9350       NSITEB = JBINSB
9351       IF (NSITEB.GT.KSITEB) NSITEB = KSITEB
9352
9353 * set up interaction geometry (common /DTGLAM/)
9354 *  projectile/target radii
9355       RPRNCL = DT_RNCLUS(NA)
9356       RTANCL = DT_RNCLUS(NB)
9357       IF (IJPROJ.EQ.7) THEN
9358          RASH(1) = ZERO
9359          RBSH(NTARG) = RTANCL
9360          BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9361       ELSE
9362          IF (NIDX.LE.-1) THEN
9363             RASH(1)     = RPRNCL
9364             RBSH(NTARG) = RTANCL
9365             BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9366          ELSE
9367             RASH(NTARG) = RPRNCL
9368             RBSH(1)     = RTANCL
9369             BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1))
9370          ENDIF
9371       ENDIF
9372 *  maximum impact-parameter
9373       BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1)
9374
9375 * slope, rho ( Re(f(0))/Im(f(0)) )
9376       IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
9377          IF (MCGENE.EQ.2) THEN
9378             ZERO1 = ZERO
9379             CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3,
9380      &                                                   BSLOPE,0)
9381          ELSE
9382             BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
9383          ENDIF
9384          IF (ECMNN(IE).LE.3.0D0) THEN
9385             ROSH = -0.43D0
9386          ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN
9387             ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE))
9388          ELSEIF (ECMNN(IE).GT.50.0D0) THEN
9389             ROSH = 0.1D0
9390          ENDIF
9391       ELSEIF (IJPROJ.EQ.7) THEN
9392          ROSH = 0.1D0
9393       ELSE
9394          BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
9395          ROSH   = 0.01D0
9396       ENDIF
9397
9398 * projectile-nucleon xsection (in fm)
9399       IF (IJPROJ.EQ.7) THEN
9400          SIGSH = DT_SIGVP(X,Q2)/10.0D0
9401       ELSE
9402          ELAB  = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
9403          PLAB  = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
9404 C        SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
9405          DUMZER = ZERO
9406          CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
9407          SIGSH = SIGSH/10.0D0
9408       ENDIF
9409
9410 * parameters for projectile diffraction (hA scattering only)
9411       IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7)
9412      &                               .AND.(DIBETA.GE.ZERO)) THEN
9413          ZERO1 = ZERO
9414          CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0)
9415 C        DIBETA = SDIF1/STOT
9416          DIBETA = 0.2D0
9417          DIGAMM = SQRT(DIALPH**2+DIBETA**2)
9418          IF (DIBETA.LE.ZERO) THEN
9419             ALPGAM = ONE
9420          ELSE
9421             ALPGAM = DIALPH/DIGAMM
9422          ENDIF
9423          FACDI1 = ONE-ALPGAM
9424          FACDI2 = ONE+ALPGAM
9425          FACDI  = SQRT(FACDI1*FACDI2)
9426          WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM
9427       ELSE
9428          DIBETA = -1.0D0
9429          DIALPH = ZERO
9430          DIGAMM = ZERO
9431          FACDI1 = ZERO
9432          FACDI2 = 2.0D0
9433          FACDI  = ZERO
9434       ENDIF
9435
9436 * initializations
9437       DO 10 I=1,NSITEB
9438          BSITE( 0,IQ,NTARG,I) = ZERO
9439          BSITE(IE,IQ,NTARG,I) = ZERO
9440          BPROD(I) = ZERO
9441    10 CONTINUE
9442       STOT  = ZERO
9443       STOT2 = ZERO
9444       SELA  = ZERO
9445       SELA2 = ZERO
9446       SQEP  = ZERO
9447       SQEP2 = ZERO
9448       SQET  = ZERO
9449       SQET2 = ZERO
9450       SQE2  = ZERO
9451       SQE22 = ZERO
9452       SPRO  = ZERO
9453       SPRO2 = ZERO
9454       SDEL  = ZERO
9455       SDEL2 = ZERO
9456       SDQE  = ZERO
9457       SDQE2 = ZERO
9458       FACN   = ONE/DBLE(NSTATB)
9459
9460       IPNT = 0
9461       RPNT = ZERO
9462
9463 *  initialize Gauss-integration for photon-proj.
9464       JPOINT = 1
9465       IF (IJPROJ.EQ.7) THEN
9466          IF (INTRGE(1).EQ.1) THEN
9467             AMLO2 = (3.0D0*AAM(13))**2
9468          ELSEIF (INTRGE(1).EQ.2) THEN
9469             AMLO2 = AAM(33)**2
9470          ELSE
9471             AMLO2 = AAM(96)**2
9472          ENDIF
9473          IF (INTRGE(2).EQ.1) THEN
9474             AMHI2 = S/TWO
9475          ELSEIF (INTRGE(2).EQ.2) THEN
9476             AMHI2 = S/4.0D0
9477          ELSE
9478             AMHI2 = S
9479          ENDIF
9480          AMHI20 = (ECMNN(IE)-AMP)**2
9481          IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
9482          XAMLO = LOG( AMLO2+Q2 )
9483          XAMHI = LOG( AMHI2+Q2 )
9484 **PHOJET105a
9485 C        CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9486 **PHOJET112
9487          CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9488 **
9489          JPOINT = NPOINT
9490 * ratio direct/total photon-nucleon xsection
9491          CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1)
9492       ENDIF
9493
9494 * read pre-initialized profile-function from file
9495       IF (IOGLB.EQ.1) THEN
9496          READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM
9497          IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN
9498             WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB,
9499      &                             NA,NB,NSTATB,NSITEB
9500  1000       FORMAT(' XSGLAU: inconsistent input data in file ',A12,/,
9501      &             ' (IA,IB,ISTATB,ISITEB) ',4I10,/,
9502      &             ' (NA,NB,NSTATB,NSITEB) ',4I10)
9503             STOP
9504          ENDIF
9505          IF (LFIRST) WRITE(LOUT,1001) CFILE
9506  1001    FORMAT(/,' XSGLAU: impact parameter distribution read from ',
9507      &          'file ',A12,/)
9508          READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),
9509      &                         XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG),
9510      &                         XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9511          READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),
9512      &                         XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG),
9513      &                         XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9514          NLINES = INT(DBLE(NSITEB)/7.0D0)
9515          IF (NLINES.GT.0) THEN
9516             DO 21 I=1,NLINES
9517                ISTART = 7*I-6
9518                READ(LDAT,'(7E11.4)')
9519      &            (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9520    21       CONTINUE
9521          ENDIF
9522          ISTART = 7*NLINES+1
9523          IF (ISTART.LE.NSITEB) THEN
9524             READ(LDAT,'(7E11.4)')
9525      &         (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9526          ENDIF
9527          LFIRST = .FALSE.
9528          GOTO 100
9529 * variable projectile/target/energy runs:
9530 * read pre-initialized profile-functions from file
9531       ELSEIF (IOGLB.EQ.100) THEN
9532          CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0)
9533          GOTO 100
9534       ENDIF
9535
9536 * cross sections averaged over NSTATB nucleon configurations
9537       DO 11 IS=1,NSTATB
9538 C        IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS
9539          STOTN = ZERO
9540          SELAN = ZERO
9541          SQEPN = ZERO
9542          SQETN = ZERO
9543          SQE2N = ZERO
9544          SPRON = ZERO
9545          SDELN = ZERO
9546          SDQEN = ZERO
9547
9548          IF (NIDX.LE.-1) THEN
9549             CALL DT_CONUCL(COOP1,NA,RASH(1),0)
9550             CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1)
9551             IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9552                CALL DT_CONUCL(COOP2,NA,RASH(1),0)
9553                CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1)
9554             ENDIF
9555          ELSE
9556             CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0)
9557             CALL DT_CONUCL(COOT1,NB,RBSH(1),1)
9558             IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9559                CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0)
9560                CALL DT_CONUCL(COOT2,NB,RBSH(1),1)
9561             ENDIF
9562          ENDIF
9563
9564 *  integration over impact parameter B
9565          DO 12 IB=1,NSITEB-1
9566             STOTB = ZERO
9567             SELAB = ZERO
9568             SQEPB = ZERO
9569             SQETB = ZERO
9570             SQE2B = ZERO
9571             SPROB = ZERO
9572             SDIR  = ZERO
9573             SDELB = ZERO
9574             SDQEB = ZERO
9575             B     = DBLE(IB)*BSTEP(NTARG)
9576             FACB  = 10.0D0*TWOPI*B*BSTEP(NTARG)
9577
9578 *   integration over M_V^2 for photon-proj.
9579             DO 14 IM=1,JPOINT
9580                PP11(1) = CONE
9581                PP12(1) = CONE
9582                PP21(1) = CONE
9583                PP22(1) = CONE
9584                IF (IJPROJ.EQ.7) THEN
9585                   DO 13 K=2,NB
9586                      PP11(K) = CONE
9587                      PP12(K) = CONE
9588                      PP21(K) = CONE
9589                      PP22(K) = CONE
9590    13             CONTINUE
9591                ENDIF
9592                SHI  = ZERO
9593                FACM = ONE
9594                DCOH = 1.0D10
9595
9596                IF (IJPROJ.EQ.7) THEN
9597                   AMV2 = EXP(ABSZX(IM))-Q2
9598                   AMV  = SQRT(AMV2)
9599                   IF (AMV2.LT.16.0D0) THEN
9600                      R = TWO
9601                   ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN
9602                      R = 10.0D0/3.0D0
9603                   ELSE
9604                      R = 11.0D0/3.0D0
9605                   ENDIF
9606 *    define M_V dependent properties of nucleon scattering amplitude
9607 *     V_M-nucleon xsection
9608                   SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0
9609                   SIGMV  = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2)
9610 *     slope-parametrisation a la Kaidalov
9611                   BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
9612      &                           +0.25D0*LOG(S/(AMV2+Q2)))
9613 *    coherence length
9614                   IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM
9615 *    integration weight factor
9616                   FACM = ALPHEM/(3.0D0*PI*(ONE-X))*
9617      &                  R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM)
9618                ENDIF
9619                GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
9620                GAM = GSH
9621                IF (IJPROJ.EQ.7) THEN
9622                   RCA = GAM*SIGMV/TWOPI
9623                ELSE
9624                   RCA = GAM*SIGSH/TWOPI
9625                ENDIF
9626                FCA = -ROSH*RCA
9627                CA  = DCMPLX(RCA,FCA)
9628                CI  = CONE
9629
9630                DO 15 INA=1,NA
9631                   KK1  = 1
9632                   INT1 = 1
9633                   KK2  = 1
9634                   INT2 = 1
9635                   DO 16 INB=1,NB
9636 *    photon-projectile: check for supression by coherence length
9637                      IF (IJPROJ.EQ.7) THEN
9638                         IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN
9639                            KK1  = INB
9640                            INT1 = INT1+1
9641                         ENDIF
9642                         IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN
9643                            KK2  = INB
9644                            INT2 = INT2+1
9645                         ENDIF
9646                      ENDIF
9647
9648                      X11 = B+COOT1(1,INB)-COOP1(1,INA)
9649                      Y11 =   COOT1(2,INB)-COOP1(2,INA)
9650                      XY11 = GAM*(X11*X11+Y11*Y11)
9651                      IF (XY11.LE.15.0D0) THEN
9652                         C = CONE-CA*EXP(-XY11)
9653                         AR = DBLE(PP11(INT1))
9654                         AI = DIMAG(PP11(INT1))
9655                         IF (ABS(AR).LT.TINY25) AR = ZERO
9656                         IF (ABS(AI).LT.TINY25) AI = ZERO
9657                         PP11(INT1) = DCMPLX(AR,AI)
9658                         PP11(INT1) = PP11(INT1)*C
9659                         AR  = DBLE(C)
9660                         AI  = DIMAG(C)
9661                         SHI = SHI+LOG(AR*AR+AI*AI)
9662                      ENDIF
9663                      IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9664                         X12 = B+COOT2(1,INB)-COOP1(1,INA)
9665                         Y12 =   COOT2(2,INB)-COOP1(2,INA)
9666                         XY12 = GAM*(X12*X12+Y12*Y12)
9667                         IF (XY12.LE.15.0D0) THEN
9668                            C = CONE-CA*EXP(-XY12)
9669                            AR = DBLE(PP12(INT2))
9670                            AI = DIMAG(PP12(INT2))
9671                            IF (ABS(AR).LT.TINY25) AR = ZERO
9672                            IF (ABS(AI).LT.TINY25) AI = ZERO
9673                            PP12(INT2) = DCMPLX(AR,AI)
9674                            PP12(INT2) = PP12(INT2)*C
9675                         ENDIF
9676                         X21 = B+COOT1(1,INB)-COOP2(1,INA)
9677                         Y21 =   COOT1(2,INB)-COOP2(2,INA)
9678                         XY21 = GAM*(X21*X21+Y21*Y21)
9679                         IF (XY21.LE.15.0D0) THEN
9680                            C = CONE-CA*EXP(-XY21)
9681                            AR = DBLE(PP21(INT1))
9682                            AI = DIMAG(PP21(INT1))
9683                            IF (ABS(AR).LT.TINY25) AR = ZERO
9684                            IF (ABS(AI).LT.TINY25) AI = ZERO
9685                            PP21(INT1) = DCMPLX(AR,AI)
9686                            PP21(INT1) = PP21(INT1)*C
9687                         ENDIF
9688                         X22 = B+COOT2(1,INB)-COOP2(1,INA)
9689                         Y22 =   COOT2(2,INB)-COOP2(2,INA)
9690                         XY22 = GAM*(X22*X22+Y22*Y22)
9691                         IF (XY22.LE.15.0D0) THEN
9692                            C = CONE-CA*EXP(-XY22)
9693                            AR = DBLE(PP22(INT2))
9694                            AI = DIMAG(PP22(INT2))
9695                            IF (ABS(AR).LT.TINY25) AR = ZERO
9696                            IF (ABS(AI).LT.TINY25) AI = ZERO
9697                            PP22(INT2) = DCMPLX(AR,AI)
9698                            PP22(INT2) = PP22(INT2)*C
9699                         ENDIF
9700                      ENDIF
9701    16             CONTINUE
9702    15          CONTINUE
9703
9704                OMPP11 = CZERO
9705                OMPP21 = CZERO
9706                DIPP11 = CZERO
9707                DIPP21 = CZERO
9708                DO 17 K=1,INT1
9709                   IF (PP11(K).EQ.CZERO) THEN
9710                      PPTMP1 = CZERO
9711                      PPTMP2 = CZERO
9712                   ELSE
9713                      PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM)
9714                      PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM)
9715                   ENDIF
9716                   AVDIPP = 0.5D0*
9717      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9718                   OMPP11 = OMPP11+AVDIPP
9719 C                 OMPP11 = OMPP11+(CONE-PP11(K))
9720                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9721                   DIPP11 = DIPP11+AVDIPP
9722                   IF (PP21(K).EQ.CZERO) THEN
9723                      PPTMP1 = CZERO
9724                      PPTMP2 = CZERO
9725                   ELSE
9726                      PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM)
9727                      PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM)
9728                   ENDIF
9729                   AVDIPP = 0.5D0*
9730      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9731                   OMPP21 = OMPP21+AVDIPP
9732 C                 OMPP21 = OMPP21+(CONE-PP21(K))
9733                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9734                   DIPP21 = DIPP21+AVDIPP
9735    17          CONTINUE
9736                OMPP12 = CZERO
9737                OMPP22 = CZERO
9738                DIPP12 = CZERO
9739                DIPP22 = CZERO
9740                DO 18 K=1,INT2
9741                   IF (PP12(K).EQ.CZERO) THEN
9742                      PPTMP1 = CZERO
9743                      PPTMP2 = CZERO
9744                   ELSE
9745                      PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM)
9746                      PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM)
9747                   ENDIF
9748                   AVDIPP = 0.5D0*
9749      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9750                   OMPP12 = OMPP12+AVDIPP
9751 C                 OMPP12 = OMPP12+(CONE-PP12(K))
9752                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9753                   DIPP12 = DIPP12+AVDIPP
9754                   IF (PP22(K).EQ.CZERO) THEN
9755                      PPTMP1 = CZERO
9756                      PPTMP2 = CZERO
9757                   ELSE
9758                      PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM)
9759                      PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM)
9760                   ENDIF
9761                   AVDIPP = 0.5D0*
9762      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9763                   OMPP22 = OMPP22+AVDIPP
9764 C                 OMPP22 = OMPP22+(CONE-PP22(K))
9765                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9766                   DIPP22 = DIPP22+AVDIPP
9767    18          CONTINUE
9768
9769                SPROM = ONE-EXP(SHI)
9770                SPROB = SPROB+FACM*SPROM
9771                IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9772                   STOTM = DBLE(OMPP11+OMPP22)
9773                   SELAM = DBLE(OMPP11*DCONJG(OMPP22))
9774                   SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM
9775                   SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM
9776                   SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM
9777                   SDELM = DBLE(DIPP11*DCONJG(DIPP22))
9778                   SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM
9779                   STOTB = STOTB+FACM*STOTM
9780                   SELAB = SELAB+FACM*SELAM
9781                   SDELB = SDELB+FACM*SDELM
9782                   IF (NB.GT.1) THEN
9783                      SQEPB = SQEPB+FACM*SQEPM
9784                      SDQEB = SDQEB+FACM*SDQEM
9785                   ENDIF
9786                   IF (NA.GT.1) SQETB = SQETB+FACM*SQETM
9787                   IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M
9788                   IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD
9789                ENDIF
9790
9791    14       CONTINUE
9792
9793             STOTN = STOTN+FACB*STOTB
9794             SELAN = SELAN+FACB*SELAB
9795             SQEPN = SQEPN+FACB*SQEPB
9796             SQETN = SQETN+FACB*SQETB
9797             SQE2N = SQE2N+FACB*SQE2B
9798             SPRON = SPRON+FACB*SPROB
9799             SDELN = SDELN+FACB*SDELB
9800             SDQEN = SDQEN+FACB*SDQEB
9801
9802             IF (IJPROJ.EQ.7) THEN
9803                BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB)
9804             ELSE
9805                IF (DIBETA.GT.ZERO) THEN
9806                   BPROD(IB+1)= BPROD(IB+1)
9807      &                        +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B)
9808                ELSE
9809                   BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB
9810                ENDIF
9811             ENDIF
9812
9813    12    CONTINUE
9814
9815          STOT  = STOT +FACN*STOTN
9816          STOT2 = STOT2+FACN*STOTN**2
9817          SELA  = SELA +FACN*SELAN
9818          SELA2 = SELA2+FACN*SELAN**2
9819          SQEP  = SQEP +FACN*SQEPN
9820          SQEP2 = SQEP2+FACN*SQEPN**2
9821          SQET  = SQET +FACN*SQETN
9822          SQET2 = SQET2+FACN*SQETN**2
9823          SQE2  = SQE2 +FACN*SQE2N
9824          SQE22 = SQE22+FACN*SQE2N**2
9825          SPRO  = SPRO +FACN*SPRON
9826          SPRO2 = SPRO2+FACN*SPRON**2
9827          SDEL  = SDEL +FACN*SDELN
9828          SDEL2 = SDEL2+FACN*SDELN**2
9829          SDQE  = SDQE +FACN*SDQEN
9830          SDQE2 = SDQE2+FACN*SDQEN**2
9831
9832    11 CONTINUE
9833
9834 * final cross sections
9835 * 1) total
9836       XSTOT(IE,IQ,NTARG) = STOT
9837       IF (IJPROJ.EQ.7)
9838      &   XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR
9839 * 2) elastic
9840       XSELA(IE,IQ,NTARG) = SELA
9841 * 3) quasi-el.: A+B-->A+X (excluding 2)
9842       XSQEP(IE,IQ,NTARG) = SQEP
9843 * 4) quasi-el.: A+B-->X+B (excluding 2)
9844       XSQET(IE,IQ,NTARG) = SQET
9845 * 5) quasi-el.: A+B-->X (excluding 2-4)
9846       XSQE2(IE,IQ,NTARG) = SQE2
9847 * 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
9848       IF (SDEL.GT.ZERO) THEN
9849          XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2
9850       ELSE
9851          XSPRO(IE,IQ,NTARG) = SPRO
9852       ENDIF
9853 * 7) projectile diffraction (el. scatt. off target)
9854       XSDEL(IE,IQ,NTARG) = SDEL
9855 * 8) projectile diffraction (quasi-el. scatt. off target)
9856       XSDQE(IE,IQ,NTARG) = SDQE
9857 *  stat. errors
9858       XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1))
9859       XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1))
9860       XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1))
9861       XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1))
9862       XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1))
9863       XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1))
9864       XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1))
9865       XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1))
9866
9867       IF (IJPROJ.EQ.7) THEN
9868          BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG)
9869      &          -XSQEP(IE,IQ,NTARG)
9870       ELSE
9871          BNORM = XSPRO(IE,IQ,NTARG)
9872       ENDIF
9873       DO 19 I=2,NSITEB
9874          BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1)
9875          IF ((IE.EQ.1).AND.(IQ.EQ.1))
9876      &      BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1)
9877    19 CONTINUE
9878
9879 * write profile function data into file
9880       IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN
9881          WRITE(LDAT,'(5I10,1P,E15.5)')
9882      &      IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE)
9883          WRITE(LDAT,'(1P,6E12.5)')
9884      &      XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG),
9885      &      XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9886          WRITE(LDAT,'(1P,6E12.5)')
9887      &      XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG),
9888      &      XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9889          NLINES = INT(DBLE(NSITEB)/7.0D0)
9890          IF (NLINES.GT.0) THEN
9891             DO 20 I=1,NLINES
9892                ISTART = 7*I-6
9893                WRITE(LDAT,'(1P,7E11.4)')
9894      &            (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9895    20       CONTINUE
9896          ENDIF
9897          ISTART = 7*NLINES+1
9898          IF (ISTART.LE.NSITEB) THEN
9899             WRITE(LDAT,'(1P,7E11.4)')
9900      &         (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9901          ENDIF
9902       ENDIF
9903
9904   100 CONTINUE
9905
9906 C     IF (ABS(IOGLB).EQ.1) CLOSE(LDAT)
9907
9908       RETURN
9909       END
9910
9911 *$ CREATE DT_GETBXS.FOR
9912 *COPY DT_GETBXS
9913 *
9914 *===getbxs=============================================================*
9915 *
9916       SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX)
9917
9918 ************************************************************************
9919 * Biasing in impact parameter space.                                   *
9920 *     XSFRAC = 0 :  BLO    - minimum impact parameter  (input)         *
9921 *                   BHI    - maximum impact parameter  (input)         *
9922 *                   XSFRAC - fraction of cross section corresponding   *
9923 *                            to impact parameter range (BLO,BHI)       *
9924 *                                                      (output)        *
9925 *     XSFRAC > 0 :  XSFRAC - fraction of cross section (input)         *
9926 *                   BHI    - maximum impact parameter giving requested *
9927 *                            fraction of cross section in impact       *
9928 *                            parameter range (0,BMAX)  (output)        *
9929 * This version dated 17.03.00  is written by S. Roesler                *
9930 ************************************************************************
9931
9932       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9933       SAVE
9934       PARAMETER ( LINP = 10 ,
9935      &            LOUT = 6 ,
9936      &            LDAT = 9 )
9937
9938       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9939 * Glauber formalism: parameters
9940       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9941      &                BMAX(NCOMPX),BSTEP(NCOMPX),
9942      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9943      &                NSITEB,NSTATB
9944
9945       NTARG = ABS(NIDX)
9946       IF (XSFRAC.LE.0.0D0) THEN
9947          ILO    = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG)))
9948          IHI    = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG)))
9949          IF (ILO.GE.IHI) THEN
9950             XSFRAC = 0.0D0
9951             RETURN
9952          ENDIF
9953          IF (ILO.EQ.NSITEB-1) THEN
9954             FRCLO = BSITE(0,1,NTARG,NSITEB)
9955          ELSE
9956             FRCLO = BSITE(0,1,NTARG,ILO+1)
9957      &              +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG)
9958      &              *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1))
9959          ENDIF
9960          IF (IHI.EQ.NSITEB-1) THEN
9961             FRCHI = BSITE(0,1,NTARG,NSITEB)
9962          ELSE
9963             FRCHI = BSITE(0,1,NTARG,IHI+1)
9964      &              +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG)
9965      &              *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1))
9966          ENDIF
9967          XSFRAC = FRCHI-FRCLO
9968       ELSE
9969          BLO = 0.0D0
9970          BHI = BMAX(NTARG)
9971          DO 1 I=1,NSITEB-1
9972             IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN
9973                FAC = (XSFRAC              -BSITE(0,1,NTARG,I))/
9974      &               (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I))
9975                BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC
9976                GOTO 2
9977             ENDIF
9978     1    CONTINUE
9979     2    CONTINUE
9980       ENDIF
9981
9982       RETURN
9983       END
9984
9985 *$ CREATE DT_CONUCL.FOR
9986 *COPY DT_CONUCL
9987 *
9988 *===conucl=============================================================*
9989 *
9990       SUBROUTINE DT_CONUCL(X,N,R,MODE)
9991
9992 ************************************************************************
9993 * Calculation of coordinates of nucleons within nuclei.                *
9994 *        X(3,N)   spatial coordinates of nucleons (in fm)  (output)    *
9995 *        N / R    number of nucleons / radius of nucleus   (input)     *
9996 *        MODE = 0 coordinates not sorted                               *
9997 *             = 1 coordinates sorted with increasing X(3,i)            *
9998 *             = 2 coordinates sorted with decreasing X(3,i)            *
9999 * This version dated 26.10.95 is revised by S. Roesler                 *
10000 ************************************************************************
10001
10002       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10003       SAVE
10004       PARAMETER ( LINP = 10 ,
10005      &            LOUT = 6 ,
10006      &            LDAT = 9 )
10007
10008       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10009      &           ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10010
10011       PARAMETER (TWOPI = 6.283185307179586454D+00 )
10012
10013       PARAMETER (NSRT=10)
10014       DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10015       DIMENSION X(3,N),XTMP(3,260)
10016
10017       CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R)
10018
10019       IF ((MODE.NE.0).AND.(N.GT.4)) THEN
10020          K = 0
10021          DO 1 I=1,NSRT
10022             IF (MODE.EQ.2) THEN
10023                ISRT = NSRT+1-I
10024             ELSE
10025                ISRT = I
10026             ENDIF
10027             K1 = K
10028             DO 2 J=1,ICSRT(ISRT)
10029                K = K+1
10030                X(1,K) = XTMP(1,IDXSRT(ISRT,J))
10031                X(2,K) = XTMP(2,IDXSRT(ISRT,J))
10032                X(3,K) = XTMP(3,IDXSRT(ISRT,J))
10033     2       CONTINUE
10034             IF (ICSRT(ISRT).GT.1) THEN
10035                I0 = K1+1
10036                I1 = K
10037                CALL DT_SORT(X,N,I0,I1,MODE)
10038             ENDIF
10039     1    CONTINUE
10040       ELSEIF ((MODE.NE.0).AND.(N.GE.2).AND.(N.LE.4)) THEN
10041          DO 3 I=1,N
10042             X(1,I) = XTMP(1,I)
10043             X(2,I) = XTMP(2,I)
10044             X(3,I) = XTMP(3,I)
10045     3    CONTINUE
10046          CALL DT_SORT(X,N,1,N,MODE)
10047       ELSE
10048          DO 4 I=1,N
10049             X(1,I) = XTMP(1,I)
10050             X(2,I) = XTMP(2,I)
10051             X(3,I) = XTMP(3,I)
10052     4    CONTINUE
10053       ENDIF
10054
10055       RETURN
10056       END
10057
10058 *$ CREATE DT_COORDI.FOR
10059 *COPY DT_COORDI
10060 *
10061 *===coordi=============================================================*
10062 *
10063       SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R)
10064
10065 ************************************************************************
10066 * Calculation of coordinates of nucleons within nuclei.                *
10067 *        X(3,N)   spatial coordinates of nucleons (in fm)  (output)    *
10068 *        N / R    number of nucleons / radius of nucleus   (input)     *
10069 * Based on the original version by Shmakov et al.                      *
10070 * This version dated 26.10.95 is revised by S. Roesler                 *
10071 ************************************************************************
10072
10073       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10074       SAVE
10075       PARAMETER ( LINP = 10 ,
10076      &            LOUT = 6 ,
10077      &            LDAT = 9 )
10078
10079       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10080      &           ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10081
10082       PARAMETER (TWOPI = 6.283185307179586454D+00 )
10083
10084       LOGICAL LSTART
10085
10086       PARAMETER (NSRT=10)
10087       DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10088       DIMENSION X(3,260),WD(4),RD(3)
10089
10090       DATA PDIF/0.545D0/,R2MIN/0.16D0/
10091       DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/
10092       DATA RD /2.09D0, 0.935D0, 0.697D0/
10093
10094       X1SUM = ZERO
10095       X2SUM = ZERO
10096       X3SUM = ZERO
10097
10098       IF (N.EQ.1) THEN
10099          X(1,1) = ZERO
10100          X(2,1) = ZERO
10101          X(3,1) = ZERO
10102       ELSEIF (N.EQ.2) THEN
10103          EPS = DT_RNDM(RD(1))
10104          DO 30 I=1,3
10105             IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40
10106    30    CONTINUE
10107    40    CONTINUE
10108          DO 50 J=1,3
10109             CALL DT_RANNOR(X1,X2)
10110             X(J,1) = RD(I)*X1
10111             X(J,2) = -X(J,1)
10112    50    CONTINUE
10113       ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN
10114          SIGMA = R/SQRTWO
10115          LSTART = .TRUE.
10116          CALL DT_RANNOR(X3,X4)
10117          DO 100 I=1,N
10118             CALL DT_RANNOR(X1,X2)
10119             X(1,I) = SIGMA*X1
10120             X(2,I) = SIGMA*X2
10121             IF (LSTART) GOTO 80
10122             X(3,I) = SIGMA*X4
10123             CALL DT_RANNOR(X3,X4)
10124             GOTO 90
10125    80       CONTINUE
10126             X(3,I) = SIGMA*X3
10127    90       CONTINUE
10128             LSTART = .NOT.LSTART
10129             X1SUM = X1SUM+X(1,I)
10130             X2SUM = X2SUM+X(2,I)
10131             X3SUM = X3SUM+X(3,I)
10132   100    CONTINUE
10133          X1SUM = X1SUM/DBLE(N)
10134          X2SUM = X2SUM/DBLE(N)
10135          X3SUM = X3SUM/DBLE(N)
10136          DO 101 I=1,N
10137             X(1,I) = X(1,I)-X1SUM
10138             X(2,I) = X(2,I)-X2SUM
10139             X(3,I) = X(3,I)-X3SUM
10140   101    CONTINUE
10141       ELSE
10142
10143 * maximum nuclear radius for coordinate sampling
10144          RMAX = R+4.605D0*PDIF
10145
10146 * initialize pre-sorting
10147          DO 121 I=1,NSRT
10148             ICSRT(I) = 0
10149   121    CONTINUE
10150          DR = TWO*RMAX/DBLE(NSRT)
10151
10152 * sample coordinates for N nucleons
10153          DO 140 I=1,N
10154   120       CONTINUE
10155             RAD = RMAX*(DT_RNDM(DR))**ONETHI
10156             F   = DT_DENSIT(N,RAD,R)
10157             IF (DT_RNDM(RAD).GT.F) GOTO 120
10158 *   theta, phi uniformly distributed
10159             CT  = ONE-TWO*DT_RNDM(F)
10160             ST  = SQRT((ONE-CT)*(ONE+CT))
10161             CALL DT_DSFECF(SFE,CFE)
10162             X(1,I) = RAD*ST*CFE
10163             X(2,I) = RAD*ST*SFE
10164             X(3,I) = RAD*CT
10165 *   ensure that distance between two nucleons is greater than R2MIN
10166             IF (I.LT.2) GOTO 122
10167             I1 = I-1
10168             DO 130 I2=1,I1
10169                DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+
10170      &                 (X(3,I)-X(3,I2))**2
10171                IF (DIST2.LE.R2MIN) GOTO 120
10172   130       CONTINUE
10173   122       CONTINUE
10174 *   save index according to z-bin
10175             IDXZ        = INT( (X(3,I)+RMAX)/DR )+1
10176             ICSRT(IDXZ) = ICSRT(IDXZ)+1
10177             IDXSRT(IDXZ,ICSRT(IDXZ)) = I
10178             X1SUM = X1SUM+X(1,I)
10179             X2SUM = X2SUM+X(2,I)
10180             X3SUM = X3SUM+X(3,I)
10181   140    CONTINUE
10182          X1SUM = X1SUM/DBLE(N)
10183          X2SUM = X2SUM/DBLE(N)
10184          X3SUM = X3SUM/DBLE(N)
10185          DO 141 I=1,N
10186             X(1,I) = X(1,I)-X1SUM
10187             X(2,I) = X(2,I)-X2SUM
10188             X(3,I) = X(3,I)-X3SUM
10189   141    CONTINUE
10190
10191       ENDIF
10192
10193       RETURN
10194       END
10195
10196 *$ CREATE DT_DENSIT.FOR
10197 *COPY DT_DENSIT
10198 *
10199 *===densit=============================================================*
10200 *
10201       DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA)
10202
10203       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10204       SAVE
10205
10206       PARAMETER ( LINP = 10 ,
10207      &            LOUT = 6 ,
10208      &            LDAT = 9 )
10209       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10210       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
10211      &           PI    = TWOPI/TWO)
10212
10213       DIMENSION R0(18),FNORM(18)
10214       DATA R0 /  ZERO,   ZERO,   ZERO,   ZERO, 2.12D0,
10215      &         2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0,
10216      &         2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0,
10217      &         2.72D0, 2.66D0, 2.79D0/
10218       DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10219      &            .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10220      &            .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01,
10221      &            .1214D+01,.1265D+01,.1318D+01/
10222       DATA PDIF /0.545D0/
10223
10224       DT_DENSIT = ZERO
10225 * shell model
10226       IF (NA.LE.4) THEN
10227          STOP 'DT_DENSIT-0'
10228       ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN
10229          R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA))
10230          DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2)
10231      &            *EXP(-(R/R1)**2)/FNORM(NA)
10232 * Woods-Saxon
10233       ELSEIF (NA.GT.18) THEN
10234          DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF))
10235       ENDIF
10236
10237       RETURN
10238       END
10239
10240 *$ CREATE DT_RNCLUS.FOR
10241 *COPY DT_RNCLUS
10242 *
10243 *===rnclus=============================================================*
10244 *
10245       DOUBLE PRECISION FUNCTION DT_RNCLUS(N)
10246
10247 ************************************************************************
10248 * Nuclear radius for nucleus with mass number N.                       *
10249 * This version dated 26.9.00  is written by S. Roesler                 *
10250 ************************************************************************
10251
10252       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10253       SAVE
10254
10255       PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)
10256
10257 * nucleon radius
10258       PARAMETER (RNUCLE = 1.12D0)
10259
10260 * nuclear radii for selected nuclei
10261       DIMENSION RADNUC(18)
10262       DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0,
10263      &               2.58D0,2.71D0,2.66D0,2.71D0/
10264
10265       IF (N.LE.18) THEN
10266          IF (RADNUC(N).GT.0.0D0) THEN
10267             DT_RNCLUS = RADNUC(N)
10268          ELSE
10269             DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10270          ENDIF
10271       ELSE
10272          DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10273       ENDIF
10274
10275       RETURN
10276       END
10277
10278 *$ CREATE DT_DENTST.FOR
10279 *COPY DT_DENTST
10280 *
10281 *===dentst=============================================================*
10282 *
10283 C      PROGRAM DT_DENTST
10284       SUBROUTINE DT_DENTST
10285
10286       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10287       SAVE
10288
10289       OPEN(40,FILE='dentst.out',STATUS='UNKNOWN')
10290       OPEN(41,FILE='denmax.out',STATUS='UNKNOWN')
10291
10292       RMIN  = 0.0D0
10293       RMAX  = 8.0D0
10294       NBINS = 500.0D0
10295       DR    = (RMAX-RMIN)/DBLE(NBINS)
10296       DO 1 IA=5,18
10297          FMAX = 0.0D0
10298          DO 2 IR=1,NBINS+1
10299             R = RMIN+DBLE(IR-1)*DR
10300             F = DT_DENSIT(IA,R,R)
10301             IF (F.GT.FMAX) FMAX = F
10302             WRITE(40,'(1X,I3,2E15.5)') IA,R,F
10303     2    CONTINUE
10304          WRITE(41,'(1X,I3,E15.5)') IA,FMAX
10305     1 CONTINUE
10306
10307       CLOSE(40)
10308       CLOSE(41)
10309
10310       END
10311
10312 *$ CREATE DT_SHMAKI.FOR
10313 *COPY DT_SHMAKI
10314 *
10315 *===shmaki=============================================================*
10316 *
10317       SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE)
10318
10319 ************************************************************************
10320 * Initialisation of Glauber formalism. This subroutine has to be       *
10321 * called once (in case of target emulsions as often as many different  *
10322 * target nuclei are considered) before events are sampled.             *
10323 *         NA / NCA   mass number/charge of projectile nucleus          *
10324 *         NB / NCB   mass number/charge of target     nucleus          *
10325 *         IJP        identity of projectile (hadrons/leptons/photons)  *
10326 *         PPN        projectile momentum (for projectile nuclei:       *
10327 *                    momentum per nucleon) in target rest system       *
10328 *         MODE = 0   Glauber formalism invoked                         *
10329 *              = 1   fitted results are loaded from data-file          *
10330 *              = 99  NTARG is forced to be 1                           *
10331 *                    (used in connection with GLAUBERI-card only)      *
10332 * This version dated 22.03.96 is based on the original SHMAKI-routine  *
10333 * and revised by S. Roesler.                                           *
10334 ************************************************************************
10335
10336       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10337       SAVE
10338       PARAMETER ( LINP = 10 ,
10339      &            LOUT = 6 ,
10340      &            LDAT = 9 )
10341       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
10342      &           THREE=3.0D0)
10343
10344       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10345 * Glauber formalism: parameters
10346       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10347      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10348      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10349      &                NSITEB,NSTATB
10350 * Lorentz-parameters of the current interaction
10351       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10352      &                UMO,PPCM,EPROJ,PPROJ
10353 * properties of photon/lepton projectiles
10354       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10355 * kinematical cuts for lepton-nucleus interactions
10356       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
10357      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
10358 * Glauber formalism: cross sections
10359       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10360      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10361      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10362      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10363      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10364      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10365      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10366      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10367      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10368      &                BSLOPE,NEBINI,NQBINI
10369 * cuts for variable energy runs
10370       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
10371 * nucleon-nucleon event-generator
10372       CHARACTER*8 CMODEL
10373       LOGICAL LPHOIN
10374       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10375 * Glauber formalism: flags and parameters for statistics
10376       LOGICAL LPROD
10377       CHARACTER*8 CGLB
10378       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10379
10380       DATA NTARG,ICOUT,IVEOUT /0,0,0/
10381
10382 C     CALL DT_HISHAD
10383 C     STOP
10384
10385       NTARG = NTARG+1
10386       IF (MODE.EQ.99) NTARG = 1
10387       NIDX = -NTARG
10388       IF (MODE.EQ.-1) NIDX = NTARG
10389
10390       IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1
10391       IF (ICOUT.EQ.1) WRITE(LOUT,1000)
10392  1000    FORMAT(//,1X,'SHMAKI:    Glauber formalism (Shmakov et. al) -',
10393      &          ' initialization',/,12X,'--------------------------',
10394      &          '-------------------------',/)
10395
10396       IF (MODE.EQ.2) THEN
10397          CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10398          CALL DT_SHFAST(MODE,PPN,IBACK)
10399          STOP ' Glauber pre-initialization done'
10400       ENDIF
10401       IF (MODE.EQ.1) THEN
10402          CALL DT_PROFBI(NA,NB,PPN,NTARG)
10403       ELSE
10404          IBACK = 1
10405          IF (MODE.EQ.3)  CALL DT_SHFAST(MODE,PPN,IBACK)
10406          IF (IBACK.EQ.1) THEN
10407 * lepton-nucleus (variable energy runs)
10408             IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR.
10409      &          (IJP.EQ.10).OR.(IJP.EQ.11))   THEN
10410                IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10411      &            WRITE(LOUT,1002) NB,NCB
10412  1002          FORMAT(1X,'variable energy run:     projectile-id:  7',
10413      &                '    target A/Z: ',I3,' /',I3,/,/,8X,
10414      &                'E_cm (GeV)    Q^2 (GeV^2)',
10415      &                '    Sigma_tot (mb)     Sigma_in (mb)',/,7X,
10416      &                '--------------------------------',
10417      &                '------------------------------')
10418                AECMLO = LOG10(MIN(UMO,ECMLI))
10419                AECMHI = LOG10(MIN(UMO,ECMHI))
10420                IESTEP = NEB-1
10421                DAECM  = (AECMHI-AECMLO)/DBLE(IESTEP)
10422                IF (AECMLO.EQ.AECMHI) IESTEP = 0
10423                DO 1 I=1,IESTEP+1
10424                   ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10425                   IF (Q2HI.GT.0.1D0) THEN
10426                      IF (Q2LI.LT.0.01D0) THEN
10427                         CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10428                         IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10429      &                     WRITE(LOUT,1003)
10430      &                  ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10431                         Q2LI = 0.01D0
10432                         IBIN = 2
10433                      ELSE
10434                         IBIN = 1
10435                      ENDIF
10436                      IQSTEP = NQB-IBIN
10437                      AQ2LO  = LOG10(Q2LI)
10438                      AQ2HI  = LOG10(Q2HI)
10439                      DAQ2   = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE)
10440                      DO 2 J=IBIN,IQSTEP+IBIN
10441                         Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2)
10442                         CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX)
10443                         IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10444      &                     WRITE(LOUT,1003) ECMNN(I),
10445      &                     Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG)
10446     2                CONTINUE
10447                   ELSE
10448                      CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10449                      IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10450      &                  WRITE(LOUT,1003)
10451      &                  ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10452                   ENDIF
10453  1003             FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3)
10454     1          CONTINUE
10455                IVEOUT = 1
10456             ELSE
10457 * hadron/photon/nucleus-nucleus
10458                IF ((ABS(VAREHI).GT.ZERO).AND.
10459      &             (ABS(VAREHI).GT.ABS(VARELO))) THEN
10460                   IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN
10461                      WRITE(LOUT,1004) NA,NB,NCB
10462  1004                FORMAT(1X,'variable energy run:    projectile-id:',
10463      &                      I3,'    target A/Z: ',I3,' /',I3,/)
10464                      WRITE(LOUT,1005)
10465  1005                FORMAT('  E_cm (GeV)  E_Lab (GeV)  sig_tot^pp (mb)'
10466      &                      ,'  Sigma_tot (mb)  Sigma_prod (mb)',/,
10467      &                      ' -------------------------------------',
10468      &                      '--------------------------------------')
10469                   ENDIF
10470                   AECMLO = LOG10(VARCLO)
10471                   AECMHI = LOG10(VARCHI)
10472                   IESTEP = NEB-1
10473                   DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10474                   IF (AECMLO.EQ.AECMHI) IESTEP = 0
10475                   DO 3 I=1,IESTEP+1
10476                      ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10477                      AMP = 0.938D0
10478                      AMT = 0.938D0
10479                      AMP2 = AMP**2
10480                      AMT2 = AMT**2
10481                      ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT)
10482                      PLAB = SQRT((ELAB+AMP)*(ELAB-AMP))
10483                      CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX)
10484                      IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10485      &                 WRITE(LOUT,1006)
10486      &                 ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10487  1006             FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3)
10488     3             CONTINUE
10489                   IVEOUT = 1
10490                ELSE
10491                   CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10492                ENDIF
10493             ENDIF
10494          ENDIF
10495       ENDIF
10496
10497       IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND.
10498      &    (IOGLB.NE.100)) THEN
10499          WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH,
10500      &                    BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG)
10501  1001    FORMAT(38X,'projectile',
10502      &          '      target',/,1X,'Mass number / charge',
10503      &          17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X,
10504      &          'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X,
10505      &          'Parameters of elastic scattering amplitude:',/,5X,
10506      &          'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ',
10507      &          F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X,
10508      &          'statistics at each b-step',4X,I5,/,/,1X,
10509      &          'Prod. cross section  ',5X,F10.4,' mb',/)
10510       ENDIF
10511
10512       RETURN
10513       END
10514
10515 *$ CREATE DT_PROFBI.FOR
10516 *COPY DT_PROFBI
10517 *
10518 *===profbi=============================================================*
10519 *
10520       SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG)
10521
10522 ************************************************************************
10523 * Integral over profile function (to be used for impact-parameter      *
10524 * sampling during event generation).                                   *
10525 * Fitted results are used.                                             *
10526 *         NA / NB    mass numbers of proj./target nuclei               *
10527 *         PPN        projectile momentum (for projectile nuclei:       *
10528 *                    momentum per nucleon) in target rest system       *
10529 *         NTARG      index of target material (i.e. kind of nucleus)   *
10530 * This version dated 31.05.95 is revised by S. Roesler                 *
10531 ************************************************************************
10532
10533       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10534       SAVE
10535       PARAMETER ( LINP = 10 ,
10536      &            LOUT = 6 ,
10537      &            LDAT = 9 )
10538 CPH      SAVE
10539
10540       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
10541
10542       LOGICAL LSTART
10543       CHARACTER CNAME*80
10544
10545       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10546 * Glauber formalism: parameters
10547       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10548      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10549      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10550      &                NSITEB,NSTATB
10551 * Glauber formalism: cross sections
10552       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10553      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10554      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10555      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10556      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10557      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10558      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10559      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10560      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10561      &                BSLOPE,NEBINI,NQBINI
10562
10563       PARAMETER (NGLMAX=8000)
10564       DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX),
10565      &          GLASIG(NGLMAX),GLAFIT(5,NGLMAX)
10566
10567       DATA LSTART /.TRUE./
10568
10569       IF (LSTART) THEN
10570 * read fit-parameters from file
10571          OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN')
10572          I = 0
10573     1    CONTINUE
10574          READ(47,'(A80)') CNAME
10575          IF (CNAME.EQ.'STOP') GOTO 2
10576          I = I+1
10577          READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I),
10578      &                 GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I),
10579      &                 GLAFIT(4,I),GLAFIT(5,I)
10580          IF (I+1.GT.NGLMAX) THEN
10581             WRITE(LOUT,1000)
10582  1000       FORMAT(1X,'PROFBI:    warning! array size exceeded - ',
10583      &             'program stopped')
10584             STOP
10585          ENDIF
10586          GOTO 1
10587     2    CONTINUE
10588          NGLPAR = I
10589          LSTART = .FALSE.
10590       ENDIF
10591
10592       NNA = NA
10593       NNB = NB
10594       IF (NA.GT.NB) THEN
10595          NNA = NB
10596          NNB = NA
10597       ENDIF
10598       IDXGLA = 0
10599       DO 3 J=1,NGLPAR
10600          IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN
10601             IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1)
10602             DO 4 K=1,J-1
10603                IPOINT = J-K
10604                IF (J.EQ.NGLPAR) IPOINT = J+1-K
10605                IF ((NNA.GT.NGLIP(IPOINT)).OR.
10606      &             (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN
10607                   IF (IPOINT.EQ.1) IPOINT = 0
10608                   NATMP = NGLIP(IPOINT+1)
10609                   IF (PPN.LT.GLAPPN(IPOINT+1)) THEN
10610                      IDXGLA = IPOINT+1
10611                      GOTO 6
10612                   ELSE
10613                      J1BEG = IPOINT+1
10614                      J1END = J
10615 C                    IF (J.EQ.NGLPAR) THEN
10616 C                       J1BEG = IPOINT
10617 C                       J1END = J
10618 C                    ENDIF
10619                      DO 5 J1=J1BEG,J1END
10620                         IF (NGLIP(J1).EQ.NATMP) THEN
10621                            IF (PPN.LT.GLAPPN(J1)) THEN
10622                               IDXGLA = J1
10623                               GOTO 6
10624                            ENDIF
10625                         ELSE
10626                            IDXGLA = J1-1
10627                            GOTO 6
10628                         ENDIF
10629     5                CONTINUE
10630                      IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR)))
10631      &                  IDXGLA = NGLPAR
10632                   ENDIF
10633                ENDIF
10634     4       CONTINUE
10635          ENDIF
10636     3 CONTINUE
10637
10638     6 CONTINUE
10639       IF (IDXGLA.EQ.0) THEN
10640          WRITE(LOUT,1001) NNA,NNB,PPN
10641  1001    FORMAT(1X,'PROFBI:   configuration (NA,NB,PPN = ',
10642      &          2I4,F6.0,') not found ')
10643          STOP
10644       ENDIF
10645
10646 * no interpolation yet available
10647       XSPRO(1,1,NTARG) = GLASIG(IDXGLA)
10648
10649       BSITE(1,1,NTARG,1) = ZERO
10650       DO 10 I=2,NSITEB
10651          XX = DBLE(I)
10652          POLY  = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+
10653      &           GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+
10654      &           GLAFIT(5,IDXGLA)*XX**4
10655          IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY)
10656          BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY))
10657          IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO
10658    10 CONTINUE
10659
10660       RETURN
10661       END
10662
10663 *$ CREATE DT_GLAUBE.FOR
10664 *COPY DT_GLAUBE
10665 *
10666 *===glaube=============================================================*
10667 *
10668       SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX)
10669
10670 ************************************************************************
10671 * Calculation of configuartion of interacting nucleons for one event.  *
10672 *    NB / NB    mass numbers of proj./target nuclei           (input)  *
10673 *    B          impact parameter                              (output) *
10674 *    INTT       total number of wounded nucleons                 "     *
10675 *    INTA / INTB number of wounded nucleons in proj. / target    "     *
10676 *    JS / JT(i) number of collisions proj. / target nucleon i is       *
10677 *                                                   involved  (output) *
10678 *    NIDX       index of projectile/target material            (input) *
10679 *               = -2 call within FLUKA transport calculation           *
10680 * This is an update of the original routine SHMAKO by J.Ranft/HJM      *
10681 * This version dated 22.03.96 is revised by S. Roesler                 *
10682 *                                                                      *
10683 * Last change 27.12.2006 by S. Roesler.                                *
10684 ************************************************************************
10685
10686       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10687       SAVE
10688       PARAMETER ( LINP = 10 ,
10689      &            LOUT = 6 ,
10690      &            LDAT = 9 )
10691       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
10692      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
10693
10694       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10695       PARAMETER ( MAXNCL = 260,
10696      &            MAXVQU = MAXNCL,
10697      &            MAXSQU = 20*MAXVQU,
10698      &            MAXINT = MAXVQU+MAXSQU)
10699 * Glauber formalism: parameters
10700       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10701      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10702      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10703      &                NSITEB,NSTATB
10704 * Glauber formalism: cross sections
10705       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10706      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10707      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10708      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10709      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10710      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10711      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10712      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10713      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10714      &                BSLOPE,NEBINI,NQBINI
10715 * Lorentz-parameters of the current interaction
10716       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10717      &                UMO,PPCM,EPROJ,PPROJ
10718 * properties of photon/lepton projectiles
10719       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10720 * Glauber formalism: collision properties
10721       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
10722      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
10723      &                NCP,NCT
10724 * Glauber formalism: flags and parameters for statistics
10725       LOGICAL LPROD
10726       CHARACTER*8 CGLB
10727       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10728
10729       DIMENSION JS(MAXNCL),JT(MAXNCL)
10730
10731       NTARG = ABS(NIDX)
10732
10733 * get actual energy from /DTLTRA/
10734       ECMNOW = UMO
10735       Q2     = VIRT
10736 *
10737 * new patch for pre-initialized variable projectile/target/energy runs,
10738 * bypassed for use within FLUKA (Nidx=-2)
10739       IF (IOGLB.EQ.100) THEN
10740          IF (NIDX.NE.-2) CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1)
10741 *
10742 * variable energy run, interpolate profile function
10743       ELSE
10744          I1   = 1
10745          I2   = 1
10746          RATE = ONE
10747          IF (NEBINI.GT.1) THEN
10748             IF (ECMNOW.GE.ECMNN(NEBINI)) THEN
10749                I1   = NEBINI
10750                I2   = NEBINI
10751                RATE = ONE
10752             ELSEIF (ECMNOW.GT.ECMNN(1)) THEN
10753                DO 1 I=2,NEBINI
10754                   IF (ECMNOW.LT.ECMNN(I)) THEN
10755                      I1   = I-1
10756                      I2   = I
10757                      RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
10758                      GOTO 2
10759                   ENDIF
10760     1          CONTINUE
10761     2          CONTINUE
10762             ENDIF
10763          ENDIF
10764          J1   = 1
10765          J2   = 1
10766          RATQ = ONE
10767          IF (NQBINI.GT.1) THEN
10768             IF (Q2.GE.Q2G(NQBINI)) THEN
10769                J1   = NQBINI
10770                J2   = NQBINI
10771                RATQ = ONE
10772             ELSEIF (Q2.GT.Q2G(1)) THEN
10773                DO 3 I=2,NQBINI
10774                   IF (Q2.LT.Q2G(I)) THEN
10775                      J1   = I-1
10776                      J2   = I
10777                      RATQ = LOG10(     Q2/MAX(Q2G(J1),TINY14))/
10778      &                      LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
10779 C                    RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1))
10780                      GOTO 4
10781                   ENDIF
10782     3          CONTINUE
10783     4          CONTINUE
10784             ENDIF
10785          ENDIF
10786
10787          DO 5 I=1,KSITEB
10788             BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+
10789      &         RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10790      &         RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10791      &         RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+
10792      &                    BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I))
10793     5    CONTINUE
10794       ENDIF
10795
10796       CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX)
10797       IF (NIDX.LE.-1) THEN
10798          RPROJ = RASH(1)
10799          RTARG = RBSH(NTARG)
10800       ELSE
10801          RPROJ = RASH(NTARG)
10802          RTARG = RBSH(1)
10803       ENDIF
10804
10805       RETURN
10806       END
10807
10808 *$ CREATE DT_DIAGR.FOR
10809 *COPY DT_DIAGR
10810 *
10811 *===diagr==============================================================*
10812 *
10813       SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC,
10814      &                                                         NIDX)
10815
10816 ************************************************************************
10817 * Based on the original version by Shmakov et al.                      *
10818 * This version dated 21.04.95 is revised by S. Roesler                 *
10819 ************************************************************************
10820
10821       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10822       SAVE
10823       PARAMETER ( LINP = 10 ,
10824      &            LOUT = 6 ,
10825      &            LDAT = 9 )
10826       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10827       PARAMETER (TWOPI  = 6.283185307179586454D+00,
10828      &           PI     = TWOPI/TWO,
10829      &           GEV2MB = 0.38938D0,
10830      &           GEV2FM = 0.1972D0,
10831      &           ALPHEM = ONE/137.0D0,
10832 * proton mass
10833      &           AMP    = 0.938D0,
10834      &           AMP2   = AMP**2,
10835 * rho0 mass
10836      &           AMRHO0 = 0.77D0)
10837
10838       COMPLEX*16 C,CA,CI
10839       PARAMETER ( MAXNCL = 260,
10840      &            MAXVQU = MAXNCL,
10841      &            MAXSQU = 20*MAXVQU,
10842      &            MAXINT = MAXVQU+MAXSQU)
10843 * particle properties (BAMJET index convention)
10844       CHARACTER*8  ANAME
10845       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
10846      &                IICH(210),IIBAR(210),K1(210),K2(210)
10847       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10848 * emulsion treatment
10849       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
10850      &                NCOMPO,IEMUL
10851 * Glauber formalism: parameters
10852       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10853      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10854      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10855      &                NSITEB,NSTATB
10856 * Glauber formalism: cross sections
10857       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10858      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10859      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10860      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10861      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10862      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10863      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10864      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10865      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10866      &                BSLOPE,NEBINI,NQBINI
10867 * VDM parameter for photon-nucleus interactions
10868       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
10869 * nucleon-nucleon event-generator
10870       CHARACTER*8 CMODEL
10871       LOGICAL LPHOIN
10872       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10873 **PHOJET105a
10874 C     COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10875 **PHOJET112
10876 C  obsolete cut-off information
10877       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
10878       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10879 **
10880 * coordinates of nucleons
10881       COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
10882 * interface between Glauber formalism and DPM
10883       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
10884      &                INTER1(MAXINT),INTER2(MAXINT)
10885 * statistics: Glauber-formalism
10886       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
10887 * n-n cross section fluctuations
10888       PARAMETER (NBINS = 1000)
10889       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
10890
10891       DIMENSION JS(MAXNCL),JT(MAXNCL),
10892      &          JS0(MAXNCL),JT0(MAXNCL,MAXNCL),
10893      &          JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL)
10894       DIMENSION NWA(0:210),NWB(0:210)
10895
10896       LOGICAL LFIRST
10897       DATA LFIRST /.TRUE./
10898
10899       DATA NTARGO,ICNT /0,0/
10900
10901       NTARG = ABS(NIDX)
10902
10903       IF (LFIRST) THEN
10904          LFIRST = .FALSE.
10905          IF (NCOMPO.EQ.0) THEN
10906             NCALL  = 0
10907             NWAMAX = NA
10908             NWBMAX = NB
10909             DO 17 I=0,210
10910                NWA(I) = 0
10911                NWB(I) = 0
10912    17       CONTINUE
10913          ENDIF
10914       ENDIF
10915       IF (NTARG.EQ.-1) THEN
10916          IF (NCOMPO.EQ.0) THEN
10917             WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons'
10918             WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ',
10919      &                                NCALL,NWAMAX,NWBMAX
10920             DO 18 I=1,MAX(NWAMAX,NWBMAX)
10921                WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)')
10922      &                          I,NWA(I),DBLE(NWA(I))/DBLE(NCALL),
10923      &                            NWB(I),DBLE(NWB(I))/DBLE(NCALL)
10924    18       CONTINUE
10925          ENDIF
10926          RETURN
10927       ENDIF
10928
10929       DCOH   = 1.0D10
10930       IPNT   = 0
10931
10932       SQ2  = Q2
10933       IF (SQ2.LE.ZERO) SQ2 = 0.0001D0
10934       S   = ECMNOW**2
10935       X   = SQ2/(S+SQ2-AMP2)
10936       XNU = (S+SQ2-AMP2)/(TWO*AMP)
10937 * photon projectiles: recalculate photon-nucleon amplitude
10938       IF (IJPROJ.EQ.7) THEN
10939    15    CONTINUE
10940 *  VDM assumption: mass of V-meson
10941          AMV2   = DT_SAM2(SQ2,ECMNOW)
10942          AMV    = SQRT(AMV2)
10943          IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15
10944 *  check for pointlike interaction
10945          CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1)
10946 **sr 27.10.
10947 C        SIGSH  = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
10948          SIGSH  = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
10949 **
10950          ROSH   = 0.1D0
10951          BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2)
10952      &                   +0.25D0*LOG(S/(AMV2+SQ2)))
10953 *  coherence length
10954          IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM
10955       ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
10956          IF (MCGENE.EQ.2) THEN
10957             ZERO1 = ZERO
10958             CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3,
10959      &                                                BSLOPE,0)
10960          ELSE
10961             BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
10962          ENDIF
10963          IF (ECMNOW.LE.3.0D0) THEN
10964             ROSH = -0.43D0
10965          ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN
10966             ROSH = -0.63D0+0.175D0*LOG(ECMNOW)
10967          ELSEIF (ECMNOW.GT.50.0D0) THEN
10968             ROSH = 0.1D0
10969          ENDIF
10970          ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
10971          PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
10972          IF (MCGENE.EQ.2) THEN
10973             ZERO1 = ZERO
10974             CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3,
10975      &                                                  BDUM,0)
10976             SIGSH = SIGSH/10.0D0
10977          ELSE
10978 C           SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
10979             DUMZER = ZERO
10980             CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
10981             SIGSH = SIGSH/10.0D0
10982          ENDIF
10983       ELSE
10984          BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
10985          ROSH   = 0.01D0
10986          ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
10987          PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
10988 C        SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
10989          DUMZER = ZERO
10990          CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
10991          SIGSH = SIGSH/10.0D0
10992       ENDIF
10993       GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
10994       GAM = GSH
10995       RCA = GAM*SIGSH/TWOPI
10996       FCA = -ROSH*RCA
10997       CA  = DCMPLX(RCA,FCA)
10998       CI  = DCMPLX(ONE,ZERO)
10999
11000    16 CONTINUE
11001 * impact parameter
11002       IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX)
11003
11004       NTRY = 0
11005     3 CONTINUE
11006       NTRY = NTRY+1
11007 * initializations
11008       JNT  = 0
11009       DO 1 I=1,NA
11010          JS(I) = 0
11011     1 CONTINUE
11012       DO 2 I=1,NB
11013          JT(I) = 0
11014     2 CONTINUE
11015       IF (IJPROJ.EQ.7) THEN
11016          DO 8 I=1,MAXNCL
11017             JS0(I) = 0
11018             JNT0(I)= 0
11019             DO 9 J=1,NB
11020                JT0(I,J) = 0
11021     9       CONTINUE
11022     8    CONTINUE
11023       ENDIF
11024
11025 * nucleon configuration
11026 C     IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN
11027       IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN
11028 C        CALL DT_CONUCL(PKOO,NA,RASH,2)
11029 C        CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1)
11030          IF (NIDX.LE.-1) THEN
11031             CALL DT_CONUCL(PKOO,NA,RASH(1),0)
11032             CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0)
11033          ELSE
11034             CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0)
11035             CALL DT_CONUCL(TKOO,NB,RBSH(1),0)
11036          ENDIF
11037          NTARGO = NTARG
11038       ENDIF
11039       ICNT = ICNT+1
11040
11041 * LEPTO: pick out one struck nucleon
11042       IF (MCGENE.EQ.3) THEN
11043          JNT     = 1
11044          JS(1)   = 1
11045          IDX     = INT(DT_RNDM(X)*NB)+1
11046          JT(IDX) = 1
11047          B       = ZERO
11048          GOTO 19
11049       ENDIF
11050
11051       DO 4 INA=1,NA
11052 * cross section fluctuations
11053          AFLUC = ONE
11054          IF (IFLUCT.EQ.1) THEN
11055             IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0)
11056             AFLUC = FLUIXX(IFLUK)
11057          ENDIF
11058          KK1  = 1
11059          KINT = 1
11060          DO 5 INB=1,NB
11061 * photon-projectile: check for supression by coherence length
11062             IF (IJPROJ.EQ.7) THEN
11063                IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN
11064                   KK1  = INB
11065                   KINT = KINT+1
11066                ENDIF
11067             ENDIF
11068             QQ1 = B+TKOO(1,INB)-PKOO(1,INA)
11069             QQ2 =   TKOO(2,INB)-PKOO(2,INA)
11070             XY  = GAM*(QQ1*QQ1+QQ2*QQ2)
11071             IF (XY.LE.15.0D0) THEN
11072                C  = CI-CA*AFLUC*EXP(-XY)
11073                AR = DBLE(C)
11074                AI = DIMAG(C)
11075                P  = AR*AR+AI*AI
11076                IF (DT_RNDM(XY).GE.P) THEN
11077                   JNT = JNT+1
11078                   IF (IJPROJ.EQ.7) THEN
11079                      JNT0(KINT) = JNT0(KINT)+1
11080                      IF (JNT0(KINT).GT.MAXNCL) THEN
11081                         WRITE(LOUT,1001) MAXNCL
11082  1001                   FORMAT(1X,
11083      &                        'DIAGR:  no. of requested interactions',
11084      &                        ' exceeds array dimensions ',I4)
11085                         STOP
11086                      ENDIF
11087                      JS0(KINT)      = JS0(KINT)+1
11088                      JT0(KINT,INB)  = JT0(KINT,INB)+1
11089                      JI1(KINT,JNT0(KINT)) = INA
11090                      JI2(KINT,JNT0(KINT)) = INB
11091                   ELSE
11092                      IF (JNT.GT.MAXINT) THEN
11093                         WRITE(LOUT,1000) JNT, MAXINT
11094  1000                   FORMAT(1X,
11095      &                        'DIAGR:  no. of requested interactions ('
11096      &                        ,I4,') exceeds array dimensions (',I4,')')
11097                         STOP
11098                      ENDIF
11099                      JS(INA) = JS(INA)+1
11100                      JT(INB) = JT(INB)+1
11101                      INTER1(JNT) = INA
11102                      INTER2(JNT) = INB
11103                   ENDIF
11104                ENDIF
11105             ENDIF
11106     5    CONTINUE
11107     4 CONTINUE
11108
11109       IF (JNT.EQ.0) THEN
11110          IF (NTRY.LT.500) THEN
11111             GOTO 3
11112          ELSE
11113 C           WRITE(6,*) ' new impact parameter required (old= ',B,')'
11114             GOTO 16
11115          ENDIF
11116       ENDIF
11117
11118       IDIREC = 0
11119       IF (IJPROJ.EQ.7) THEN
11120          K = INT(ONE+DT_RNDM(X)*DBLE(KINT))
11121    10    CONTINUE
11122          IF (JNT0(K).EQ.0) THEN
11123             K = K+1
11124             IF (K.GT.KINT) K = 1
11125             GOTO 10
11126          ENDIF
11127 * supress Glauber-cascade by direct photon processes
11128          CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2)
11129          IF (IPNT.GT.0) THEN
11130             JNT   = 1
11131             JS(1) = 1
11132             DO 11 INB=1,NB
11133                JT(INB) = JT0(K,INB)
11134                IF (JT(INB).GT.0) GOTO 12
11135    11       CONTINUE
11136    12       CONTINUE
11137             INTER1(1) = 1
11138             INTER2(1) = INB
11139             IDIREC    = IPNT
11140          ELSE
11141             JNT   = JNT0(K)
11142             JS(1) = JS0(K)
11143             DO 13 INB=1,NB
11144                JT(INB) = JT0(K,INB)
11145    13       CONTINUE
11146             DO 14 I=1,JNT
11147                INTER1(I) = JI1(K,I)
11148                INTER2(I) = JI2(K,I)
11149    14       CONTINUE
11150          ENDIF
11151       ENDIF
11152
11153    19 CONTINUE
11154       INTA = 0
11155       INTB = 0
11156       DO 6 I=1,NA
11157         IF (JS(I).NE.0) INTA=INTA+1
11158     6 CONTINUE
11159       DO 7 I=1,NB
11160         IF (JT(I).NE.0) INTB=INTB+1
11161     7 CONTINUE
11162       ICWPG = INTA
11163       ICWTG = INTB
11164       ICIG  = JNT
11165       IPGLB = IPGLB+INTA
11166       ITGLB = ITGLB+INTB
11167       NGLB = NGLB+1
11168
11169       IF (NCOMPO.EQ.0) THEN
11170          NCALL = NCALL+1
11171          NWA(INTA) = NWA(INTA)+1
11172          NWB(INTB) = NWB(INTB)+1
11173       ENDIF
11174
11175       RETURN
11176       END
11177
11178 *$ CREATE DT_MODB.FOR
11179 *COPY DT_MODB
11180 *
11181 *===modb===============================================================*
11182 *
11183       SUBROUTINE DT_MODB(B,NIDX)
11184
11185 ************************************************************************
11186 * Sampling of impact parameter of collision.                           *
11187 *    B          impact parameter    (output)                           *
11188 *    NIDX       index of projectile/target material             (input)*
11189 * Based on the original version by Shmakov et al.                      *
11190 * This version dated 21.04.95 is revised by S. Roesler                 *
11191 *                                                                      *
11192 * Last change 27.12.2006 by S. Roesler.                                *
11193 ************************************************************************
11194
11195       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11196       SAVE
11197       PARAMETER ( LINP = 10 ,
11198      &            LOUT = 6 ,
11199      &            LDAT = 9 )
11200       PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0)
11201
11202       LOGICAL LEFT,LFIRST
11203
11204 * central particle production, impact parameter biasing
11205       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
11206       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11207 * Glauber formalism: parameters
11208       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11209      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11210      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11211      &                NSITEB,NSTATB
11212 * Glauber formalism: cross sections
11213       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11214      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11215      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11216      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11217      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11218      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11219      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11220      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11221      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11222      &                BSLOPE,NEBINI,NQBINI
11223
11224       DATA LFIRST /.TRUE./
11225
11226       NTARG = ABS(NIDX)
11227       IF (NIDX.LE.-1) THEN
11228          RA = RASH(1)
11229          RB = RBSH(NTARG)
11230       ELSE
11231          RA = RASH(NTARG)
11232          RB = RBSH(1)
11233       ENDIF
11234
11235       IF (ICENTR.EQ.2) THEN
11236          IF (RA.EQ.RB) THEN
11237             BB = DT_RNDM(B)*(0.3D0*RA)**2
11238             B  = SQRT(BB)
11239          ELSEIF(RA.LT.RB)THEN
11240             BB = DT_RNDM(B)*1.4D0*(RB-RA)**2
11241             B  = SQRT(BB)
11242          ELSEIF(RA.GT.RB)THEN
11243             BB = DT_RNDM(B)*1.4D0*(RA-RB)**2
11244             B  = SQRT(BB)
11245          ENDIF
11246       ELSE
11247     9    CONTINUE
11248          Y  = DT_RNDM(BB)
11249          I0 = 1
11250          I2 = NSITEB
11251    10    CONTINUE
11252          I1 = (I0+I2)/2
11253          LEFT = ((BSITE(0,1,NTARG,I0)-Y)
11254      &          *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO
11255          IF (LEFT) GOTO 20
11256          I0 = I1
11257          GOTO 30
11258    20    CONTINUE
11259          I2 = I1
11260    30    CONTINUE
11261          IF (I2-I0-2) 40,50,60
11262    40    CONTINUE
11263          I1 = I2+1
11264          IF (I1.GT.NSITEB) I1 = I0-1
11265          GOTO 70
11266    50    CONTINUE
11267          I1 = I0+1
11268          GOTO 70
11269    60    CONTINUE
11270          GOTO 10
11271    70    CONTINUE
11272          X0 = DBLE(I0-1)*BSTEP(NTARG)
11273          X1 = DBLE(I1-1)*BSTEP(NTARG)
11274          X2 = DBLE(I2-1)*BSTEP(NTARG)
11275          Y0 = BSITE(0,1,NTARG,I0)
11276          Y1 = BSITE(0,1,NTARG,I1)
11277          Y2 = BSITE(0,1,NTARG,I2)
11278    80    CONTINUE
11279          B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+
11280      &       X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+
11281      &       X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15)
11282 **sr 5.4.98: shift B by half the bin width to be in agreement with BPROD
11283          B = B+0.5D0*BSTEP(NTARG)
11284          IF (B.LT.ZERO) B = X1
11285          IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG)
11286          IF (ICENTR.LT.0) THEN
11287             IF (LFIRST) THEN
11288                LFIRST = .FALSE.
11289                IF (ICENTR.LE.-100) THEN
11290                   BIMIN  = 0.0D0
11291                ELSE
11292                   XSFRAC = 0.0D0
11293                ENDIF
11294                CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG)
11295                WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG),
11296      &                          BIMIN,BIMAX,XSFRAC*100.0D0,
11297      &                          XSFRAC*XSPRO(1,1,NTARG)
11298  10000         FORMAT(/,1X,'DT_MODB:      Biasing in impact parameter',
11299      &                /,15X,'---------------------------'/,/,4X,
11300      &                'average radii of proj / targ :',F10.3,' fm /',
11301      &                F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :',
11302      &                F10.3,' fm',/,/,21X,'b_lo / b_hi :',
11303      &                F10.3,' fm /',F7.3,' fm',/,5X,'percentage of',
11304      &                ' cross section :',F10.3,' %',/,5X,
11305      &                'corresponding cross section :',F10.3,' mb',/)
11306             ENDIF
11307             IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN
11308                B = BIMIN
11309             ELSE
11310                IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9
11311             ENDIF
11312          ENDIF
11313       ENDIF
11314
11315       RETURN
11316       END
11317
11318 *$ CREATE DT_SHFAST.FOR
11319 *COPY DT_SHFAST
11320 *
11321 *===shfast=============================================================*
11322 *
11323       SUBROUTINE DT_SHFAST(MODE,PPN,IBACK)
11324
11325       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11326       SAVE
11327       PARAMETER ( LINP = 10 ,
11328      &            LOUT = 6 ,
11329      &            LDAT = 9 )
11330       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1,
11331      &           ONE=1.0D0,TWO=2.0D0)
11332
11333       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11334 * Glauber formalism: parameters
11335       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11336      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11337      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11338      &                NSITEB,NSTATB
11339 * properties of interacting particles
11340       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11341 * Glauber formalism: cross sections
11342       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11343      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11344      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11345      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11346      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11347      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11348      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11349      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11350      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11351      &                BSLOPE,NEBINI,NQBINI
11352
11353       IBACK = 0
11354
11355       IF (MODE.EQ.2) THEN
11356          OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11357          WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN
11358  1000    FORMAT(1X,8I5,E15.5)
11359          WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11360  1001    FORMAT(1X,4E15.5)
11361          WRITE(47,1002) SIGSH,ROSH,GSH
11362  1002    FORMAT(1X,3E15.5)
11363          DO 10 I=1,100
11364             WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I)
11365    10    CONTINUE
11366          WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11367  1003    FORMAT(1X,2I10,3E15.5)
11368          CLOSE(47)
11369       ELSE
11370          OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11371          READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP
11372          IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND.
11373      &       (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ)
11374      &       .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND.
11375      &       (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN
11376             READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11377             READ(47,1002) SIGSH,ROSH,GSH
11378             DO 11 I=1,100
11379                READ(47,'(1X,E15.5)') BSITE(1,1,1,I)
11380    11       CONTINUE
11381             READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11382          ELSE
11383             IBACK = 1
11384          ENDIF
11385          CLOSE(47)
11386       ENDIF
11387
11388       RETURN
11389       END
11390
11391 *$ CREATE DT_POILIK.FOR
11392 *COPY DT_POILIK
11393 *
11394 *===poilik=============================================================*
11395 *
11396       SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE)
11397
11398       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
11399       SAVE
11400
11401       PARAMETER ( LINP = 10 ,
11402      &            LOUT = 6 ,
11403      &            LDAT = 9 )
11404       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0)
11405       PARAMETER (NE = 8)
11406
11407 **PHOJET105a
11408 C     CHARACTER*8 MDLNA
11409 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
11410 C     PARAMETER (IEETAB=10)
11411 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
11412 **PHOJET110
11413 C  model switches and parameters
11414       CHARACTER*8 MDLNA
11415       INTEGER ISWMDL,IPAMDL
11416       DOUBLE PRECISION PARMDL
11417       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11418 C  energy-interpolation table
11419       INTEGER IEETA2
11420       PARAMETER ( IEETA2 = 20 )
11421       INTEGER ISIMAX
11422       DOUBLE PRECISION SIGTAB,SIGECM
11423       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
11424 **
11425 * VDM parameter for photon-nucleus interactions
11426       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11427 **sr 22.7.97
11428       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11429 * Glauber formalism: cross sections
11430       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11431      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11432      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11433      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11434      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11435      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11436      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11437      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11438      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11439      &                BSLOPE,NEBINI,NQBINI
11440 **
11441
11442       DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/
11443
11444       IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3
11445
11446 * load cross sections from interpolation table
11447       IP = 1
11448       IF(ECM.LE.SIGECM(IP,1)) THEN
11449         I1 = 1
11450         I2 = 1
11451       ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
11452         DO 50 I=2,ISIMAX
11453           IF(ECM.LE.SIGECM(IP,I)) GOTO 200
11454   50    CONTINUE
11455  200    CONTINUE
11456         I1 = I-1
11457         I2 = I
11458       ELSE
11459         WRITE(LOUT,'(/1X,A,2E12.3)')
11460      &    'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
11461         I1 = ISIMAX
11462         I2 = ISIMAX
11463       ENDIF
11464       FAC2 = ZERO
11465       IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
11466      &                     /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
11467       FAC1 = ONE-FAC2
11468
11469       SIGANO = DT_SANO(ECM)
11470
11471 * cross section dependence on photon virtuality
11472       FSUP1 = ZERO
11473       DO  150 I=1,3
11474          FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I)))
11475      &                             /(ONE+VIRT/PARMDL(30+I))**2
11476  150  CONTINUE
11477       FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34))
11478       FAC1  = FAC1*FSUP1
11479       FAC2  = FAC2*FSUP1
11480       FSUP2 = ONE
11481
11482       ECMOLD = ECM
11483       Q2OLD  = VIRT
11484
11485     3 CONTINUE
11486
11487 C     SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
11488       CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2)
11489       IF (ISHAD(1).EQ.1) THEN
11490          SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
11491       ELSE
11492          SIGDIR = ZERO
11493       ENDIF
11494       SIGANO = FSUP1*FSUP2*SIGANO
11495       SIGTOT = SIGTOT-SIGDIR-SIGANO
11496       SIGDIR = SIGDIR/(FSUP1*FSUP2)
11497       SIGANO = SIGANO/(FSUP1*FSUP2)
11498       SIGTOT = SIGTOT+SIGDIR+SIGANO
11499
11500       RR = DT_RNDM(SIGTOT)
11501       IF (RR.LT.SIGDIR/SIGTOT) THEN
11502          IPNT = 1
11503       ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND.
11504      &        (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN
11505          IPNT = 2
11506       ELSE
11507          IPNT = 0
11508       ENDIF
11509       RPNT = (SIGDIR+SIGANO)/SIGTOT
11510 C     WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2
11511 C     WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO
11512 C     WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM
11513 C     WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT
11514       IF (MODE.EQ.1) RETURN
11515
11516 **sr 22.7.97
11517       K1   = 1
11518       K2   = 1
11519       RATE = ZERO
11520       IF (ECM.GE.ECMNN(NEBINI)) THEN
11521          K1   = NEBINI
11522          K2   = NEBINI
11523          RATE = ONE
11524       ELSEIF (ECM.GT.ECMNN(1)) THEN
11525          DO 10 I=2,NEBINI
11526             IF (ECM.LT.ECMNN(I)) THEN
11527                K1   = I-1
11528                K2   = I
11529                RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1))
11530                GOTO 11
11531             ENDIF
11532    10    CONTINUE
11533    11    CONTINUE
11534       ENDIF
11535       J1   = 1
11536       J2   = 1
11537       RATQ = ZERO
11538       IF (NQBINI.GT.1) THEN
11539          IF (VIRT.GE.Q2G(NQBINI)) THEN
11540             J1   = NQBINI
11541             J2   = NQBINI
11542             RATQ = ONE
11543          ELSEIF (VIRT.GT.Q2G(1)) THEN
11544             DO 12 I=2,NQBINI
11545                IF (VIRT.LT.Q2G(I)) THEN
11546                   J1   = I-1
11547                   J2   = I
11548                   RATQ = LOG10(   VIRT/MAX(Q2G(J1),TINY14))/
11549      &                   LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
11550                   GOTO 13
11551                ENDIF
11552    12       CONTINUE
11553    13       CONTINUE
11554          ENDIF
11555       ENDIF
11556       SGA = XSPRO(K1,J1,NTARG)+
11557      &      RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+
11558      &      RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+
11559      &      RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+
11560      &                 XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG))
11561       SDI = DBLE(NB)*SIGDIR
11562       SAN = DBLE(NB)*SIGANO
11563       SPL = SDI+SAN
11564       RR = DT_RNDM(SPL)
11565       IF (RR.LT.SDI/SGA) THEN
11566          IPNT = 1
11567       ELSEIF ((RR.GE.SDI/SGA).AND.
11568      &        (RR.LT.SPL/SGA)) THEN
11569          IPNT = 2
11570       ELSE
11571          IPNT = 0
11572       ENDIF
11573       RPNT = SPL/SGA
11574 C     WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM
11575 **
11576
11577       RETURN
11578       END
11579
11580 *$ CREATE DT_GLBINI.FOR
11581 *COPY DT_GLBINI
11582 *
11583 *===glbini=============================================================*
11584 *
11585       SUBROUTINE DT_GLBINI(WHAT)
11586
11587 ************************************************************************
11588 * Pre-initialization of profile function                               *
11589 * This version dated 28.11.00 is written by S. Roesler.                *
11590 *                                                                      *
11591 * Last change 27.12.2006 by S. Roesler.                                *
11592 ************************************************************************
11593
11594       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11595       SAVE
11596
11597       PARAMETER ( LINP = 10 ,
11598      &            LOUT = 6 ,
11599      &            LDAT = 9 )
11600       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14)
11601
11602       LOGICAL LCMS
11603
11604 * particle properties (BAMJET index convention)
11605       CHARACTER*8  ANAME
11606       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11607      &                IICH(210),IIBAR(210),K1(210),K2(210)
11608 * properties of interacting particles
11609       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11610       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11611 * emulsion treatment
11612       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11613      &                NCOMPO,IEMUL
11614 * Glauber formalism: flags and parameters for statistics
11615       LOGICAL LPROD
11616       CHARACTER*8 CGLB
11617       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11618 * number of data sets other than protons and nuclei
11619 * at the moment = 2 (pions and kaons)
11620       PARAMETER (MAXOFF=2)
11621       DIMENSION IJPINI(5),IOFFST(25)
11622       DATA IJPINI / 13, 15,  0,  0,  0/
11623 * Glauber data-set to be used for hadron projectiles
11624 * (0=proton, 1=pion, 2=kaon)
11625       DATA (IOFFST(K),K=1,25) /
11626      &  0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11627      &  0, 0, 1, 2, 2/
11628 * Acceptance interval for target nucleus mass
11629       PARAMETER (KBACC = 6)
11630 * flags for input different options
11631       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
11632       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
11633      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
11634
11635       PARAMETER (MAXMSS = 100)
11636       DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS)
11637       DIMENSION WHAT(6)
11638
11639       DATA JPEACH,JPSTEP / 18, 5 /
11640
11641 * temporary patch until fix has been implemented in phojet:
11642 *  maximum energy for pion projectile
11643       DATA ECMXPI / 100000.0D0 /
11644 *
11645 *--------------------------------------------------------------------------
11646 * general initializations
11647 *
11648 *  steps in projectile mass number for initialization
11649       IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4))
11650       IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5))
11651 *
11652 *  energy range and binning
11653       ELO  = ABS(WHAT(1))
11654       EHI  = ABS(WHAT(2))
11655       IF (ELO.GT.EHI) ELO = EHI
11656       NEBIN = MAX(INT(WHAT(3)),1)
11657       IF (ELO.EQ.EHI) NEBIN = 0
11658       LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO)
11659       IF (LCMS) THEN
11660          ECMINI = EHI
11661       ELSE
11662          ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2
11663      &                 +2.0D0*AAM(IJTARG)*EHI)
11664       ENDIF
11665 *
11666 *  default arguments for Glauber-routine
11667       XI  = ZERO
11668       Q2I = ZERO
11669 *
11670 *  initialize nuclear parameters, etc.
11671       CALL DT_BERTTP
11672       CALL DT_INCINI
11673 *
11674 *  open Glauber-data output file
11675       IDX = INDEX(CGLB,' ')
11676       K   = 12
11677       IF (IDX.GT.1) K = IDX-1
11678       OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
11679 *
11680 *--------------------------------------------------------------------------
11681 * Glauber-initialization for proton and nuclei projectiles
11682 *
11683 *  initialize phojet for proton-proton interactions
11684       ELAB = ZERO
11685       PLAB = ZERO
11686       CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11687       CALL DT_PHOINI
11688 *
11689 *  record projectile masses
11690       NASAV = 0
11691       NPROJ = MIN(IP,JPEACH)
11692       DO 10 KPROJ=1,NPROJ
11693          NASAV = NASAV+1
11694          IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11695          IASAV(NASAV) = KPROJ
11696    10 CONTINUE
11697       IF (IP.GT.JPEACH) THEN
11698          NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP)
11699          IF (NPROJ.EQ.0) THEN
11700             NASAV = NASAV+1
11701             IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11702             IASAV(NASAV) = IP
11703          ELSE
11704             DO 11 IPROJ=1,NPROJ
11705                KPROJ = JPEACH+IPROJ*JPSTEP
11706                NASAV = NASAV+1
11707                IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11708                IASAV(NASAV) = KPROJ
11709    11       CONTINUE
11710             IF (KPROJ.LT.IP) THEN
11711                NASAV = NASAV+1
11712                IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11713                IASAV(NASAV) = IP
11714             ENDIF
11715          ENDIF
11716       ENDIF
11717 *
11718 *  record target masses
11719       NBSAV = 0
11720       NTARG = 1
11721       IF (NCOMPO.GT.0) NTARG = NCOMPO
11722       DO 12 ITARG=1,NTARG
11723          NBSAV = NBSAV+1
11724          IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! '
11725          IF (NCOMPO.GT.0) THEN
11726             IBSAV(NBSAV) = IEMUMA(ITARG)
11727          ELSE
11728             IBSAV(NBSAV) = IT
11729          ENDIF
11730    12 CONTINUE
11731 *
11732 *  print masses
11733       WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2))
11734  1000 FORMAT(I4,A,1P,2E13.5)
11735       NLINES = DBLE(NASAV)/18.0D0
11736       IF (NLINES.GT.0) THEN
11737          DO 13 I=1,NLINES
11738             IF (I.EQ.1) THEN
11739                WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18)
11740             ELSE
11741                WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I)
11742             ENDIF
11743    13    CONTINUE
11744       ENDIF
11745       I0 = 18*NLINES+1
11746       IF (I0.LE.NASAV) THEN
11747          IF (I0.EQ.1) THEN
11748             WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV)
11749          ELSE
11750             WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV)
11751          ENDIF
11752       ENDIF
11753       NLINES = DBLE(NBSAV)/18.0D0
11754       IF (NLINES.GT.0) THEN
11755          DO 14 I=1,NLINES
11756             IF (I.EQ.1) THEN
11757                WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18)
11758             ELSE
11759                WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I)
11760             ENDIF
11761    14    CONTINUE
11762       ENDIF
11763       I0 = 18*NLINES+1
11764       IF (I0.LE.NBSAV) THEN
11765          IF (I0.EQ.1) THEN
11766             WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV)
11767          ELSE
11768             WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV)
11769          ENDIF
11770       ENDIF
11771 *
11772 *  calculate Glauber-data for each energy and mass combination
11773 *
11774 *   loop over energy bins
11775       ELO = LOG10(ELO)
11776       EHI = LOG10(EHI)
11777       DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE)
11778       DO 1 IE=1,NEBIN+1
11779          E = ELO+DBLE(IE-1)*DEBIN
11780          E = 10**E
11781          IF (LCMS) THEN
11782             E   = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E)
11783             ECM = E
11784          ELSE
11785             PLAB = ZERO
11786             ECM  = ZERO
11787             E    = MAX(AAM(IJPROJ)+0.1D0,E)
11788             CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11789          ENDIF
11790 *
11791 *   loop over projectile and target masses
11792          DO 2 ITARG=1,NBSAV
11793             DO 3 IPROJ=1,NASAV
11794                CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ,
11795      &                                       XI,Q2I,ECM,1,1,-1)
11796     3       CONTINUE
11797     2    CONTINUE
11798 *
11799     1 CONTINUE
11800 *
11801 *--------------------------------------------------------------------------
11802 * Glauber-initialization for pion, kaon, ... projectiles
11803 *
11804       DO 6 IJ=1,MAXOFF
11805 *
11806 *  initialize phojet for this interaction
11807          ELAB = ZERO
11808          PLAB = ZERO
11809          IJPROJ = IJPINI(IJ)
11810          IP     = 1
11811          IPZ    = 1
11812 *
11813 *   temporary patch until fix has been implemented in phojet:
11814          IF (ECMINI.GT.ECMXPI) THEN
11815             CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1)
11816          ELSE
11817             CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11818          ENDIF
11819          CALL DT_PHOINI
11820 *
11821 *  calculate Glauber-data for each energy and mass combination
11822 *
11823 *   loop over energy bins
11824          DO 4 IE=1,NEBIN+1
11825             E = ELO+DBLE(IE-1)*DEBIN
11826             E = 10**E
11827             IF (LCMS) THEN
11828                E   = MAX(2.0D0*AAM(IJPROJ)+TINY14,E)
11829                ECM = E
11830             ELSE
11831                PLAB = ZERO
11832                ECM  = ZERO
11833                E    = MAX(AAM(IJPROJ)+TINY14,E)
11834                CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11835             ENDIF
11836 *
11837 *   loop over projectile and target masses
11838             DO 5 ITARG=1,NBSAV
11839                CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1)
11840     5       CONTINUE
11841 *
11842     4    CONTINUE
11843 *
11844     6 CONTINUE
11845
11846 *--------------------------------------------------------------------------
11847 * close output unit(s), etc.
11848 *
11849       CLOSE(LDAT)
11850
11851       RETURN
11852       END
11853
11854 *$ CREATE DT_GLBSET.FOR
11855 *COPY DT_GLBSET
11856 *
11857 *===glbset=============================================================*
11858 *
11859       SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE)
11860 ************************************************************************
11861 * Interpolation of pre-initialized profile functions                   *
11862 * This version dated 28.11.00 is written by S. Roesler.                *
11863 ************************************************************************
11864
11865       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11866       SAVE
11867
11868       PARAMETER ( LINP = 10 ,
11869      &            LOUT = 6 ,
11870      &            LDAT = 9 )
11871       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
11872
11873       LOGICAL LCMS,LREAD,LFRST1,LFRST2
11874
11875 * particle properties (BAMJET index convention)
11876       CHARACTER*8  ANAME
11877       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11878      &                IICH(210),IIBAR(210),K1(210),K2(210)
11879 * Glauber formalism: flags and parameters for statistics
11880       LOGICAL LPROD
11881       CHARACTER*8 CGLB
11882       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11883       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11884 * Glauber formalism: parameters
11885       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11886      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11887      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11888      &                NSITEB,NSTATB
11889 * Glauber formalism: cross sections
11890       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11891      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11892      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11893      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11894      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11895      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11896      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11897      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11898      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11899      &                BSLOPE,NEBINI,NQBINI
11900 * number of data sets other than protons and nuclei
11901 * at the moment = 2 (pions and kaons)
11902       PARAMETER (MAXOFF=2)
11903       DIMENSION IJPINI(5),IOFFST(25)
11904       DATA IJPINI / 13, 15,  0,  0,  0/
11905 * Glauber data-set to be used for hadron projectiles
11906 * (0=proton, 1=pion, 2=kaon)
11907       DATA (IOFFST(K),K=1,25) /
11908      &  0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11909      &  0, 0, 1, 2, 2/
11910 * Acceptance interval for target nucleus mass
11911       PARAMETER (KBACC = 6)
11912 * emulsion treatment
11913       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11914      &                NCOMPO,IEMUL
11915
11916       PARAMETER (MAXSET=5000,
11917      &           MAXBIN=100)
11918       DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB)
11919       DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6),
11920      &          BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB),
11921      &          IAIDX(10)
11922
11923       DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./
11924 *
11925 * read data from file
11926 *
11927       IF (MODE.EQ.0) THEN
11928
11929          IF (LREAD) RETURN
11930
11931          DO 1 I=1,MAXSET
11932             DO 2 J=1,6
11933                XSIG(I,J) = ZERO
11934                XERR(I,J) = ZERO
11935     2       CONTINUE
11936             DO 3 J=1,KSITEB
11937                BPROFL(I,J) = ZERO
11938     3       CONTINUE
11939     1    CONTINUE
11940          DO 4 I=1,MAXBIN
11941             IABIN(I) = 0
11942             IBBIN(I) = 0
11943     4    CONTINUE
11944          DO 5 I=1,KSITEB
11945             BPRO0(I) = ZERO
11946             BPRO1(I) = ZERO
11947             BPRO(I)  = ZERO
11948     5    CONTINUE
11949
11950          IDX = INDEX(CGLB,' ')
11951          K   = 12
11952          IF (IDX.GT.1) K = IDX-1
11953          OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
11954          WRITE(LOUT,1000) CGLB(1:K)//'.glb'
11955  1000    FORMAT(/,' GLBSET: impact parameter distributions read from ',
11956      &          'file ',A12,/)
11957 *
11958 *  read binning information
11959          READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI
11960 *  return lower energy threshold to Fluka-interface
11961          ELAB = ELO
11962          LCMS = ELO.LT.ZERO
11963          WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:'
11964          IF (LCMS) THEN
11965             WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN
11966          ELSE
11967             WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN
11968          ENDIF
11969  1001    FORMAT(2X,A5,'  E_lo = ',1P,E9.3,'  E_hi = ',1P,E9.3,4X,
11970      &          'No. of bins:',I5,/)
11971          ELO  = LOG10(ABS(ELO))
11972          EHI  = LOG10(ABS(EHI))
11973          DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN))
11974          WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)'
11975          READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18)
11976          IF (NABIN.LT.18) THEN
11977             WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN)
11978          ELSE
11979             WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18)
11980          ENDIF
11981          IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !'
11982          IF (NABIN.GT.18) THEN
11983             NLINES = DBLE(NABIN-18)/18.0D0
11984             IF (NLINES.GT.0) THEN
11985                DO 7 I=1,NLINES
11986                   I0 = 18*(I+1)-17
11987                   READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
11988                   WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
11989     7          CONTINUE
11990             ENDIF
11991             I0 = 18*(NLINES+1)+1
11992             IF (I0.LE.NABIN) THEN
11993                READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
11994                WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
11995             ENDIF
11996          ENDIF
11997          WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)'
11998          READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18)
11999          IF (NBBIN.LT.18) THEN
12000             WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN)
12001          ELSE
12002             WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18)
12003          ENDIF
12004          IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !'
12005          IF (NBBIN.GT.18) THEN
12006             NLINES = DBLE(NBBIN-18)/18.0D0
12007             IF (NLINES.GT.0) THEN
12008                DO 8 I=1,NLINES
12009                   I0 = 18*(I+1)-17
12010                   READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12011                   WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12012     8          CONTINUE
12013             ENDIF
12014             I0 = 18*(NLINES+1)+1
12015             IF (I0.LE.NBBIN) THEN
12016                READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12017                WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12018             ENDIF
12019          ENDIF
12020 *  number of data sets to follow in the Glauber data file
12021 *   this variable is used for checks of consistency of projectile
12022 *   and target mass configurations given in header of Glauber data
12023 *   file and the data-sets which follow in this file
12024          NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN
12025 *
12026 *  read profile function data
12027          NSET  = 0
12028          NAIDX = 0
12029          IPOLD = 0
12030    10    CONTINUE
12031          NSET = NSET+1
12032          IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! '
12033          READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM
12034  1002    FORMAT(5I10,E15.5)
12035          IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN
12036             NAIDX = NAIDX+1
12037             IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !'
12038             IAIDX(NAIDX) = IP
12039             IPOLD = IP
12040          ENDIF
12041          READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6)
12042          READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6)
12043          NLINES = INT(DBLE(ISITEB)/7.0D0)
12044          IF (NLINES.GT.0) THEN
12045             DO 11 I=1,NLINES
12046                READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I)
12047    11       CONTINUE
12048          ENDIF
12049          I0 = 7*NLINES+1
12050          IF (I0.LE.ISITEB)
12051      &      READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB)
12052          GOTO 10
12053   100    CONTINUE
12054          NSET = NSET-1
12055          IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !'
12056          WRITE(LOUT,'(/,1X,A)')
12057      &   ' projectiles other than protons and nuclei: (particle index)'
12058          IF (NAIDX.GT.0) THEN
12059             WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX)
12060          ELSE
12061             WRITE(LOUT,'(6X,A)') 'none'
12062          ENDIF
12063 *
12064          CLOSE(LDAT)
12065          WRITE(LOUT,*)
12066          LREAD = .TRUE.
12067
12068          IF (NCOMPO.EQ.0) THEN
12069             DO 12 J=1,NBBIN
12070                NCOMPO = NCOMPO+1
12071                IEMUMA(NCOMPO) = IBBIN(J)
12072                IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2
12073                EMUFRA(NCOMPO) = 1.0D0
12074    12       CONTINUE
12075             IEMUL = 1
12076          ENDIF
12077 *
12078 * calculate profile function for certain set of parameters
12079 *
12080       ELSE
12081
12082 c        write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE
12083 *
12084 * check for type of projectile and set index-offset to entry in
12085 * Glauber data array correspondingly
12086          IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !'
12087          IF (IOFFST(IDPROJ).EQ.-1) THEN
12088             STOP ' GLBSET: no data for this projectile !'
12089          ELSEIF (IOFFST(IDPROJ).GT.0) THEN
12090             IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN
12091          ELSE
12092             IDXOFF = 0
12093          ENDIF
12094 *
12095 * get energy bin and interpolation factor
12096          IF (LCMS) THEN
12097             E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB)
12098          ELSE
12099             E = ELAB
12100          ENDIF
12101          E = LOG10(E)
12102          IF (E.LT.ELO) THEN
12103             IF (LFRST1) THEN
12104                WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E
12105                LFRST1 = .FALSE.
12106             ENDIF
12107             E = ELO
12108          ENDIF
12109          IF (E.GT.EHI) THEN
12110             IF (LFRST2) THEN
12111                WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E
12112                LFRST2 = .FALSE.
12113             ENDIF
12114             E = EHI
12115          ENDIF
12116          IE0  = (E-ELO)/DEBIN+1
12117          IE1  = IE0+1
12118          FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN
12119 *
12120 * get target nucleus index
12121          KB = 0
12122          NBACC = KBACC
12123          DO 20 I=1,NBBIN
12124             NBDIFF = ABS(NB-IBBIN(I))
12125             IF (NB.EQ.IBBIN(I)) THEN
12126                KB = I
12127                GOTO 21
12128             ELSEIF (NBDIFF.LE.NBACC) THEN
12129                KB = I
12130                NBACC = NBDIFF
12131             ENDIF
12132    20    CONTINUE
12133          IF (KB.NE.0) GOTO 21
12134          WRITE(LOUT,*) ' GLBSET: data not found for target ',NB
12135          STOP
12136    21    CONTINUE
12137 *
12138 * get projectile nucleus bin and interpolation factor
12139          KA0 = 0
12140          KA1 = 0
12141          FACNA = 0
12142          IF (IDXOFF.GT.0) THEN
12143             KA0 = 1
12144             KA1 = 1
12145             KABIN = 1
12146          ELSE
12147             IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !'
12148             DO 22 I=1,NABIN
12149                IF (NA.EQ.IABIN(I)) THEN
12150                   KA0 = I
12151                   KA1 = I
12152                   GOTO 23
12153                ELSEIF (NA.LT.IABIN(I)) THEN
12154                   KA0 = I-1
12155                   KA1 = I
12156                   GOTO 23
12157                ENDIF
12158    22       CONTINUE
12159             WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA
12160             STOP
12161    23       CONTINUE
12162             IF (KA0.NE.KA1)
12163      &         FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0))
12164             KABIN = NABIN
12165          ENDIF
12166 *
12167 * interpolate profile functions for interactions ka0-kb and ka1-kb
12168 * for energy E separately
12169          IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12170          IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12171          IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12172          IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12173          DO 30 I=1,ISITEB
12174             BPRO0(I) = BPROFL(IDX0,I)
12175      &                 +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I))
12176             BPRO1(I) = BPROFL(IDY0,I)
12177      &                 +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I))
12178    30    CONTINUE
12179          RADB  = DT_RNCLUS(NB)
12180          BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1)
12181          BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1)
12182 *
12183 * interpolate cross sections for energy E and projectile mass
12184          DO 31 I=1,6
12185             XS0   = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I))
12186             XS1   = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I))
12187             XS(I) = XS0+FACNA*(XS1-XS0)
12188             XE0   = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I))
12189             XE1   = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I))
12190             XE(I) = XE0+FACNA*(XE1-XE0)
12191    31    CONTINUE
12192 *
12193 * interpolate between ka0 and ka1
12194          RADA = DT_RNCLUS(NA)
12195          BMX  = 2.0D0*(RADA+RADB)
12196          BSTP = BMX/DBLE(ISITEB-1)
12197          BPRO(1) = ZERO
12198          DO 32 I=1,ISITEB-1
12199             B = DBLE(I)*BSTP
12200 *
12201 *   calculate values of profile functions at B
12202             IDX0 = B/BSTP0+1
12203             IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12204             IDX1 = MIN(IDX0+1,ISITEB)
12205             FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0
12206             BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0))
12207             IDX0 = B/BSTP1+1
12208             IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12209             IDX1 = MIN(IDX0+1,ISITEB)
12210             FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1
12211             BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0))
12212 *
12213             BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0)
12214    32    CONTINUE
12215 *
12216 * fill common dtglam
12217          NSITEB   = ISITEB
12218          RASH(1)  = RADA
12219          RBSH(1)  = RADB
12220          BMAX(1)  = BMX
12221          BSTEP(1) = BSTP
12222          DO 33 I=1,KSITEB
12223             BSITE(0,1,1,I) = BPRO(I)
12224    33    CONTINUE
12225 *
12226 * fill common dtglxs
12227          XSTOT(1,1,1) = XS(1)
12228          XSELA(1,1,1) = XS(2)
12229          XSQEP(1,1,1) = XS(3)
12230          XSQET(1,1,1) = XS(4)
12231          XSQE2(1,1,1) = XS(5)
12232          XSPRO(1,1,1) = XS(6)
12233          XETOT(1,1,1) = XE(1)
12234          XEELA(1,1,1) = XE(2)
12235          XEQEP(1,1,1) = XE(3)
12236          XEQET(1,1,1) = XE(4)
12237          XEQE2(1,1,1) = XE(5)
12238          XEPRO(1,1,1) = XE(6)
12239
12240       ENDIF
12241
12242       RETURN
12243       END
12244
12245 *$ CREATE DT_XKSAMP.FOR
12246 *COPY DT_XKSAMP
12247 *
12248 *===xksamp=============================================================*
12249 *
12250       SUBROUTINE DT_XKSAMP(NN,ECM)
12251
12252 ************************************************************************
12253 * Sampling of parton x-values and chain system for one interaction.    *
12254 *                                   processed by S. Roesler, 9.8.95    *
12255 ************************************************************************
12256
12257       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12258       SAVE
12259       PARAMETER ( LINP = 10 ,
12260      &            LOUT = 6 ,
12261      &            LDAT = 9 )
12262       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
12263 CPH      SAVE
12264
12265       PARAMETER (
12266 * lower cuts for (valence-sea/sea-valence) chain masses
12267 *   antiquark-quark (u/d-sea quark)    (s-sea quark)
12268      &               AMIU = 0.5D0,      AMIS = 0.8D0,
12269 *   quark-diquark   (u/d-sea quark)    (s-sea quark)
12270      &               AMAU = 2.6D0,      AMAS = 2.6D0,
12271 * maximum lower valence-x threshold
12272      &           XVMAX  = 0.98D0,
12273 * fraction of sea-diquarks sampled out of sea-partons
12274 **test
12275 C    &           FRCDIQ = 0.9D0,
12276 **
12277 *
12278      &           SQMA   = 0.7D0,
12279 *
12280 * maximum number of trials to generate x's for the required number
12281 * of sea quark pairs for a given hadron
12282      &           NSEATY = 12
12283 C    &           NSEATY = 3
12284      &          )
12285
12286       LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO
12287
12288       PARAMETER ( MAXNCL = 260,
12289      &            MAXVQU = MAXNCL,
12290      &            MAXSQU = 20*MAXVQU,
12291      &            MAXINT = MAXVQU+MAXSQU)
12292 * event history
12293       PARAMETER (NMXHKK=200000)
12294       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
12295      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
12296      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
12297 * particle properties (BAMJET index convention)
12298       CHARACTER*8  ANAME
12299       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12300      &                IICH(210),IIBAR(210),K1(210),K2(210)
12301 * interface between Glauber formalism and DPM
12302       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
12303      &                INTER1(MAXINT),INTER2(MAXINT)
12304 * properties of interacting particles
12305       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12306 * threshold values for x-sampling (DTUNUC 1.x)
12307       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
12308      &                SSMIMQ,VVMTHR
12309 * x-values of partons (DTUNUC 1.x)
12310       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
12311      &                XTVQ(MAXVQU),XTVD(MAXVQU),
12312      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
12313      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
12314 * flavors of partons (DTUNUC 1.x)
12315       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
12316      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
12317      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
12318      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
12319      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
12320      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
12321      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
12322 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12323       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
12324      &                IXPV,IXPS,IXTV,IXTS,
12325      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
12326      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
12327      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
12328      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
12329      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
12330      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
12331      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
12332      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
12333 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12334       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
12335      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
12336 * auxiliary common for chain system storage (DTUNUC 1.x)
12337       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
12338 * flags for input different options
12339       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12340       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12341      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12342 * various options for treatment of partons (DTUNUC 1.x)
12343 * (chain recombination, Cronin,..)
12344       LOGICAL LCO2CR,LINTPT
12345       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
12346      &                LCO2CR,LINTPT
12347
12348       DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU),
12349      &          INTLO(MAXINT)
12350
12351 * (1) initializations
12352 *-----------------------------------------------------------------------
12353
12354 **test
12355       IF (ECM.LT.4.5D0) THEN
12356 C        FRCDIQ = 0.6D0
12357          FRCDIQ = 0.4D0
12358       ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN
12359 C        FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0
12360          FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0
12361       ELSE
12362 C        FRCDIQ = 0.9D0
12363          FRCDIQ = 0.7D0
12364       ENDIF
12365 **
12366       DO 30 I=1,MAXSQU
12367          ZUOSP(I) = .FALSE.
12368          ZUOST(I) = .FALSE.
12369          IF (I.LE.MAXVQU) THEN
12370             ZUOVP(I) = .FALSE.
12371             ZUOVT(I) = .FALSE.
12372          ENDIF
12373    30 CONTINUE
12374
12375 * lower thresholds for x-selection
12376 *  sea-quarks       (default: CSEA=0.2)
12377       IF (ECM.LT.10.0D0) THEN
12378 **!!test
12379          XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM
12380 C        XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0
12381          NSEA  = NSEATY
12382 C        XSTHR = ONE/ECM**2
12383       ELSE
12384 **sr 30.3.98
12385 C        XSTHR = CSEA/ECM
12386          XSTHR = CSEA/ECM**2
12387 C        XSTHR = ONE/ECM**2
12388 **
12389          IF ((IP.GE.150).AND.(IT.GE.150))
12390      &      XSTHR = 2.5D0/(ECM*SQRT(ECM))
12391          NSEA  = NSEATY
12392       ENDIF
12393 *                   (default: SSMIMA=0.14) used for sea-diquarks (?)
12394       XSSTHR = SSMIMA/ECM
12395       BSQMA  = SQMA/ECM
12396 *  valence-quarks   (default: CVQ=1.0)
12397       XVTHR  = CVQ/ECM
12398 *  valence-diquarks (default: CDQ=2.0)
12399       XDTHR  = CDQ/ECM
12400
12401 * maximum-x for sea-quarks
12402       XVCUT  = XVTHR+XDTHR
12403       IF (XVCUT.GT.XVMAX) THEN
12404          XVCUT = XVMAX
12405          XVTHR = XVCUT/3.0D0
12406          XDTHR = XVCUT-XVTHR
12407       ENDIF
12408       XXSEAM = ONE-XVCUT
12409 **sr 18.4. test: DPMJET
12410 C     XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1))
12411 C    &            - XDTHR*(1.D0+0.3D0*DT_RNDM(V2))
12412 C    &             -0.01*(1.D0+1.5D0*DT_RNDM(V3))
12413 **
12414 * maximum number of sea-pairs allowed kinematically
12415 C     NSMAX  = INT(OHALF*XXSEAM/XSTHR)
12416       RNSMAX = OHALF*XXSEAM/XSTHR
12417       IF (RNSMAX.GT.10000.0D0) THEN
12418          NSMAX = 10000
12419       ELSE
12420          NSMAX = INT(OHALF*XXSEAM/XSTHR)
12421       ENDIF
12422 * check kinematical limit for valence-x thresholds
12423 * (should be obsolete now)
12424       IF (XVCUT.GT.XVMAX) THEN
12425          WRITE(LOUT,1000) XVCUT,ECM
12426  1000    FORMAT(' XKSAMP:    kin. limit for valence-x',
12427      &          '  thresholds not allowed (',2E9.3,')')
12428 C        XVTHR = XVMAX-XDTHR
12429 C        IF (XVTHR.LT.ZERO) STOP
12430          STOP
12431       ENDIF
12432
12433 * set eta for valence-x sampling (BETREJ)
12434 *   (UNON per default, UNOM used for projectile mesons only)
12435       IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN
12436          UNOPRV = UNOM
12437       ELSE
12438          UNOPRV = UNON
12439       ENDIF
12440
12441 * (2) select parton x-values of interacting projectile nucleons
12442 *-----------------------------------------------------------------------
12443
12444       IXPV = 0
12445       IXPS = 0
12446
12447       DO 100 IPP=1,IP
12448 *   get interacting projectile nucleon as sampled by Glauber
12449          IF (JSSH(IPP).NE.0) THEN
12450             IXSTMP = IXPS
12451             IXVTMP = IXPV
12452    99       CONTINUE
12453             IXPS   = IXSTMP
12454             IXPV   = IXVTMP
12455 *     JIPP is the actual number of sea-pairs sampled for this nucleon
12456             JIPP   = MIN(JSSH(IPP)-1,NSMAX)
12457    41       CONTINUE
12458             XXSEA  = ZERO
12459             IF (JIPP.GT.0) THEN
12460                XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR
12461 *???
12462                IF (XSTHR.GE.XSMAX) THEN
12463                   JIPP = JIPP-1
12464                   GOTO 41
12465                ENDIF
12466
12467 *>>>get x-values of sea-quark pairs
12468                NSCOUN = 0
12469                PLW = 0.5D0
12470    40          CONTINUE
12471 *     accumulator for sea x-values
12472                XXSEA  = ZERO
12473                NSCOUN = NSCOUN+1
12474                IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12475                IF (NSCOUN.GT.NSEA) THEN
12476 *     decrease the number of interactions after NSEA trials
12477                   JIPP   = JIPP-1
12478                   NSCOUN = 0
12479                ENDIF
12480                DO 70 ISQ=1,JIPP
12481 *     sea-quarks
12482                   IF (IPSQ(IXPS+1).LE.2) THEN
12483 **sr 8.4.98 (1/sqrt(x))
12484 C                    XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12485 C                    XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12486                      XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12487 **
12488                   ELSE
12489                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
12490                         XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12491                      ELSE
12492 **sr 8.4.98 (1/sqrt(x))
12493 C                       XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12494 C                       XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12495                         XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12496 **
12497                      ENDIF
12498                   ENDIF
12499 *     sea-antiquarks
12500                   IF (IPSAQ(IXPS+1).GE.-2) THEN
12501 **sr 8.4.98 (1/sqrt(x))
12502 C                    XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12503 C                    XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12504                      XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12505 **
12506                   ELSE
12507                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
12508                         XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12509                      ELSE
12510 **sr 8.4.98 (1/sqrt(x))
12511 C                       XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12512 C                       XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12513                         XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12514 **
12515                      ENDIF
12516                   ENDIF
12517                   XXSEA = XXSEA+XPSQI+XPSAQI
12518 *     check for maximum allowed sea x-value
12519                   IF (XXSEA.GE.XXSEAM) THEN
12520                      IXPS = IXPS-ISQ+1
12521                      GOTO 40
12522                   ENDIF
12523 *     accept this sea-quark pair
12524                   IXPS         = IXPS+1
12525                   XPSQ(IXPS)   = XPSQI
12526                   XPSAQ(IXPS)  = XPSAQI
12527                   IFROSP(IXPS) = IPP
12528                   ZUOSP(IXPS)  = .TRUE.
12529    70          CONTINUE
12530             ENDIF
12531
12532 *>>>get x-values of valence partons
12533 *     valence quark
12534             IF (XVTHR.GT.0.05D0) THEN
12535                XVHI  = ONE-XXSEA-XDTHR
12536                XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI)
12537             ELSE
12538    90          CONTINUE
12539                XPVQI = DT_DBETAR(OHALF,UNOPRV)
12540                IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR))
12541      &                                                     GOTO 90
12542             ENDIF
12543 *     valence diquark
12544             XPVDI = ONE-XPVQI-XXSEA
12545 *       reject according to x**1.5
12546             XDTMP = XPVDI**1.5D0
12547             IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99
12548 *     accept these valence partons
12549             IXPV         = IXPV+1
12550             XPVQ(IXPV)   = XPVQI
12551             XPVD(IXPV)   = XPVDI
12552             IFROVP(IXPV) = IPP
12553             ITOVP(IPP)   = IXPV
12554             ZUOVP(IXPV)  = .TRUE.
12555
12556          ENDIF
12557   100 CONTINUE
12558
12559 * (3) select parton x-values of interacting target nucleons
12560 *-----------------------------------------------------------------------
12561
12562       IXTV = 0
12563       IXTS = 0
12564
12565       DO 170 ITT=1,IT
12566 *   get interacting target nucleon as sampled by Glauber
12567          IF (JTSH(ITT).NE.0) THEN
12568             IXSTMP = IXTS
12569             IXVTMP = IXTV
12570   169       CONTINUE
12571             IXTS   = IXSTMP
12572             IXTV   = IXVTMP
12573 *     JITT is the actual number of sea-pairs sampled for this nucleon
12574             JITT   = MIN(JTSH(ITT)-1,NSMAX)
12575   111       CONTINUE
12576             XXSEA  = ZERO
12577             IF (JITT.GT.0) THEN
12578                XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR
12579 *???
12580                IF (XSTHR.GE.XSMAX) THEN
12581                   JITT = JITT-1
12582                   GOTO 111
12583                ENDIF
12584
12585 *>>>get x-values of sea-quark pairs
12586                NSCOUN = 0
12587                PLW = 0.5D0
12588   110          CONTINUE
12589 *     accumulator for sea x-values
12590                XXSEA  = ZERO
12591                NSCOUN = NSCOUN+1
12592                IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12593                IF (NSCOUN.GT.NSEA)THEN
12594 *     decrease the number of interactions after NSEA trials
12595                   JITT   = JITT-1
12596                   NSCOUN = 0
12597                ENDIF
12598                DO 140 ISQ=1,JITT
12599 *     sea-quarks
12600                   IF (ITSQ(IXTS+1).LE.2) THEN
12601 **sr 8.4.98 (1/sqrt(x))
12602 C                    XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12603 C                    XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12604                      XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12605 **
12606                   ELSE
12607                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
12608                         XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12609                      ELSE
12610 **sr 8.4.98 (1/sqrt(x))
12611 C                       XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12612 C                       XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12613                         XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12614 **
12615                      ENDIF
12616                   ENDIF
12617 *     sea-antiquarks
12618                   IF (ITSAQ(IXTS+1).GE.-2) THEN
12619 **sr 8.4.98 (1/sqrt(x))
12620 C                    XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12621 C                    XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12622                      XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12623 **
12624                   ELSE
12625                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
12626                         XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12627                      ELSE
12628 **sr 8.4.98 (1/sqrt(x))
12629 C                       XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12630 C                       XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12631                         XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12632 **
12633                      ENDIF
12634                   ENDIF
12635                   XXSEA = XXSEA+XTSQI+XTSAQI
12636 *     check for maximum allowed sea x-value
12637                   IF (XXSEA.GE.XXSEAM) THEN
12638                      IXTS = IXTS-ISQ+1
12639                      GOTO 110
12640                   ENDIF
12641 *     accept this sea-quark pair
12642                   IXTS         = IXTS+1
12643                   XTSQ(IXTS)   = XTSQI
12644                   XTSAQ(IXTS)  = XTSAQI
12645                   IFROST(IXTS) = ITT
12646                   ZUOST(IXTS)  = .TRUE.
12647   140          CONTINUE
12648             ENDIF
12649
12650 *>>>get x-values of valence partons
12651 *     valence quark
12652             IF (XVTHR.GT.0.05D0) THEN
12653                XVHI  = ONE-XXSEA-XDTHR
12654                XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI)
12655             ELSE
12656   160          CONTINUE
12657                XTVQI = DT_DBETAR(OHALF,UNON)
12658                IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR))
12659      &                                                    GOTO 160
12660             ENDIF
12661 *     valence diquark
12662             XTVDI = ONE-XTVQI-XXSEA
12663 *       reject according to x**1.5
12664             XDTMP = XTVDI**1.5D0
12665             IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169
12666 *     accept these valence partons
12667             IXTV         = IXTV+1
12668             XTVQ(IXTV)   = XTVQI
12669             XTVD(IXTV)   = XTVDI
12670             IFROVT(IXTV) = ITT
12671             ITOVT(ITT)   = IXTV
12672             ZUOVT(IXTV)  = .TRUE.
12673
12674          ENDIF
12675   170 CONTINUE
12676
12677 * (4) get valence-valence chains
12678 *-----------------------------------------------------------------------
12679
12680       NVV = 0
12681       DO 240 I=1,NN
12682          INTLO(I) = .TRUE.
12683          IPVAL    = ITOVP(INTER1(I))
12684          ITVAL    = ITOVT(INTER2(I))
12685          IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN
12686             INTLO(I)      = .FALSE.
12687             ZUOVP(IPVAL)  = .FALSE.
12688             ZUOVT(ITVAL)  = .FALSE.
12689             NVV           = NVV+1
12690             ISKPCH(8,NVV) = 0
12691             INTVV1(NVV)   = IPVAL
12692             INTVV2(NVV)   = ITVAL
12693          ENDIF
12694   240 CONTINUE
12695
12696 * (5) get sea-valence chains
12697 *-----------------------------------------------------------------------
12698
12699       NSV = 0
12700       NDV = 0
12701       PLW = 0.5D0
12702       DO 270 I=1,NN
12703          IF (INTLO(I)) THEN
12704             IPVAL = ITOVP(INTER1(I))
12705             ITVAL = ITOVT(INTER2(I))
12706             DO 250 J=1,IXPS
12707                IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND.
12708      &                                ZUOVT(ITVAL)) THEN
12709                   ZUOSP(J)     = .FALSE.
12710                   ZUOVT(ITVAL) = .FALSE.
12711                   INTLO(I)     = .FALSE.
12712                   IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN
12713 *   sample sea-diquark pair
12714                      CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1)
12715                      IF (IREJ1.EQ.0) GOTO 260
12716                   ENDIF
12717                   NSV           = NSV+1
12718                   ISKPCH(4,NSV) = 0
12719                   INTSV1(NSV)   = J
12720                   INTSV2(NSV)   = ITVAL
12721
12722 *>>>correct chain kinematics according to minimum chain masses
12723 *     the actual chain masses
12724                   AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2
12725                   AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2
12726 *     get lower mass cuts
12727                   IF (IPSQ(J).EQ.3) THEN
12728 *       q being s-quark
12729                      AMCHK1 = AMAS
12730                      AMCHK2 = AMIS
12731                   ELSE
12732 *       q being u/d-quark
12733                      AMCHK1 = AMAU
12734                      AMCHK2 = AMIU
12735                   ENDIF
12736 *       q-qq chain
12737 *         chain mass above minimum - resampling of sea-q x-value
12738                   IF (AMSVQ1.GT.AMCHK1) THEN
12739                      XPSQTH      = AMCHK1/(XTVD(ITVAL)*ECM**2)
12740 **sr 8.4.98 (1/sqrt(x))
12741 C                    XPSQXX      = DT_SAMPEX(XPSQTH,XPSQ(J))
12742 C                    XPSQXX      = DT_SAMSQX(XPSQTH,XPSQ(J))
12743                      XPSQXX      = DT_SAMPLW(XPSQTH,XPSQ(J),PLW)
12744 **
12745                      XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX
12746                      XPSQ(J)     = XPSQXX
12747 *         chain mass below minimum - reset sea-q x-value and correct
12748 *                                    diquark-x of the same nucleon
12749                   ELSEIF (AMSVQ1.LT.AMCHK1) THEN
12750                      XPSQW       = AMCHK1/(XTVD(ITVAL)*ECM**2)
12751                      DXPSQ       = XPSQW-XPSQ(J)
12752                      IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12753                         XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12754                         XPSQ(J)     = XPSQW
12755                      ENDIF
12756                   ENDIF
12757 *       aq-q chain
12758 *         chain mass below minimum - reset sea-aq x-value and correct
12759 *                                    diquark-x of the same nucleon
12760                   IF (AMSVQ2.LT.AMCHK2) THEN
12761                      XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2)
12762                      DXPSQ = XPSQW-XPSAQ(J)
12763                      IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12764                         XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12765                         XPSAQ(J)    = XPSQW
12766                      ENDIF
12767                   ENDIF
12768 *>>>end of chain mass correction
12769
12770                   GOTO 260
12771                ENDIF
12772   250       CONTINUE
12773          ENDIF
12774   260    CONTINUE
12775   270 CONTINUE
12776
12777 * (6) get valence-sea chains
12778 *-----------------------------------------------------------------------
12779
12780       NVS = 0
12781       NVD = 0
12782       DO 300 I=1,NN
12783          IF (INTLO(I)) THEN
12784             IPVAL = ITOVP(INTER1(I))
12785             ITVAL = ITOVT(INTER2(I))
12786             DO 280 J=1,IXTS
12787                IF (ZUOVP(IPVAL).AND.ZUOST(J).AND.
12788      &                  (IFROST(J).EQ.INTER2(I))) THEN
12789                   ZUOST(J)     = .FALSE.
12790                   ZUOVP(IPVAL) = .FALSE.
12791                   INTLO(I)     = .FALSE.
12792                   IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
12793 *   sample sea-diquark pair
12794                      CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1)
12795                      IF (IREJ1.EQ.0) GOTO 290
12796                   ENDIF
12797                   NVS           = NVS + 1
12798                   ISKPCH(6,NVS) = 0
12799                   INTVS1(NVS)   = IPVAL
12800                   INTVS2(NVS)   = J
12801
12802 *>>>correct chain kinematics according to minimum chain masses
12803 *     the actual chain masses
12804                   AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2
12805                   AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2
12806 *     get lower mass cuts
12807                   IF (ITSQ(J).EQ.3) THEN
12808 *       q being s-quark
12809                      AMCHK1 = AMIS
12810                      AMCHK2 = AMAS
12811                   ELSE
12812 *       q being u/d-quark
12813                      AMCHK1 = AMIU
12814                      AMCHK2 = AMAU
12815                   ENDIF
12816 *       q-aq chain
12817 *         chain mass below minimum - reset sea-aq x-value and correct
12818 *                                    diquark-x of the same nucleon
12819                   IF (AMVSQ1.LT.AMCHK1) THEN
12820                      XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2)
12821                      DXTSQ = XTSQW-XTSAQ(J)
12822                      IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12823                         XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12824                         XTSAQ(J)    = XTSQW
12825                      ENDIF
12826                   ENDIF
12827 *       qq-q chain
12828 *         chain mass above minimum - resampling of sea-q x-value
12829                   IF (AMVSQ2.GT.AMCHK2) THEN
12830                      XTSQTH      = AMCHK2/(XPVD(IPVAL)*ECM**2)
12831 **sr 8.4.98 (1/sqrt(x))
12832 C                    XTSQXX      = DT_SAMPEX(XTSQTH,XTSQ(J))
12833 C                    XTSQXX      = DT_SAMSQX(XTSQTH,XTSQ(J))
12834                      XTSQXX      = DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
12835 **
12836                      XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX
12837                      XTSQ(J)     = XTSQXX
12838 *         chain mass below minimum - reset sea-q x-value and correct
12839 *                                    diquark-x of the same nucleon
12840                   ELSEIF (AMVSQ2.LT.AMCHK2) THEN
12841                      XTSQW       = AMCHK2/(XPVD(IPVAL)*ECM**2)
12842                      DXTSQ       = XTSQW-XTSQ(J)
12843                      IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12844                         XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12845                         XTSQ(J)     = XTSQW
12846                      ENDIF
12847                   ENDIF
12848 *>>>end of chain mass correction
12849
12850                   GOTO 290
12851                ENDIF
12852   280       CONTINUE
12853          ENDIF
12854   290    CONTINUE
12855   300 CONTINUE
12856
12857 * (7) get sea-sea chains
12858 *-----------------------------------------------------------------------
12859
12860       NSS = 0
12861       NDS = 0
12862       NSD = 0
12863       DO 420 I=1,NN
12864          IF (INTLO(I)) THEN
12865             IPVAL = ITOVP(INTER1(I))
12866             ITVAL = ITOVT(INTER2(I))
12867 *   loop over target partons not yet matched
12868             DO 400 J=1,IXTS
12869                IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN
12870 *   loop over projectile partons not yet matched
12871                   DO 390 JJ=1,IXPS
12872                      IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN
12873                         ZUOSP(JJ)     = .FALSE.
12874                         ZUOST(J)      = .FALSE.
12875                         INTLO(I)      = .FALSE.
12876                         NSS           = NSS+1
12877                         ISKPCH(1,NSS) = 0
12878                         INTSS1(NSS)   = JJ
12879                         INTSS2(NSS)   = J
12880
12881 *---->chain recombination option
12882                         VALFRA        = DBLE(NVV/(NVV+IXPS+IXTS))
12883                         IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA))
12884      &                                                             THEN
12885 *       sea-sea chains may recombine with valence-valence chains
12886 *       only if they have the same projectile or target nucleon
12887                            DO 4201 IVV=1,NVV
12888                               IF (ISKPCH(8,IVV).NE.99) THEN
12889                                  IXVPR = INTVV1(IVV)
12890                                  IXVTA = INTVV2(IVV)
12891                                  IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR.
12892      &                               (INTER2(I).EQ.IFROVT(IXVTA))) THEN
12893 *         recombination possible, drop old v-v and s-s chains
12894                                     ISKPCH(1,NSS) = 99
12895                                     ISKPCH(8,IVV) = 99
12896
12897 *         (a) assign new s-v chains
12898 *         ~~~~~~~~~~~~~~~~~~~~~~~~~
12899                                     IF (LSEADI.AND.
12900      &                                  (DT_RNDM(VALFRA).GT.FRCDIQ))
12901      &                                                             THEN
12902 *           sample sea-diquark pair
12903                                        CALL DT_SAMSDQ(ECM,IXVTA,JJ,2,
12904      &                                                      IREJ1)
12905                                        IF (IREJ1.EQ.0) GOTO 4202
12906                                     ENDIF
12907                                     NSV           = NSV+1
12908                                     ISKPCH(4,NSV) = 0
12909                                     INTSV1(NSV)   = JJ
12910                                     INTSV2(NSV)   = IXVTA
12911 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
12912 *           the actual chain masses
12913                                     AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA)
12914      &                                                     *ECM**2
12915                                     AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA)
12916      &                                                     *ECM**2
12917 *           get lower mass cuts
12918                                     IF (IPSQ(JJ).EQ.3) THEN
12919 *             q being s-quark
12920                                        AMCHK1 = AMAS
12921                                        AMCHK2 = AMIS
12922                                     ELSE
12923 *             q being u/d-quark
12924                                        AMCHK1 = AMAU
12925                                        AMCHK2 = AMIU
12926                                     ENDIF
12927 *           q-qq chain
12928 *             chain mass above minimum - resampling of sea-q x-value
12929                                     IF (AMSVQ1.GT.AMCHK1) THEN
12930                                        XPSQTH      =
12931      &                                    AMCHK1/(XTVD(IXVTA)*ECM**2)
12932 **sr 8.4.98 (1/sqrt(x))
12933                                        XPSQXX      =
12934      &                                    DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW)
12935 C    &                                    DT_SAMSQX(XPSQTH,XPSQ(JJ))
12936 C    &                                    DT_SAMPEX(XPSQTH,XPSQ(JJ))
12937 **
12938                                        XPVD(IPVAL) =
12939      &                                    XPVD(IPVAL)+XPSQ(JJ)-XPSQXX
12940                                        XPSQ(JJ)    = XPSQXX
12941 *             chain mass below minimum - reset sea-q x-value and correct
12942 *                                        diquark-x of the same nucleon
12943                                     ELSEIF (AMSVQ1.LT.AMCHK1) THEN
12944                                        XPSQW =
12945      &                                    AMCHK1/(XTVD(IXVTA)*ECM**2)
12946                                        DXPSQ = XPSQW-XPSQ(JJ)
12947                                        IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
12948      &                                                            THEN
12949                                           XPVD(IPVAL) =
12950      &                                       XPVD(IPVAL)-DXPSQ
12951                                           XPSQ(JJ)    = XPSQW
12952                                        ENDIF
12953                                     ENDIF
12954 *           aq-q chain
12955 *             chain mass below minimum - reset sea-aq x-value and correct
12956 *                                        diquark-x of the same nucleon
12957                                     IF (AMSVQ2.LT.AMCHK2) THEN
12958                                        XPSQW =
12959      &                                    AMCHK2/(XTVQ(IXVTA)*ECM**2)
12960                                        DXPSQ = XPSQW-XPSAQ(JJ)
12961                                        IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
12962      &                                                            THEN
12963                                           XPVD(IPVAL) =
12964      &                                       XPVD(IPVAL)-DXPSQ
12965                                           XPSAQ(JJ)   = XPSQW
12966                                        ENDIF
12967                                     ENDIF
12968 *>>>>>>>>>>>end of chain mass correction
12969  4202                               CONTINUE
12970
12971 *         (b) assign new v-s chains
12972 *         ~~~~~~~~~~~~~~~~~~~~~~~~~
12973                                     IF (LSEADI.AND.(
12974      &                                  DT_RNDM(AMSVQ2).GT.FRCDIQ))
12975      &                                                             THEN
12976 *           sample sea-diquark pair
12977                                        CALL DT_SAMSDQ(ECM,IXVPR,J,1,
12978      &                                                      IREJ1)
12979                                        IF (IREJ1.EQ.0) GOTO 4203
12980                                     ENDIF
12981                                     NVS           = NVS+1
12982                                     ISKPCH(6,NVS) = 0
12983                                     INTVS1(NVS)   = IXVPR
12984                                     INTVS2(NVS)   = J
12985 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
12986 *           the actual chain masses
12987                                     AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2
12988                                     AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2
12989 *           get lower mass cuts
12990                                     IF (ITSQ(J).EQ.3) THEN
12991 *             q being s-quark
12992                                        AMCHK1 = AMIS
12993                                        AMCHK2 = AMAS
12994                                     ELSE
12995 *             q being u/d-quark
12996                                        AMCHK1 = AMIU
12997                                        AMCHK2 = AMAU
12998                                     ENDIF
12999 *           q-aq chain
13000 *             chain mass below minimum - reset sea-aq x-value and correct
13001 *                                        diquark-x of the same nucleon
13002                                     IF (AMVSQ1.LT.AMCHK1) THEN
13003                                        XTSQW =
13004      &                                    AMCHK1/(XPVQ(IXVPR)*ECM**2)
13005                                        DXTSQ = XTSQW-XTSAQ(J)
13006                                        IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13007      &                                                            THEN
13008                                           XTVD(ITVAL) =
13009      &                                       XTVD(ITVAL)-DXTSQ
13010                                           XTSAQ(J)    = XTSQW
13011                                        ENDIF
13012                                     ENDIF
13013                                     IF (AMVSQ2.GT.AMCHK2) THEN
13014                                        XTSQTH      =
13015      &                                    AMCHK2/(XPVD(IXVPR)*ECM**2)
13016 **sr 8.4.98 (1/sqrt(x))
13017                                        XTSQXX      =
13018      &                                    DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13019 C    &                                    DT_SAMSQX(XTSQTH,XTSQ(J))
13020 C    &                                    DT_SAMPEX(XTSQTH,XTSQ(J))
13021 **
13022                                        XTVD(ITVAL) =
13023      &                                    XTVD(ITVAL)+XTSQ(J)-XTSQXX
13024                                        XTSQ(J)     = XTSQXX
13025                                     ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13026                                        XTSQW =
13027      &                                    AMCHK2/(XPVD(IXVPR)*ECM**2)
13028                                        DXTSQ = XTSQW-XTSQ(J)
13029                                        IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13030      &                                                            THEN
13031                                           XTVD(ITVAL) =
13032      &                                       XTVD(ITVAL)-DXTSQ
13033                                           XTSQ(J)     = XTSQW
13034                                        ENDIF
13035                                     ENDIF
13036 *>>>>>>>>>end of chain mass correction
13037  4203                               CONTINUE
13038 *       jump out of s-s chain loop
13039                                     GOTO 420
13040                                  ENDIF
13041                               ENDIF
13042  4201                      CONTINUE
13043                         ENDIF
13044 *---->end of chain recombination option
13045
13046 *     sample sea-diquark pair (projectile)
13047                         IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN
13048                            CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1)
13049                            IF (IREJ1.EQ.0) THEN
13050                               ISKPCH(1,NSS) = 99
13051                               GOTO 410
13052                            ENDIF
13053                         ENDIF
13054 *     sample sea-diquark pair (target)
13055                         IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13056                            CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1)
13057                            IF (IREJ1.EQ.0) THEN
13058                               ISKPCH(1,NSS) = 99
13059                               GOTO 410
13060                            ENDIF
13061                         ENDIF
13062 *>>>>>correct chain kinematics according to minimum chain masses
13063 *     the actual chain masses
13064                         SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2
13065                         SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2
13066 *     check for lower mass cuts
13067                         IF ((SSMA1Q.LT.SSMIMQ).OR.
13068      &                      (SSMA2Q.LT.SSMIMQ)) THEN
13069                            IPVAL = ITOVP(INTER1(I))
13070                            ITVAL = ITOVT(INTER2(I))
13071                            IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND.
13072      &                         (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN
13073 *       maximum allowed x values for sea quarks
13074                               XSPMAX = ONE-XPVQ(IPVAL)-XDTHR-
13075      &                                           1.2D0*XSSTHR
13076                               XSTMAX = ONE-XTVQ(ITVAL)-XDTHR-
13077      &                                           1.2D0*XSSTHR
13078 *       resampling of x values not possible - skip sea-sea chains
13079                               IF ((XSPMAX.LE.XSSTHR+0.05D0).OR.
13080      &                            (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380
13081 *       resampling of x for projectile sea quark pair
13082                               ICOUS = 0
13083   310                         CONTINUE
13084                               ICOUS = ICOUS+1
13085                               IF (XSSTHR.GT.0.05D0) THEN
13086                                  XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13087      &                                                         XSPMAX)
13088                                  XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13089      &                                                         XSPMAX)
13090                               ELSE
13091   320                            CONTINUE
13092                                  XPSQI = DT_DBETAR(XSEACU,UNOSEA)
13093                                  IF ((XPSQI.LT.XSSTHR).OR.
13094      &                               (XPSQI.GT.XSPMAX))  GOTO 320
13095   330                            CONTINUE
13096                                  XPSAQI = DT_DBETAR(XSEACU,UNOSEA)
13097                                  IF ((XPSAQI.LT.XSSTHR).OR.
13098      &                               (XPSAQI.GT.XSPMAX)) GOTO 330
13099                               ENDIF
13100 *       final test of remaining x for projectile diquark
13101                               XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI
13102      &                                            +XPSQ(JJ)+XPSAQ(JJ)
13103                               IF (XPVDCO.LE.XDTHR) THEN
13104 *!!!
13105 C                                IF (ICOUS.LT.5) GOTO 310
13106                                  IF (ICOUS.LT.0.5D0) GOTO 310
13107                                  GOTO 380
13108                               ENDIF
13109 *       resampling of x for target sea quark pair
13110                               ICOUS = 0
13111   350                         CONTINUE
13112                               ICOUS = ICOUS+1
13113                               IF (XSSTHR.GT.0.05D0) THEN
13114                                  XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13115      &                                                         XSTMAX)
13116                                  XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13117      &                                                         XSTMAX)
13118                               ELSE
13119   360                            CONTINUE
13120                                  XTSQI = DT_DBETAR(XSEACU,UNOSEA)
13121                                  IF ((XTSQI.LT.XSSTHR).OR.
13122      &                               (XTSQI.GT.XSTMAX))  GOTO 360
13123   370                            CONTINUE
13124                                  XTSAQI = DT_DBETAR(XSEACU,UNOSEA)
13125                                  IF ((XTSAQI.LT.XSSTHR).OR.
13126      &                               (XTSAQI.GT.XSTMAX)) GOTO 370
13127                               ENDIF
13128 *       final test of remaining x for target diquark
13129                               XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI
13130      &                                            +XTSQ(J)+XTSAQ(J)
13131                               IF (XTVDCO.LT.XDTHR) THEN
13132                                  IF (ICOUS.LT.5) GOTO 350
13133                                  GOTO 380
13134                               ENDIF
13135                               XPVD(IPVAL) = XPVDCO
13136                               XTVD(ITVAL) = XTVDCO
13137                               XPSQ(JJ)    = XPSQI
13138                               XPSAQ(JJ)   = XPSAQI
13139                               XTSQ(J)     = XTSQI
13140                               XTSAQ(J)    = XTSAQI
13141 *>>>>>end of chain mass correction
13142                               GOTO 410
13143                            ENDIF
13144 *     come here to discard s-s interaction
13145 *     resampling of x values not allowed or unsuccessful
13146   380                      CONTINUE
13147                            INTLO(I)  = .FALSE.
13148                            ZUOST(J)  = .TRUE.
13149                            ZUOSP(JJ) = .TRUE.
13150                            NSS       = NSS-1
13151                         ENDIF
13152 *   consider next s-s interaction
13153                         GOTO 410
13154                      ENDIF
13155   390             CONTINUE
13156                ENDIF
13157   400       CONTINUE
13158          ENDIF
13159   410    CONTINUE
13160   420 CONTINUE
13161
13162 * correct x-values of valence quarks for non-matching sea quarks
13163       DO 430 I=1,IXPS
13164          IF (ZUOSP(I)) THEN
13165             IPVAL       = ITOVP(IFROSP(I))
13166             XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I)
13167             XPSQ(I)     = ZERO
13168             XPSAQ(I)    = ZERO
13169             ZUOSP(I)    = .FALSE.
13170          ENDIF
13171   430 CONTINUE
13172       DO 440 I=1,IXTS
13173          IF (ZUOST(I)) THEN
13174             ITVAL       = ITOVT(IFROST(I))
13175             XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I)
13176             XTSQ(I)     = ZERO
13177             XTSAQ(I)    = ZERO
13178             ZUOST(I)    = .FALSE.
13179          ENDIF
13180   440 CONTINUE
13181       DO 450 I=1,IXPV
13182          IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13
13183   450 CONTINUE
13184       DO 460 I=1,IXTV
13185          IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14
13186   460 CONTINUE
13187
13188       RETURN
13189       END
13190
13191 *$ CREATE DT_SAMSDQ.FOR
13192 *COPY DT_SAMSDQ
13193 *
13194 *===samsdq=============================================================*
13195 *
13196       SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ)
13197
13198 ************************************************************************
13199 * SAMpling of Sea-DiQuarks                                             *
13200 *              ECM        cm-energy of the nucleon-nucleon system      *
13201 *              IDX1,2     indices of x-values of the participating     *
13202 *                         partons (IDX2 is always the sea-q-pair to be *
13203 *                         changed to sea-qq-pair)                      *
13204 *              MODE       = 1  valence-q - sea-diq                     *
13205 *                         = 2  sea-diq   - valence-q                   *
13206 *                         = 3  sea-q     - sea-diq                     *
13207 *                         = 4  sea-diq   - sea-q                       *
13208 * Based on DIQVS, DIQSV, DIQSSD, DIQDSS.                               *
13209 * This version dated 17.10.95 is written by S. Roesler                 *
13210 ************************************************************************
13211
13212       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13213       SAVE
13214
13215       PARAMETER (ZERO=0.0D0)
13216
13217 * threshold values for x-sampling (DTUNUC 1.x)
13218       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
13219      &                SSMIMQ,VVMTHR
13220 * various options for treatment of partons (DTUNUC 1.x)
13221 * (chain recombination, Cronin,..)
13222       LOGICAL LCO2CR,LINTPT
13223       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
13224      &                LCO2CR,LINTPT
13225       PARAMETER ( MAXNCL = 260,
13226      &            MAXVQU = MAXNCL,
13227      &            MAXSQU = 20*MAXVQU,
13228      &            MAXINT = MAXVQU+MAXSQU)
13229 * x-values of partons (DTUNUC 1.x)
13230       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
13231      &                XTVQ(MAXVQU),XTVD(MAXVQU),
13232      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
13233      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
13234 * flavors of partons (DTUNUC 1.x)
13235       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
13236      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
13237      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
13238      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
13239      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
13240      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
13241      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
13242 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13243       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
13244      &                IXPV,IXPS,IXTV,IXTS,
13245      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
13246      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
13247      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
13248      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
13249      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
13250      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
13251      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
13252      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
13253 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13254       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
13255      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
13256 * auxiliary common for chain system storage (DTUNUC 1.x)
13257       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
13258
13259       IREJ = 0
13260 *  threshold-x for valence diquarks
13261       XDTHR = CDQ/ECM
13262
13263       GOTO (1,2,3,4) MODE
13264
13265 *---------------------------------------------------------------------
13266 * proj. valence partons - targ. sea partons
13267 * get x-values and flavors for target sea-diquark pair
13268
13269     1 CONTINUE
13270       IDXVP = IDX1
13271       IDXST = IDX2
13272
13273 *  index of corr. val-diquark-x in target nucleon
13274       IDXVT = ITOVT(IFROST(IDXST))
13275 *  available x above diquark thresholds for valence- and sea-diquarks
13276       XXD   = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13277
13278       IF (XXD.GE.ZERO) THEN
13279 *  x-values for the three diquarks of the target nucleon
13280          RR1    = DT_RNDM(XXD)
13281          RR2    = DT_RNDM(RR1)
13282          RR3    = DT_RNDM(RR2)
13283          SR123  = RR1+RR2+RR3
13284          XXTV   = XDTHR+RR1*XXD/SR123
13285          XXTSQ  = XDTHR+RR2*XXD/SR123
13286          XXTSAQ = XDTHR+RR3*XXD/SR123
13287       ELSE
13288          XXTV   = XTVD(IDXVT)
13289          XXTSQ  = XTSQ(IDXST)
13290          XXTSAQ = XTSAQ(IDXST)
13291       ENDIF
13292 *  flavor of the second quarks in the sea-diquark pair
13293       ITSQ2(IDXST)  = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13294       ITSAQ2(IDXST) = -ITSQ2(IDXST)
13295 *  check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains
13296       AM1    = XXTSQ *XPVQ(IDXVP)*ECM**2
13297       AM2    = XXTSAQ*XPVD(IDXVP)*ECM**2
13298       IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13299 *    ss-asas pair
13300      &     ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0))            ) THEN
13301          IREJ = 1
13302          RETURN
13303       ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13304 *    at least one strange quark
13305      &         ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0))        ) THEN
13306          IREJ = 1
13307          RETURN
13308       ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13309          IREJ = 1
13310          RETURN
13311       ENDIF
13312 *  accept the new sea-diquark
13313       XTVD(IDXVT)   = XXTV
13314       XTSQ(IDXST)   = XXTSQ
13315       XTSAQ(IDXST)  = XXTSAQ
13316       NVD           = NVD+1
13317       INTVD1(NVD)   = IDXVP
13318       INTVD2(NVD)   = IDXST
13319       ISKPCH(7,NVD) = 0
13320       RETURN
13321
13322 *---------------------------------------------------------------------
13323 * proj. sea partons - targ. valence partons
13324 * get x-values and flavors for projectile sea-diquark pair
13325
13326     2 CONTINUE
13327       IDXSP = IDX2
13328       IDXVT = IDX1
13329
13330 *  index of corr. val-diquark-x in projectile nucleon
13331       IDXVP = ITOVP(IFROSP(IDXSP))
13332 *  available x above diquark thresholds for valence- and sea-diquarks
13333       XXD   = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13334
13335       IF (XXD.GE.ZERO) THEN
13336 *  x-values for the three diquarks of the projectile nucleon
13337          RR1    = DT_RNDM(XXD)
13338          RR2    = DT_RNDM(RR1)
13339          RR3    = DT_RNDM(RR2)
13340          SR123  = RR1+RR2+RR3
13341          XXPV   = XDTHR+RR1*XXD/SR123
13342          XXPSQ  = XDTHR+RR2*XXD/SR123
13343          XXPSAQ = XDTHR+RR3*XXD/SR123
13344       ELSE
13345          XXPV   = XPVD(IDXVP)
13346          XXPSQ  = XPSQ(IDXSP)
13347          XXPSAQ = XPSAQ(IDXSP)
13348       ENDIF
13349 *  flavor of the second quarks in the sea-diquark pair
13350       IPSQ2(IDXSP)  = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13351       IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13352 *  check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains
13353       AM1    = XXPSQ *XTVQ(IDXVT)*ECM**2
13354       AM2    = XXPSAQ*XTVD(IDXVT)*ECM**2
13355       IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13356 *    ss-asas pair
13357      &     ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0))            ) THEN
13358          IREJ = 1
13359          RETURN
13360       ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13361 *    at least one strange quark
13362      &         ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0))        ) THEN
13363          IREJ = 1
13364          RETURN
13365       ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13366          IREJ = 1
13367          RETURN
13368       ENDIF
13369 *  accept the new sea-diquark
13370       XPVD(IDXVP)   = XXPV
13371       XPSQ(IDXSP)   = XXPSQ
13372       XPSAQ(IDXSP)  = XXPSAQ
13373       NDV           = NDV+1
13374       INTDV1(NDV)   = IDXSP
13375       INTDV2(NDV)   = IDXVT
13376       ISKPCH(5,NDV) = 0
13377       RETURN
13378
13379 *---------------------------------------------------------------------
13380 * proj. sea partons - targ. sea partons
13381 * get x-values and flavors for target sea-diquark pair
13382
13383     3 CONTINUE
13384       IDXSP = IDX1
13385       IDXST = IDX2
13386
13387 *  index of corr. val-diquark-x in target nucleon
13388       IDXVT = ITOVT(IFROST(IDXST))
13389 *  available x above diquark thresholds for valence- and sea-diquarks
13390       XXD   = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13391
13392       IF (XXD.GE.ZERO) THEN
13393 *  x-values for the three diquarks of the target nucleon
13394          RR1    = DT_RNDM(XXD)
13395          RR2    = DT_RNDM(RR1)
13396          RR3    = DT_RNDM(RR2)
13397          SR123  = RR1+RR2+RR3
13398          XXTV   = XDTHR+RR1*XXD/SR123
13399          XXTSQ  = XDTHR+RR2*XXD/SR123
13400          XXTSAQ = XDTHR+RR3*XXD/SR123
13401       ELSE
13402          XXTV   = XTVD(IDXVT)
13403          XXTSQ  = XTSQ(IDXST)
13404          XXTSAQ = XTSAQ(IDXST)
13405       ENDIF
13406 *  flavor of the second quarks in the sea-diquark pair
13407       ITSQ2(IDXST)  = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13408       ITSAQ2(IDXST) = -ITSQ2(IDXST)
13409 *  check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains
13410       AM1    = XXTSQ *XPSQ(IDXSP)*ECM**2
13411       AM2    = XXTSAQ*XPSAQ(IDXSP)*ECM**2
13412       IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13413 *    ss-asas pair
13414      &     ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0))            ) THEN
13415          IREJ = 1
13416          RETURN
13417       ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13418 *    at least one strange quark
13419      &         ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0))        ) THEN
13420          IREJ = 1
13421          RETURN
13422       ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13423          IREJ = 1
13424          RETURN
13425       ENDIF
13426 *  accept the new sea-diquark
13427       XTVD(IDXVT)   = XXTV
13428       XTSQ(IDXST)   = XXTSQ
13429       XTSAQ(IDXST)  = XXTSAQ
13430       NSD           = NSD+1
13431       INTSD1(NSD)   = IDXSP
13432       INTSD2(NSD)   = IDXST
13433       ISKPCH(3,NSD) = 0
13434       RETURN
13435
13436 *---------------------------------------------------------------------
13437 * proj. sea partons - targ. sea partons
13438 * get x-values and flavors for projectile sea-diquark pair
13439
13440     4 CONTINUE
13441       IDXSP = IDX2
13442       IDXST = IDX1
13443
13444 *  index of corr. val-diquark-x in projectile nucleon
13445       IDXVP = ITOVP(IFROSP(IDXSP))
13446 *  available x above diquark thresholds for valence- and sea-diquarks
13447       XXD   = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13448
13449       IF (XXD.GE.ZERO) THEN
13450 *  x-values for the three diquarks of the projectile nucleon
13451          RR1    = DT_RNDM(XXD)
13452          RR2    = DT_RNDM(RR1)
13453          RR3    = DT_RNDM(RR2)
13454          SR123  = RR1+RR2+RR3
13455          XXPV   = XDTHR+RR1*XXD/SR123
13456          XXPSQ  = XDTHR+RR2*XXD/SR123
13457          XXPSAQ = XDTHR+RR3*XXD/SR123
13458       ELSE
13459          XXPV   = XPVD(IDXVP)
13460          XXPSQ  = XPSQ(IDXSP)
13461          XXPSAQ = XPSAQ(IDXSP)
13462       ENDIF
13463 *  flavor of the second quarks in the sea-diquark pair
13464       IPSQ2(IDXSP)  = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13465       IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13466 *  check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains
13467       AM1    = XXPSQ *XTSQ(IDXST)*ECM**2
13468       AM2    = XXPSAQ*XTSAQ(IDXST)*ECM**2
13469       IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13470 *    ss-asas pair
13471      &     ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0))            ) THEN
13472          IREJ = 1
13473          RETURN
13474       ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13475 *    at least one strange quark
13476      &         ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0))        ) THEN
13477          IREJ = 1
13478          RETURN
13479       ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13480          IREJ = 1
13481          RETURN
13482       ENDIF
13483 *  accept the new sea-diquark
13484       XPVD(IDXVP)   = XXPV
13485       XPSQ(IDXSP)   = XXPSQ
13486       XPSAQ(IDXSP)  = XXPSAQ
13487       NDS           = NDS+1
13488       INTDS1(NDS)   = IDXSP
13489       INTDS2(NDS)   = IDXST
13490       ISKPCH(2,NDS) = 0
13491       RETURN
13492       END
13493
13494 *$ CREATE DT_DIFEVT.FOR
13495 *COPY DT_DIFEVT
13496 *
13497 *===difevt=============================================================*
13498 *
13499       SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP,
13500      &                  IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ)
13501
13502 ************************************************************************
13503 * Interface to treatment of diffractive interactions.                  *
13504 *  (input)          IFP1/2        PDG-indizes of projectile partons    *
13505 *                                 (baryon: IFP2 - adiquark)            *
13506 *                   PP(4)         projectile 4-momentum                *
13507 *                   IFT1/2        PDG-indizes of target partons        *
13508 *                                 (baryon: IFT1 - adiquark)            *
13509 *                   PT(4)         target 4-momentum                    *
13510 *  (output)         JDIFF = 0     no diffraction                       *
13511 *                         = 1/-1  LMSD/LMDD                            *
13512 *                         = 2/-2  HMSD/HMDD                            *
13513 *                   NCSY          counter for two-chain systems        *
13514 *                                 dumped to DTEVT1                     *
13515 * This version dated 14.02.95 is written by S. Roesler                 *
13516 ************************************************************************
13517
13518       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13519       SAVE
13520       PARAMETER ( LINP = 10 ,
13521      &            LOUT = 6 ,
13522      &            LDAT = 9 )
13523       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5,
13524      &           OHALF=0.5D0)
13525
13526 * event history
13527       PARAMETER (NMXHKK=200000)
13528       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
13529      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
13530      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
13531 * extended event history
13532       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
13533      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
13534      &                IHIST(2,NMXHKK)
13535 * flags for diffractive interactions (DTUNUC 1.x)
13536       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
13537
13538       DIMENSION PP(4),PT(4)
13539
13540       LOGICAL LFIRST
13541       DATA LFIRST /.TRUE./
13542
13543       IREJ   = 0
13544       JDIFF  = 0
13545       IFLAGD = JDIFF
13546
13547 * cm. energy
13548       XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
13549      &          (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
13550 * identities of projectile hadron / target nucleon
13551       KPROJ = IDT_ICIHAD(IDHKK(MOP))
13552       KTARG = IDT_ICIHAD(IDHKK(MOT))
13553
13554 * single diffractive xsections
13555       CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM)
13556 * double diffractive xsections
13557 **!! no double diff yet
13558 C     CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM)
13559       DDTOT = 0.0D0
13560       DDHM  = 0.0D0
13561 **!!
13562 * total inelastic xsection
13563 C     SIGIN  = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM)
13564       DUMZER = ZERO
13565       CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL)
13566       SIGIN  = MAX(SIGTO-SIGEL,ZERO)
13567
13568 * fraction of diffractive processes
13569       FRADIF = (SDTOT+DDTOT)/SIGIN
13570
13571       IF (LFIRST) THEN
13572          WRITE(LOUT,1000) XM,SDTOT,SIGIN
13573  1000    FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ',
13574      &          F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ',
13575      &          F5.1,' mb',/)
13576          LFIRST = .FALSE.
13577       ENDIF
13578
13579       IF ((DT_RNDM(DDHM).LE.FRADIF).OR.
13580      &    (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN
13581 * diffractive interaction requested by x-section or by user
13582          FRASD  = SDTOT/(SDTOT+DDTOT)
13583          FRASDH = SDHM/SDTOT
13584 **sr needs to be specified!!
13585 C        FRADDH = DDHM/DDTOT
13586          FRADDH = 1.0D0
13587 **
13588          IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN
13589 *   single diffraction
13590             KDIFF = 1
13591             IF (DT_RNDM(DDTOT).LE.FRASDH) THEN
13592                KP = 2
13593                KT = 0
13594                IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND.
13595      &               ISINGD.NE.3) THEN
13596                   KP = 0
13597                   KT = 2
13598                ENDIF
13599             ELSE
13600                KP = 1
13601                KT = 0
13602                IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND.
13603      &               ISINGD.NE.3) THEN
13604                   KP = 0
13605                   KT = 1
13606                ENDIF
13607             ENDIF
13608          ELSE
13609 *   double diffraction
13610             KDIFF = -1
13611             IF (DT_RNDM(FRADDH).LE.FRADDH) THEN
13612                KP = 2
13613                KT = 2
13614             ELSE
13615                KP = 1
13616                KT = 1
13617             ENDIF
13618          ENDIF
13619          CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13620      &               IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13621          IF (IREJ1.EQ.0) THEN
13622             IFLAGD = 2*KDIFF
13623             IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF
13624          ELSE
13625             GOTO 9999
13626          ENDIF
13627       ENDIF
13628       JDIFF = IFLAGD
13629
13630       RETURN
13631
13632  9999 CONTINUE
13633       IREJ  = 1
13634       RETURN
13635       END
13636
13637 *$ CREATE DT_DIFFKI.FOR
13638 *COPY DT_DIFFKI
13639 *
13640 *===difkin=============================================================*
13641 *
13642       SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13643      &                  IFT1,IFT2,PT,MOT,KT,NCSY,IREJ)
13644
13645 ************************************************************************
13646 * Kinematics of diffractive nucleon-nucleon interaction.               *
13647 *          IFP1/2   PDG-indizes of projectile partons                  *
13648 *                   (baryon: IFP2 - adiquark)                          *
13649 *          PP(4)    projectile 4-momentum                              *
13650 *          IFT1/2   PDG-indizes of target partons                      *
13651 *                   (baryon: IFT1 - adiquark)                          *
13652 *          PT(4)    target 4-momentum                                  *
13653 *          KP   = 0 projectile quasi-elastically scattered             *
13654 *               = 1            excited to low-mass diff. state         *
13655 *               = 2            excited to high-mass diff. state        *
13656 *          KT   = 0 target     quasi-elastically scattered             *
13657 *               = 1            excited to low-mass diff. state         *
13658 *               = 2            excited to high-mass diff. state        *
13659 * This version dated 12.02.95 is written by S. Roesler                 *
13660 ************************************************************************
13661
13662       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13663       SAVE
13664       PARAMETER ( LINP = 10 ,
13665      &            LOUT = 6 ,
13666      &            LDAT = 9 )
13667       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5)
13668
13669       LOGICAL LSTART
13670
13671 * particle properties (BAMJET index convention)
13672       CHARACTER*8  ANAME
13673       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
13674      &                IICH(210),IIBAR(210),K1(210),K2(210)
13675 * flags for input different options
13676       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
13677       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
13678      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
13679 * rejection counter
13680       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
13681      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
13682      &                IREXCI(3),IRDIFF(2),IRINC
13683 * kinematics of diffractive interactions (DTUNUC 1.x)
13684       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13685      &                PPF(4),PTF(4),
13686      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13687      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13688
13689       DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4),
13690      &          PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4)
13691
13692       DATA LSTART /.TRUE./
13693
13694       IF (LSTART) THEN
13695          WRITE(LOUT,2000)
13696  2000    FORMAT(/,1X,'DIFEVT:  diffractive interactions treated ')
13697          LSTART = .FALSE.
13698       ENDIF
13699
13700       IREJ = 0
13701
13702 * initialize common /DTDIKI/
13703       CALL DT_DIFINI
13704 * store momenta of initial incoming particles for emc-check
13705       IF (LEMCCK) THEN
13706          CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM)
13707          CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM)
13708       ENDIF
13709
13710 * masses of initial particles
13711       XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2
13712       XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2
13713       IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999
13714       XMP  = SQRT(XMP2)
13715       XMT  = SQRT(XMT2)
13716 * check quark-input (used to adjust coherence cond. for M-selection)
13717       IBP  = 0
13718       IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1
13719       IBT  = 0
13720       IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1
13721
13722 * parameter for Lorentz-transformation into nucleon-nucleon cms
13723       DO 3 K=1,4
13724          PITOT(K) = PP(K)+PT(K)
13725     3 CONTINUE
13726       XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2
13727       IF (XMTOT2.LE.ZERO) THEN
13728          WRITE(LOUT,1000) XMTOT2
13729  1000    FORMAT(1X,'DIFEVT:   negative cm. energy!  ',
13730      &          'XMTOT2 = ',E12.3)
13731          GOTO 9999
13732       ENDIF
13733       XMTOT = SQRT(XMTOT2)
13734       DO 4 K=1,4
13735          BGTOT(K) = PITOT(K)/XMTOT
13736     4 CONTINUE
13737 * transformation of nucleons into cms
13738       CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2),
13739      &            PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4))
13740       CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2),
13741      &            PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4))
13742 * rotation angles
13743       COD = PP1(3)/PPTOT
13744 C     SID = SQRT((ONE-COD)*(ONE+COD))
13745       PPT = SQRT(PP1(1)**2+PP1(2)**2)
13746       SID = PPT/PPTOT
13747       COF = ONE
13748       SIF = ZERO
13749       IF(PPTOT*SID.GT.TINY10) THEN
13750          COF   = PP1(1)/(SID*PPTOT)
13751          SIF   = PP1(2)/(SID*PPTOT)
13752          ANORF = SQRT(COF*COF+SIF*SIF)
13753          COF   = COF/ANORF
13754          SIF   = SIF/ANORF
13755       ENDIF
13756 * check consistency
13757       DO 5 K=1,4
13758          DEV1(K) = ABS(PP1(K)+PT1(K))
13759     5 CONTINUE
13760       DEV1(4) = ABS(DEV1(4)-XMTOT)
13761       IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR.
13762      &    (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10))     THEN
13763          WRITE(LOUT,1001) DEV1
13764  1001    FORMAT(1X,'DIFEVT:   inconsitent Lorentz-transformation! ',
13765      &          /,8X,4E12.3)
13766          GOTO 9999
13767       ENDIF
13768
13769 * select x-fractions in high-mass diff. interactions
13770       IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT)
13771
13772 * select diffractive masses
13773 * - projectile
13774       IF (KP.EQ.1) THEN
13775          XMPF = DT_XMLMD(XMTOT)
13776          CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1)
13777          IF (IREJ1.GT.0) GOTO 9999
13778       ELSEIF (KP.EQ.2) THEN
13779          XMPF = DT_XMHMD(XMTOT,IBP,1)
13780       ELSE
13781          XMPF = XMP
13782       ENDIF
13783 * - target
13784       IF (KT.EQ.1) THEN
13785          XMTF = DT_XMLMD(XMTOT)
13786          CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1)
13787          IF (IREJ1.GT.0) GOTO 9999
13788       ELSEIF (KT.EQ.2) THEN
13789          XMTF = DT_XMHMD(XMTOT,IBT,2)
13790       ELSE
13791          XMTF = XMT
13792       ENDIF
13793
13794 * kinematical treatment of "two-particle" system (masses - XMPF,XMTF)
13795       XMPF2 = XMPF**2
13796       XMTF2 = XMTF**2
13797       PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT)
13798       PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2)
13799
13800 * select momentum transfer (all t-values used here are <0)
13801 *   minimum absolute value to produce diffractive masses
13802       TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3))
13803       TT   = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1)
13804       IF (IREJ1.GT.0) GOTO 9999
13805
13806 * longitudinal momentum of excited/elastically scattered projectile
13807       PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT)
13808 * total transverse momentum due to t-selection
13809       PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2
13810       IF (PPBLT2.LT.ZERO) THEN
13811          WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT
13812  1002    FORMAT(1X,'DIFEVT:   inconsistent transverse momentum! ',
13813      &          E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3)
13814          GOTO 9999
13815       ENDIF
13816       CALL DT_DSFECF(SINPHI,COSPHI)
13817       PPBLT     = SQRT(PPBLT2)
13818       PPBLOB(1) = COSPHI*PPBLT
13819       PPBLOB(2) = SINPHI*PPBLT
13820
13821 * rotate excited/elastically scattered projectile into n-n cms.
13822       CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF,
13823      &                                                    XX,YY,ZZ)
13824       PPBLOB(1) = XX
13825       PPBLOB(2) = YY
13826       PPBLOB(3) = ZZ
13827
13828 * 4-momentum of excited/elastically scattered target and of exchanged
13829 * Pomeron
13830       DO 6 K=1,4
13831          IF (K.LT.4) PTBLOB(K) = -PPBLOB(K)
13832          PPOM1(K) = PP1(K)-PPBLOB(K)
13833     6 CONTINUE
13834       PTBLOB(4) = XMTOT-PPBLOB(4)
13835
13836 * Lorentz-transformation back into system of initial diff. collision
13837       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13838      &            PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4),
13839      &            PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4))
13840       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13841      &            PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4),
13842      &            PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4))
13843       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13844      &            PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4),
13845      &            PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4))
13846
13847 * store 4-momentum of elastically scattered particle (in single diff.
13848 * events)
13849       IF (KP.EQ.0) THEN
13850          DO 7 K=1,4
13851             PSC(K) = PPF(K)
13852     7    CONTINUE
13853       ELSEIF (KT.EQ.0) THEN
13854          DO 8 K=1,4
13855             PSC(K) = PTF(K)
13856     8    CONTINUE
13857       ENDIF
13858
13859 * check consistency of kinematical treatment so far
13860       IF (LEMCCK) THEN
13861          CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM)
13862          CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM)
13863          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1)
13864          IF (IREJ1.NE.0) GOTO 9999
13865       ENDIF
13866       DO 9 K=1,4
13867          DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K))
13868          DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K))
13869     9 CONTINUE
13870       IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR.
13871      &    (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR.
13872      &    (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR.
13873      &    (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5))     THEN
13874          WRITE(LOUT,1003) DEV1,DEV2
13875  1003    FORMAT(1X,'DIFEVT:   inconsitent kinematical treatment!  ',
13876      &          2(/,8X,4E12.3))
13877          GOTO 9999
13878       ENDIF
13879
13880 * kinematical treatment for low-mass diffraction
13881       CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1)
13882       IF (IREJ1.NE.0) GOTO 9999
13883
13884 * dump diffractive chains into DTEVT1
13885       CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13886       IF (IREJ1.NE.0) GOTO 9999
13887
13888       RETURN
13889
13890  9999 CONTINUE
13891       IRDIFF(1) = IRDIFF(1)+1
13892       IREJ      = 1
13893       RETURN
13894       END
13895
13896 *$ CREATE DT_XMHMD.FOR
13897 *COPY DT_XMHMD
13898 *
13899 *===xmhmd==============================================================*
13900 *
13901       DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE)
13902
13903 ************************************************************************
13904 * Diffractive mass in high mass single/double diffractive events.      *
13905 * This version dated 11.02.95 is written by S. Roesler                 *
13906 ************************************************************************
13907
13908       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13909       SAVE
13910       PARAMETER ( LINP = 10 ,
13911      &            LOUT = 6 ,
13912      &            LDAT = 9 )
13913       PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)
13914
13915 * kinematics of diffractive interactions (DTUNUC 1.x)
13916       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13917      &                PPF(4),PTF(4),
13918      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13919      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13920
13921 C     DATA XCOLOW /0.05D0/
13922       DATA XCOLOW /0.15D0/
13923
13924       DT_XMHMD = ZERO
13925       XH = XPH(2)
13926       IF (MODE.EQ.2) XH = XTH(2)
13927
13928 * minimum Pomeron-x for high-mass diffraction
13929 * (adjusted to get a smooth transition between HM and LM component)
13930       R = DT_RNDM(XH)
13931       XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2)
13932       IF (ECM.LE.300.0D0) THEN
13933          RR     = (1.0D0-EXP(-((ECM/140.0D0)**4)))
13934          XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2)
13935       ENDIF
13936 * maximum Pomeron-x for high-mass diffraction
13937 * (coherence condition, adjusted to fit to experimental data)
13938       IF (IB.NE.0) THEN
13939 *   baryon-diffraction
13940          XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2)))
13941       ELSE
13942 *   meson-diffraction
13943          XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2)))
13944       ENDIF
13945 * check boundaries
13946       IF (XDIMIN.GE.XDIMAX) THEN
13947          XDIMIN = OHALF*XDIMAX
13948       ENDIF
13949
13950       KLOOP = 0
13951     1 CONTINUE
13952       KLOOP = KLOOP+1
13953       IF (KLOOP.GT.20) RETURN
13954 * sample Pomeron-x from 1/x-distribution (critical Pomeron)
13955       XDIFF = DT_SAMPEX(XDIMIN,XDIMAX)
13956 * corr. diffr. mass
13957       DT_XMHMD = ECM*SQRT(XDIFF)
13958       IF (DT_XMHMD.LT.2.5D0) GOTO 1
13959
13960       RETURN
13961       END
13962
13963 *$ CREATE DT_XMLMD.FOR
13964 *COPY DT_XMLMD
13965 *
13966 *===xmlmd==============================================================*
13967 *
13968       DOUBLE PRECISION FUNCTION DT_XMLMD(ECM)
13969
13970 ************************************************************************
13971 * Diffractive mass in high mass single/double diffractive events.      *
13972 * This version dated 11.02.95 is written by S. Roesler                 *
13973 ************************************************************************
13974
13975       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13976       SAVE
13977       PARAMETER ( LINP = 10 ,
13978      &            LOUT = 6 ,
13979      &            LDAT = 9 )
13980
13981 * minimum Pomeron-x for low-mass diffraction
13982 C     AMO = 1.5D0
13983       AMO = 2.0D0
13984 * maximum Pomeron-x for low-mass diffraction
13985 * (adjusted to get a smooth transition between HM and LM component)
13986       R   = DT_RNDM(AMO)
13987       SAM = 1.0D0
13988       IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4))
13989       R   = DT_RNDM(AMO)*SAM
13990       AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0)
13991       AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX
13992
13993 * selection of diffractive mass
13994 * (adjusted to get a smooth transition between HM and LM component)
13995       R   = DT_RNDM(AMU)
13996       IF (ECM.LE.50.0D0) THEN
13997          DT_XMLMD = AMO*(AMU/AMO)**R
13998       ELSE
13999          A = 0.7D0
14000          IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2)))
14001          DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A))
14002       ENDIF
14003
14004       RETURN
14005       END
14006
14007 *$ CREATE DT_TDIFF.FOR
14008 *COPY DT_TDIFF
14009 *
14010 *===tdiff==============================================================*
14011 *
14012       DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ)
14013
14014 ************************************************************************
14015 * t-selection for single/double diffractive interactions.              *
14016 *          ECM      cm. energy                                         *
14017 *          TMIN     minimum momentum transfer to produce diff. masses  *
14018 *          XM1/XM2  diffractively produced masses                      *
14019 *                   (for single diffraction XM2 is obsolete)           *
14020 *          K1/K2= 0 not excited                                        *
14021 *               = 1 low-mass excitation                                *
14022 *               = 2 high-mass excitation                               *
14023 * This version dated 11.02.95 is written by S. Roesler                 *
14024 ************************************************************************
14025
14026       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14027       SAVE
14028       PARAMETER ( LINP = 10 ,
14029      &            LOUT = 6 ,
14030      &            LDAT = 9 )
14031       PARAMETER (ZERO=0.0D0)
14032
14033       PARAMETER ( BTP0   = 3.7D0,
14034      &            ALPHAP = 0.24D0 )
14035
14036       IREJ   = 0
14037       NCLOOP = 0
14038       DT_TDIFF  = ZERO
14039
14040       IF (K1.GT.0) THEN
14041          XM1 = XM1I
14042          XM2 = XM2I
14043       ELSE
14044          XM1 = XM2I
14045       ENDIF
14046       XDI = (XM1/ECM)**2
14047       IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN
14048 * slope for single diffraction
14049          SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI)
14050       ELSE
14051 * slope for double diffraction
14052          SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2)
14053       ENDIF
14054
14055     1 CONTINUE
14056       NCLOOP = NCLOOP+1
14057       IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999
14058       Y = DT_RNDM(XDI)
14059       T = -LOG(1.0D0-Y)/SLOPE
14060       IF (ABS(T).LE.ABS(TMIN)) GOTO 1
14061       DT_TDIFF = -ABS(T)
14062
14063       RETURN
14064
14065  9999 CONTINUE
14066       WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2
14067  1000 FORMAT(1X,'DT_TDIFF:   t-selection rejected!',/,
14068      &       1X,'ECM  = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ',
14069      &       E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2)
14070       IREJ = 1
14071       RETURN
14072       END
14073
14074 *$ CREATE DT_XVALHM.FOR
14075 *COPY DT_XVALHM
14076 *
14077 *===xvalhm=============================================================*
14078 *
14079       SUBROUTINE DT_XVALHM(KP,KT)
14080
14081 ************************************************************************
14082 * Sampling of parton x-values in high-mass diffractive interactions.   *
14083 * This version dated 12.02.95 is written by S. Roesler                 *
14084 ************************************************************************
14085
14086       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14087       SAVE
14088       PARAMETER ( LINP = 10 ,
14089      &            LOUT = 6 ,
14090      &            LDAT = 9 )
14091       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2)
14092
14093 * kinematics of diffractive interactions (DTUNUC 1.x)
14094       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14095      &                PPF(4),PTF(4),
14096      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14097      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14098 * various options for treatment of partons (DTUNUC 1.x)
14099 * (chain recombination, Cronin,..)
14100       LOGICAL LCO2CR,LINTPT
14101       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
14102      &                LCO2CR,LINTPT
14103
14104       DATA UNON,XVQTHR /2.0D0,0.8D0/
14105
14106       IF (KP.EQ.2) THEN
14107 * x-fractions of projectile valence partons
14108     1    CONTINUE
14109          XPH(1) = DT_DBETAR(OHALF,UNON)
14110          IF (XPH(1).GE.XVQTHR) GOTO 1
14111          XPH(2) = ONE-XPH(1)
14112 * x-fractions of Pomeron q-aq-pair
14113          XPOLO = TINY2
14114          XPOHI = ONE-TINY2
14115          XPPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14116          XPPO(2) = ONE-XPPO(1)
14117 * flavors of Pomeron q-aq-pair
14118          IFLAV    = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ))
14119          IFPPO(1) = IFLAV
14120          IFPPO(2) = -IFLAV
14121          IF (DT_RNDM(UNON).GT.OHALF) THEN
14122             IFPPO(1) = -IFLAV
14123             IFPPO(2) = IFLAV
14124          ENDIF
14125       ENDIF
14126
14127       IF (KT.EQ.2) THEN
14128 * x-fractions of projectile target partons
14129     2    CONTINUE
14130          XTH(1) = DT_DBETAR(OHALF,UNON)
14131          IF (XTH(1).GE.XVQTHR) GOTO 2
14132          XTH(2) = ONE-XTH(1)
14133 * x-fractions of Pomeron q-aq-pair
14134          XPOLO = TINY2
14135          XPOHI = ONE-TINY2
14136          XTPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14137          XTPO(2) = ONE-XTPO(1)
14138 * flavors of Pomeron q-aq-pair
14139          IFLAV    = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ))
14140          IFTPO(1) = IFLAV
14141          IFTPO(2) = -IFLAV
14142          IF (DT_RNDM(XPOLO).GT.OHALF) THEN
14143             IFTPO(1) = -IFLAV
14144             IFTPO(2) = IFLAV
14145          ENDIF
14146       ENDIF
14147
14148       RETURN
14149       END
14150
14151 *$ CREATE DT_LM2RES.FOR
14152 *COPY DT_LM2RES
14153 *
14154 *===lm2res=============================================================*
14155 *
14156       SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ)
14157
14158 ************************************************************************
14159 * Check low-mass diffractive excitation for resonance mass.            *
14160 *   (input)   IF1/2    PDG-indizes of valence partons                  *
14161 *   (in/out)  XM       diffractive mass requested/corrected            *
14162 *   (output)  IDR/IDXR id./BAMJET-index of resonance                   *
14163 * This version dated 12.02.95 is written by S. Roesler                 *
14164 ************************************************************************
14165
14166       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14167       SAVE
14168       PARAMETER ( LINP = 10 ,
14169      &            LOUT = 6 ,
14170      &            LDAT = 9 )
14171       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14172
14173 * kinematics of diffractive interactions (DTUNUC 1.x)
14174       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14175      &                PPF(4),PTF(4),
14176      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14177      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14178
14179       IREJ = 0
14180       IF1B = 0
14181       IF2B = 0
14182       XMI  = XM
14183
14184 * BAMJET indices of partons
14185       IF1A = IDT_IPDG2B(IF1,1,2)
14186       IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2)
14187       IF2A = IDT_IPDG2B(IF2,1,2)
14188       IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2)
14189
14190 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq)
14191       IDCH = 2
14192       IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1
14193
14194 * check for resonance mass
14195       CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1)
14196       IF (IREJ1.NE.0) GOTO 9999
14197
14198       XM = XMN
14199       RETURN
14200
14201  9999 CONTINUE
14202       IREJ = 1
14203       RETURN
14204       END
14205
14206 *$ CREATE DT_LMKINE.FOR
14207 *COPY DT_LMKINE
14208 *
14209 *===lmkine=============================================================*
14210 *
14211       SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ)
14212
14213 ************************************************************************
14214 * Kinematical treatment of low-mass excitations.                       *
14215 * This version dated 12.02.95 is written by S. Roesler                 *
14216 ************************************************************************
14217
14218       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14219       SAVE
14220       PARAMETER ( LINP = 10 ,
14221      &            LOUT = 6 ,
14222      &            LDAT = 9 )
14223       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14224
14225 * flags for input different options
14226       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14227       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14228      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14229 * kinematics of diffractive interactions (DTUNUC 1.x)
14230       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14231      &                PPF(4),PTF(4),
14232      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14233      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14234
14235       DIMENSION P1(4),P2(4)
14236
14237       IREJ = 0
14238
14239       IF (KP.EQ.1) THEN
14240          PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2)
14241          POE  = PPF(4)/PABS
14242          FAC1 = OHALF*(POE+ONE)
14243          FAC2 = -OHALF*(POE-ONE)
14244          DO 1 K=1,3
14245             PPLM1(K) = FAC1*PPF(K)
14246             PPLM2(K) = FAC2*PPF(K)
14247     1    CONTINUE
14248          PPLM1(4) = FAC1*PABS
14249          PPLM2(4) = -FAC2*PABS
14250          IF (IMSHL.EQ.1) THEN
14251             XM1 = PYMASS(IFP1)
14252             XM2 = PYMASS(IFP2)
14253             CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1)
14254             IF (IREJ1.NE.0) GOTO 9999
14255             DO 2 K=1,4
14256                PPLM1(K) = P1(K)
14257                PPLM2(K) = P2(K)
14258     2       CONTINUE
14259          ENDIF
14260       ENDIF
14261
14262       IF (KT.EQ.1) THEN
14263          PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2)
14264          POE  = PTF(4)/PABS
14265          FAC1 = OHALF*(POE+ONE)
14266          FAC2 = -OHALF*(POE-ONE)
14267          DO 3 K=1,3
14268             PTLM2(K) = FAC1*PTF(K)
14269             PTLM1(K) = FAC2*PTF(K)
14270     3    CONTINUE
14271          PTLM2(4) = FAC1*PABS
14272          PTLM1(4) = -FAC2*PABS
14273          IF (IMSHL.EQ.1) THEN
14274             XM1 = PYMASS(IFT1)
14275             XM2 = PYMASS(IFT2)
14276             CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1)
14277             IF (IREJ1.NE.0) GOTO 9999
14278             DO 4 K=1,4
14279                PTLM1(K) = P1(K)
14280                PTLM2(K) = P2(K)
14281     4       CONTINUE
14282          ENDIF
14283       ENDIF
14284
14285       RETURN
14286
14287  9999 CONTINUE
14288       WRITE(LOUT,'(A)') 'LMKINE:   kinematical treatment rejected'
14289       IREJ = 1
14290       RETURN
14291       END
14292
14293 *$ CREATE DT_DIFINI.FOR
14294 *COPY DT_DIFINI
14295 *
14296 *===difini=============================================================*
14297 *
14298       SUBROUTINE DT_DIFINI
14299
14300 ************************************************************************
14301 * Initialization of common /DTDIKI/                                    *
14302 * This version dated 12.02.95 is written by S. Roesler                 *
14303 ************************************************************************
14304
14305       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14306       SAVE
14307       PARAMETER ( LINP = 10 ,
14308      &            LOUT = 6 ,
14309      &            LDAT = 9 )
14310       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14311
14312 * kinematics of diffractive interactions (DTUNUC 1.x)
14313       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14314      &                PPF(4),PTF(4),
14315      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14316      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14317
14318       DO 1 K=1,4
14319          PPOM(K)  = ZERO
14320          PSC(K)   = ZERO
14321          PPF(K)   = ZERO
14322          PTF(K)   = ZERO
14323          PPLM1(K) = ZERO
14324          PPLM2(K) = ZERO
14325          PTLM1(K) = ZERO
14326          PTLM2(K) = ZERO
14327     1 CONTINUE
14328       DO 2 K=1,2
14329          XPH(K)   = ZERO
14330          XPPO(K)  = ZERO
14331          XTH(K)   = ZERO
14332          XTPO(K)  = ZERO
14333          IFPPO(K) = 0
14334          IFTPO(K) = 0
14335     2 CONTINUE
14336       IDPR  = 0
14337       IDXPR = 0
14338       IDTR  = 0
14339       IDXTR = 0
14340
14341       RETURN
14342       END
14343
14344 *$ CREATE DT_DIFPUT.FOR
14345 *COPY DT_DIFPUT
14346 *
14347 *===difput=============================================================*
14348 *
14349       SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,
14350      &                                                          IREJ)
14351
14352 ************************************************************************
14353 * Dump diffractive chains into DTEVT1                                  *
14354 * This version dated 12.02.95 is written by S. Roesler                 *
14355 ************************************************************************
14356
14357       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14358       SAVE
14359       PARAMETER ( LINP = 10 ,
14360      &            LOUT = 6 ,
14361      &            LDAT = 9 )
14362       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14363
14364       LOGICAL LCHK
14365
14366 * kinematics of diffractive interactions (DTUNUC 1.x)
14367       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14368      &                PPF(4),PTF(4),
14369      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14370      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14371 * event history
14372       PARAMETER (NMXHKK=200000)
14373       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14374      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14375      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14376 * extended event history
14377       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14378      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14379      &                IHIST(2,NMXHKK)
14380 * rejection counter
14381       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
14382      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
14383      &                IREXCI(3),IRDIFF(2),IRINC
14384
14385       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4),
14386      &          P1(4),P2(4),P3(4),P4(4)
14387
14388       IREJ = 0
14389
14390       IF (KP.EQ.1) THEN
14391          DO 1 K=1,4
14392             PCH(K) = PPLM1(K)+PPLM2(K)
14393     1    CONTINUE
14394          ID1 = IFP1
14395          ID2 = IFP2
14396          IF (DT_RNDM(PT).GT.OHALF) THEN
14397             ID1 = IFP2
14398             ID2 = IFP1
14399          ENDIF
14400          CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3),
14401      &                                        PPLM1(4),0,0,0)
14402          CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3),
14403      &                                        PPLM2(4),0,0,0)
14404          CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14405      &                                              IDPR,IDXPR,8)
14406       ELSEIF (KP.EQ.2) THEN
14407          DO 2 K=1,4
14408             PP1(K) = XPH(1)*PP(K)
14409             PP2(K) = XPH(2)*PP(K)
14410             PT1(K) = -XPPO(1)*PPOM(K)
14411             PT2(K) = -XPPO(2)*PPOM(K)
14412     2    CONTINUE
14413          CALL  DT_CHKCSY(IFP1,IFPPO(1),LCHK)
14414          XM1 = ZERO
14415          XM2 = ZERO
14416          IF (LCHK) THEN
14417             CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14418             IF (IREJ1.NE.0) GOTO 9999
14419             CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14420             IF (IREJ1.NE.0) GOTO 9999
14421             DO 3 K=1,4
14422                PP1(K) = P1(K)
14423                PT1(K) = P2(K)
14424                PP2(K) = P3(K)
14425                PT2(K) = P4(K)
14426     3       CONTINUE
14427             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14428      &                                                       0,0,8)
14429             CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14430      &                                             PT1(4),0,0,8)
14431             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14432      &                                                       0,0,8)
14433             CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14434      &                                             PT2(4),0,0,8)
14435          ELSE
14436             CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14437             IF (IREJ1.NE.0) GOTO 9999
14438             CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14439             IF (IREJ1.NE.0) GOTO 9999
14440             DO 4 K=1,4
14441                PP1(K) = P1(K)
14442                PT2(K) = P2(K)
14443                PP2(K) = P3(K)
14444                PT1(K) = P4(K)
14445     4       CONTINUE
14446             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14447      &                                                       0,0,8)
14448             CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14449      &                                                PT2(4),0,0,8)
14450             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14451      &                                                       0,0,8)
14452             CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14453      &                                                PT1(4),0,0,8)
14454          ENDIF
14455          NCSY = NCSY+1
14456       ELSE
14457          CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4),
14458      &                                                        0,0,0)
14459       ENDIF
14460
14461       IF (KT.EQ.1) THEN
14462          DO 5 K=1,4
14463             PCH(K) = PTLM1(K)+PTLM2(K)
14464     5    CONTINUE
14465          ID1 = IFT1
14466          ID2 = IFT2
14467          IF (DT_RNDM(PT).GT.OHALF) THEN
14468             ID1 = IFT2
14469             ID2 = IFT1
14470          ENDIF
14471          CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3),
14472      &                                              PTLM1(4),0,0,0)
14473          CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3),
14474      &                                              PTLM2(4),0,0,0)
14475          CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14476      &                                              IDTR,IDXTR,8)
14477       ELSEIF (KT.EQ.2) THEN
14478          DO 6 K=1,4
14479             PP1(K) = XTPO(1)*PPOM(K)
14480             PP2(K) = XTPO(2)*PPOM(K)
14481             PT1(K) = XTH(2)*PT(K)
14482             PT2(K) = XTH(1)*PT(K)
14483     6    CONTINUE
14484          CALL  DT_CHKCSY(IFTPO(1),IFT1,LCHK)
14485          XM1 = ZERO
14486          XM2 = ZERO
14487          IF (LCHK) THEN
14488             CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14489             IF (IREJ1.NE.0) GOTO 9999
14490             CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14491             IF (IREJ1.NE.0) GOTO 9999
14492             DO 7 K=1,4
14493                PP1(K) = P1(K)
14494                PT1(K) = P2(K)
14495                PP2(K) = P3(K)
14496                PT2(K) = P4(K)
14497     7       CONTINUE
14498             CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14499      &                                                PP1(4),0,0,8)
14500             CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14501      &                                                       0,0,8)
14502             CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14503      &                                                PP2(4),0,0,8)
14504             CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14505      &                                                       0,0,8)
14506          ELSE
14507             CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14508             IF (IREJ1.NE.0) GOTO 9999
14509             CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14510             IF (IREJ1.NE.0) GOTO 9999
14511             DO 8 K=1,4
14512                PP1(K) = P1(K)
14513                PT2(K) = P2(K)
14514                PP2(K) = P3(K)
14515                PT1(K) = P4(K)
14516     8       CONTINUE
14517             CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14518      &                                                PP1(4),0,0,8)
14519             CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14520      &                                                       0,0,8)
14521             CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14522      &                                                PP2(4),0,0,8)
14523             CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14524      &                                                       0,0,8)
14525          ENDIF
14526          NCSY = NCSY+1
14527       ELSE
14528          CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4),
14529      &                                                        0,0,0)
14530       ENDIF
14531
14532       RETURN
14533
14534  9999 CONTINUE
14535       IRDIFF(2) = IRDIFF(2)+1
14536       IREJ      = 1
14537       RETURN
14538       END
14539
14540 *$ CREATE DT_EVTFRG.FOR
14541 *COPY DT_EVTFRG
14542 *
14543 *===evtfrg=============================================================*
14544 *
14545       SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ)
14546
14547 ************************************************************************
14548 * Hadronization of chains in DTEVT1.                                   *
14549 *                                                                      *
14550 * Input:                                                               *
14551 *   KMODE = 1   hadronization of PHOJET-chains (id=77xxx)              *
14552 *         = 2   hadronization of DTUNUC-chains (id=88xxx)              *
14553 *   NFRG  if KMODE = 1 : upper index of PHOJET-scatterings to be       *
14554 *                        hadronized with one PYEXEC call               *
14555 *         if KMODE = 2 : max. number of DTUNUC-chains to be hadronized *
14556 *                        with one PYEXEC call                          *
14557 * Output:                                                              *
14558 *   NPYMEM      number of entries in JETSET-common after hadronization *
14559 *   IREJ        rejection flag                                         *
14560 *                                                                      *
14561 * This version dated 17.09.00 is written by S. Roesler                 *
14562 ************************************************************************
14563
14564       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14565       SAVE
14566       PARAMETER ( LINP = 10 ,
14567      &            LOUT = 6 ,
14568      &            LDAT = 9 )
14569       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1)
14570       PARAMETER (ONE=1.0D0,ZERO=0.0D0)
14571
14572       LOGICAL LACCEP
14573
14574       PARAMETER (MXJOIN=200)
14575
14576 * event history
14577       PARAMETER (NMXHKK=200000)
14578       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14579      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14580      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14581 * extended event history
14582       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14583      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14584      &                IHIST(2,NMXHKK)
14585 * flags for input different options
14586       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14587       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14588      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14589 * statistics
14590       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
14591      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
14592      &                ICEVTG(8,0:30)
14593 * flags for diffractive interactions (DTUNUC 1.x)
14594       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
14595 * nucleon-nucleon event-generator
14596       CHARACTER*8 CMODEL
14597       LOGICAL LPHOIN
14598       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
14599 * phojet
14600 C  model switches and parameters
14601       CHARACTER*8 MDLNA
14602       INTEGER ISWMDL,IPAMDL
14603       DOUBLE PRECISION PARMDL
14604       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14605 * jetset
14606       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14607       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
14608       PARAMETER (MAXLND=4000)
14609       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
14610       INTEGER PYK
14611       DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
14612       INTEGER PYCOMP
14613       MODE = KMODE
14614       ISTSTG = 7
14615       IF (MODE.NE.1) ISTSTG = 8
14616       IREJ = 0
14617
14618       IP     = 0
14619       ISH    = 0
14620       INIEMC = 1
14621       NEND   = NHKK
14622       NACCEP = 0
14623       IFRG   = 0
14624       IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
14625       DO 10 I=NPOINT(3),NEND
14626 * sr 14.02.00: seems to be not necessary anymore, commented
14627 C        LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
14628 C    &            ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
14629          LACCEP = .TRUE.
14630 * pick up chains from dtevt1
14631          IDCHK = IDHKK(I)/10000
14632          IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN
14633             IF (IDCHK.EQ.7) THEN
14634                IPJE = IDHKK(I)-IDCHK*10000
14635                IF (IPJE.NE.IFRG) THEN
14636                   IFRG = IPJE
14637                   IF (IFRG.GT.NFRG) GOTO 16
14638                ENDIF
14639             ELSE
14640                IPJE = 1
14641                IFRG = IFRG+1
14642                IF (IFRG.GT.NFRG) THEN
14643                   NFRG = -1
14644                   GOTO 16
14645                ENDIF
14646             ENDIF
14647 *   statistics counter
14648 c           IF (IDCH(I).LE.8)
14649 c    &         ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
14650 c           IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
14651 * special treatment for small chains already corrected to hadrons
14652             IF (IDRES(I).NE.0) THEN
14653                IF (IDRES(I).EQ.11) THEN
14654                   ID = IDXRES(I)
14655                ELSE
14656                   ID = IDT_IPDGHA(IDXRES(I))
14657                ENDIF
14658                IF (LEMCCK) THEN
14659                   CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
14660      &                              PHKK(4,I),INIEMC,IDUM,IDUM)
14661                   INIEMC = 2
14662                ENDIF
14663                IP = IP+1
14664                IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
14665                P(IP,1) = PHKK(1,I)
14666                P(IP,2) = PHKK(2,I)
14667                P(IP,3) = PHKK(3,I)
14668                P(IP,4) = PHKK(4,I)
14669                P(IP,5) = PHKK(5,I)
14670                K(IP,1) = 1
14671                K(IP,2) = ID
14672                K(IP,3) = 0
14673                K(IP,4) = 0
14674                K(IP,5) = 0
14675                IHIST(2,I) = 10000*IPJE+IP
14676                IF (IHIST(1,I).LE.-100) THEN
14677                   ISH = ISH+1
14678                   IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14679                   ISJOIN(ISH) = I
14680                ENDIF
14681                N = IP
14682                IHISMO(IP) = I
14683             ELSE
14684                IJ  = 0
14685                DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
14686                   IF (LEMCCK) THEN
14687                      CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK),
14688      &                                   PHKK(4,KK),INIEMC,IDUM,IDUM)
14689                      CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM)
14690                      INIEMC = 2
14691                   ENDIF
14692                   ID = IDHKK(KK)
14693                   IF (ID.EQ.0) ID = 21
14694 c                  PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
14695 c                  AM0  = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
14696 c                  AMRQ   = PYMASS(ID)
14697 c                  AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
14698 c                  IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
14699 c     &                (ABS(IDIFF).EQ.0)) THEN
14700 cC                    WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
14701 c                     DELTA      = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
14702 c                     PHKK(4,KK) = PHKK(4,KK)+DELTA
14703 c                     PTOT1      = PTOT-DELTA
14704 c                     PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
14705 c                     PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
14706 c                     PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
14707 c                     PHKK(5,KK) = AMRQ
14708 c                  ENDIF
14709                   IP = IP+1
14710                   IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
14711                   P(IP,1) = PHKK(1,KK)
14712                   P(IP,2) = PHKK(2,KK)
14713                   P(IP,3) = PHKK(3,KK)
14714                   P(IP,4) = PHKK(4,KK)
14715                   P(IP,5) = PHKK(5,KK)
14716                   K(IP,1) = 1
14717                   K(IP,2) = ID
14718                   K(IP,3) = 0
14719                   K(IP,4) = 0
14720                   K(IP,5) = 0
14721                   IHIST(2,KK) = 10000*IPJE+IP
14722                   IF (IHIST(1,KK).LE.-100) THEN
14723                      ISH = ISH+1
14724                      IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14725                      ISJOIN(ISH) = KK
14726                   ENDIF
14727                   IJ = IJ+1
14728                   IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
14729                   IJOIN(IJ)  = IP
14730                   IHISMO(IP) = I
14731    11          CONTINUE
14732                N = IP
14733 * join the two-parton system
14734                CALL PYJOIN(IJ,IJOIN)
14735             ENDIF
14736             IDHKK(I) = 99999
14737          ENDIF
14738    10 CONTINUE
14739    16 CONTINUE
14740       N = IP
14741
14742       IF (IP.GT.0) THEN
14743
14744 * final state parton shower
14745          DO 136 NPJE=1,IPJE
14746             IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
14747                IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
14748                   DO 130 K1=1,ISH
14749                      IF (ISJOIN(K1).EQ.0) GOTO 130
14750                      I = ISJOIN(K1)
14751                      IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
14752      &                                                       GOTO 130
14753                      IH1 = IHIST(2,I)/10000
14754                      IF (IH1.NE.NPJE) GOTO 130
14755                      IH1 = IHIST(2,I)-IH1*10000
14756                      DO 135 K2=K1+1,ISH
14757                         IF (ISJOIN(K2).EQ.0) GOTO 135
14758                         II = ISJOIN(K2)
14759                         IH2 = IHIST(2,II)/10000
14760                         IF (IH2.NE.NPJE) GOTO 135
14761                         IH2 = IHIST(2,II)-IH2*10000
14762                         IF (IHIST(1,I).EQ.IHIST(1,II)) THEN
14763                            PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2)
14764                            PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2)
14765                            RQLUN = MIN(PT1,PT2)
14766                            CALL PYSHOW(IH1,IH2,RQLUN)
14767
14768                            ISJOIN(K1) = 0
14769                            ISJOIN(K2) = 0
14770                            GOTO 130
14771                         ENDIF
14772  135                 CONTINUE
14773  130              CONTINUE
14774                ENDIF
14775             ENDIF
14776  136     CONTINUE
14777
14778          CALL DT_INITJS(MODE)
14779 * hadronization
14780
14781          CALL PYEXEC
14782
14783          IF (MSTU(24).NE.0) THEN
14784             WRITE(LOUT,*) ' JETSET-reject at event',
14785      &                    NEVHKK,MSTU(24),KMODE
14786 C           CALL DT_EVTOUT(4)
14787
14788 C           CALL PYLIST(2)
14789
14790             GOTO 9999
14791          ENDIF
14792
14793 *   number of entries in LUJETS
14794
14795          NLINES = PYK(0,1)
14796
14797          NPYMEM = NLINES
14798
14799          DO 12 I=1,NLINES
14800             IFLG(I) = 0
14801    12    CONTINUE
14802
14803          DO 13 II=1,NLINES
14804
14805             IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
14806
14807 *  pick up mother resonance if possible and put it together with
14808 *  their decay-products into the common
14809                IDXMOR = K(II,3)
14810                IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
14811                   KFMOR = K(IDXMOR,2)
14812                   ISMOR = K(IDXMOR,1)
14813                ELSE
14814                   KFMOR = 91
14815                   ISMOR = 1
14816                ENDIF
14817                IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
14818      &             (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
14819                   ID = K(IDXMOR,2)
14820                   MO = IHISMO(PYK(IDXMOR,15))
14821                   PX = PYP(IDXMOR,1)
14822                   PY = PYP(IDXMOR,2)
14823                   PZ = PYP(IDXMOR,3)
14824                   PE = PYP(IDXMOR,4)
14825                   CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14826                   IFLG(IDXMOR) = 1
14827                   MO = NHKK
14828                   DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
14829                      IF (PYK(JDAUG,7).EQ.1) THEN
14830                         ID = PYK(JDAUG,8)
14831                         PX = PYP(JDAUG,1)
14832                         PY = PYP(JDAUG,2)
14833                         PZ = PYP(JDAUG,3)
14834                         PE = PYP(JDAUG,4)
14835                         CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14836                         IF (LEMCCK) THEN
14837                            PX = -PYP(JDAUG,1)
14838                            PY = -PYP(JDAUG,2)
14839                            PZ = -PYP(JDAUG,3)
14840                            PE = -PYP(JDAUG,4)
14841                            CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14842                         ENDIF
14843                         IFLG(JDAUG) = 1
14844                      ENDIF
14845    15             CONTINUE
14846                ELSE
14847 *  there was no mother resonance
14848                   MO = IHISMO(PYK(II,15))
14849                   ID = PYK(II,8)
14850                   PX = PYP(II,1)
14851                   PY = PYP(II,2)
14852                   PZ = PYP(II,3)
14853                   PE = PYP(II,4)
14854                   CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14855                   IF (LEMCCK) THEN
14856                      PX = -PYP(II,1)
14857                      PY = -PYP(II,2)
14858                      PZ = -PYP(II,3)
14859                      PE = -PYP(II,4)
14860                      CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14861                   ENDIF
14862                ENDIF
14863             ENDIF
14864    13    CONTINUE
14865          IF (LEMCCK) THEN
14866             CHKLEV = TINY1
14867             CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
14868 C           IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
14869          ENDIF
14870
14871 * global energy-momentum & flavor conservation check
14872 **sr 16.5. this check is skipped in case of phojet-treatment
14873          IF (MCGENE.EQ.1)
14874      &      CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
14875
14876 * update statistics-counter for diffraction
14877 c        IF (IFLAGD.NE.0) THEN
14878 c           ICDIFF(1) = ICDIFF(1)+1
14879 c           IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
14880 c           IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
14881 c           IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
14882 c           IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
14883 c        ENDIF
14884
14885       ENDIF
14886
14887       RETURN
14888
14889  9999 CONTINUE
14890       IREJ = 1
14891       RETURN
14892       END
14893
14894 *$ CREATE DT_DECAYS.FOR
14895 *COPY DT_DECAYS
14896 *
14897 *===decay==============================================================*
14898 *
14899       SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
14900
14901 ************************************************************************
14902 * Resonance-decay.                                                     *
14903 * This subroutine replaces DDECAY/DECHKK.                              *
14904 *             PIN(4)      4-momentum of resonance          (input)     *
14905 *             IDXIN       BAMJET-index of resonance        (input)     *
14906 *             POUT(20,4)  4-momenta of decay-products      (output)    *
14907 *             IDXOUT(20)  BAMJET-indices of decay-products (output)    *
14908 *             NSEC        number of secondaries            (output)    *
14909 * Adopted from the original version DECHKK.                            *
14910 * This version dated 09.01.95 is written by S. Roesler                 *
14911 ************************************************************************
14912
14913       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14914       SAVE
14915       PARAMETER ( LINP = 10 ,
14916      &            LOUT = 6 ,
14917      &            LDAT = 9 )
14918       PARAMETER (TINY17=1.0D-17)
14919
14920 * HADRIN: decay channel information
14921       PARAMETER (IDMAX9=602)
14922       CHARACTER*8 ZKNAME
14923       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
14924 * particle properties (BAMJET index convention)
14925       CHARACTER*8  ANAME
14926       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
14927      &                IICH(210),IIBAR(210),K1(210),K2(210)
14928 * flags for input different options
14929       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14930       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14931      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14932
14933       DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20),
14934      &          EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3),
14935      &          CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3)
14936
14937 * ISTAB = 1 strong and weak decays
14938 *       = 2 strong decays only
14939 *       = 3 strong decays, weak decays for charmed particles and tau
14940 *           leptons only
14941       DATA ISTAB /2/
14942
14943       IREJ = 0
14944       NSEC = 0
14945 * put initial resonance to stack
14946       NSTK = 1
14947       IDXSTK(NSTK) = IDXIN
14948       DO 5 I=1,4
14949          PI(NSTK,I) = PIN(I)
14950     5 CONTINUE
14951
14952 * store initial configuration for energy-momentum cons. check
14953       IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3),
14954      &                                   PI(NSTK,4),1,IDUM,IDUM)
14955
14956   100 CONTINUE
14957 * get particle from stack
14958       IDXI = IDXSTK(NSTK)
14959 * skip stable particles
14960       IF (ISTAB.EQ.1) THEN
14961          IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10
14962          IF ((IDXI.GE.  1).AND.(IDXI.LE.  7)) GOTO 10
14963       ELSEIF (ISTAB.EQ.2) THEN
14964          IF ((IDXI.GE.  1).AND.(IDXI.LE. 30)) GOTO 10
14965          IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
14966          IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10
14967          IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10
14968          IF ( IDXI.EQ.109)                    GOTO 10
14969          IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10
14970       ELSEIF (ISTAB.EQ.3) THEN
14971          IF ((IDXI.GE.  1).AND.(IDXI.LE. 23)) GOTO 10
14972          IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
14973          IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10
14974          IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10
14975       ENDIF
14976
14977 * calculate direction cosines and Lorentz-parameter of decaying part.
14978       PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2)
14979       PTOT = MAX(PTOT,TINY17)
14980       DO 1 I=1,3
14981          DCOS(I) = PI(NSTK,I)/PTOT
14982     1 CONTINUE
14983       GAM  = PI(NSTK,4)/AAM(IDXI)
14984       BGAM = PTOT/AAM(IDXI)
14985
14986 * get decay-channel
14987       KCHAN = K1(IDXI)-1
14988     2 CONTINUE
14989       KCHAN = KCHAN+1
14990       IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
14991
14992 * identities of secondaries
14993       IDX(1) = NZK(KCHAN,1)
14994       IDX(2) = NZK(KCHAN,2)
14995       IF (IDX(2).LT.1) GOTO 9999
14996       IDX(3) = NZK(KCHAN,3)
14997
14998 * handle decay in rest system of decaying particle
14999       IF (IDX(3).EQ.0) THEN
15000 *   two-particle decay
15001          NDEC = 2
15002          CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2),
15003      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15004      &               AAM(IDX(1)),AAM(IDX(2)))
15005       ELSE
15006 *   three-particle decay
15007          NDEC = 3
15008          CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3),
15009      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15010      &               CODF(3),COFF(3),SIFF(3),
15011      &               AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3)))
15012       ENDIF
15013       NSTK = NSTK-1
15014
15015 * transform decay products back
15016       DO 3 I=1,NDEC
15017          NSTK = NSTK+1
15018          CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3),
15019      &               CODF(I),COFF(I),SIFF(I),PF(I),EF(I),
15020      &               PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4))
15021 * add particle to stack
15022          IDXSTK(NSTK) = IDX(I)
15023          DO 4 J=1,3
15024             PI(NSTK,J) = DCOSF(J)*PFF(I)
15025     4    CONTINUE
15026     3 CONTINUE
15027       GOTO 100
15028
15029    10 CONTINUE
15030 * stable particle, put to output-arrays
15031       NSEC = NSEC+1
15032       DO 6 I=1,4
15033          POUT(NSEC,I) = PI(NSTK,I)
15034     6 CONTINUE
15035       IDXOUT(NSEC) = IDXSTK(NSTK)
15036 * store secondaries for energy-momentum conservation check
15037       IF (LEMCCK)
15038      &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
15039      &            -POUT(NSEC,4),2,IDUM,IDUM)
15040       NSTK = NSTK-1
15041       IF (NSTK.GT.0) GOTO 100
15042
15043 * check energy-momentum conservation
15044       IF (LEMCCK) THEN
15045          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
15046          IF (IREJ1.NE.0) GOTO 9999
15047       ENDIF
15048
15049       RETURN
15050
15051  9999 CONTINUE
15052       IREJ = 1
15053       RETURN
15054       END
15055
15056 *$ CREATE DT_DECAY1.FOR
15057 *COPY DT_DECAY1
15058 *
15059 *===decay1=============================================================*
15060 *
15061       SUBROUTINE DT_DECAY1
15062
15063 ************************************************************************
15064 * Decay of resonances stored in DTEVT1.                                *
15065 * This version dated 20.01.95 is written by S. Roesler                 *
15066 ************************************************************************
15067
15068       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15069       SAVE
15070       PARAMETER ( LINP = 10 ,
15071      &            LOUT = 6 ,
15072      &            LDAT = 9 )
15073
15074 * event history
15075       PARAMETER (NMXHKK=200000)
15076       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15077      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15078      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15079 * extended event history
15080       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15081      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15082      &                IHIST(2,NMXHKK)
15083
15084       DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
15085
15086       NEND = NHKK
15087 C     DO 1 I=NPOINT(5),NEND
15088       DO 1 I=NPOINT(4),NEND
15089          IF (ABS(ISTHKK(I)).EQ.1) THEN
15090             DO 2 K=1,4
15091                PIN(K) = PHKK(K,I)
15092     2       CONTINUE
15093             IDXIN = IDBAM(I)
15094             CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15095             IF (NSEC.GT.1) THEN
15096                DO 3 N=1,NSEC
15097                   IDHAD = IDT_IPDGHA(IDXOUT(N))
15098                   CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2),
15099      &                               POUT(N,3),POUT(N,4),0,0,0)
15100     3          CONTINUE
15101             ENDIF
15102          ENDIF
15103     1 CONTINUE
15104
15105       RETURN
15106       END
15107
15108 *$ CREATE DT_DECPI0.FOR
15109 *COPY DT_DECPI0
15110 *
15111 *===decpi0=============================================================*
15112 *
15113       SUBROUTINE DT_DECPI0
15114
15115 ************************************************************************
15116 * Decay of pi0 handled with JETSET.                                    *
15117 * This version dated 18.02.96 is written by S. Roesler                 *
15118 ************************************************************************
15119
15120       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15121       SAVE
15122       PARAMETER ( LINP = 10 ,
15123      &            LOUT = 6 ,
15124      &            LDAT = 9 )
15125       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0)
15126
15127 * event history
15128       PARAMETER (NMXHKK=200000)
15129       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15130      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15131      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15132 * extended event history
15133       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15134      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15135      &                IHIST(2,NMXHKK)
15136       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15137       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15138       PARAMETER (MAXLND=4000)
15139       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15140 * flags for input different options
15141       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15142       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15143      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15144
15145       INTEGER PYCOMP,PYK
15146
15147       DIMENSION IHISMO(NMXHKK),P1(4)
15148
15149       TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
15150
15151       CALL DT_INITJS(2)
15152 * allow pi0 decay
15153       KC = PYCOMP(111)
15154       MDCY(KC,1) = 1
15155
15156       NN  = 0
15157       INI = 0
15158       DO 1 I=1,NHKK
15159          IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
15160             IF (INI.EQ.0) THEN
15161                INI = 1
15162             ELSE
15163                INI = 2
15164             ENDIF
15165             IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15166      &                                    PHKK(4,I),INI,IDUM,IDUM)
15167             PT    = SQRT(PHKK(1,I)**2+PHKK(2,I)**2)
15168             PTOT  = SQRT(PT**2+PHKK(3,I)**2)
15169             COSTH = PHKK(3,I)/(PTOT+TINY10)
15170             IF (COSTH.GT.ONE) THEN
15171                THETA = ZERO
15172             ELSEIF (COSTH.LT.-ONE) THEN
15173                THETA = TWOPI/2.0D0
15174             ELSE
15175                THETA = ACOS(COSTH)
15176             ENDIF
15177             PHI     = ASIN(PHKK(2,I)/(PT  +TINY10))
15178             IF (PHKK(1,I).LT.0.0D0)
15179      &         PHI  = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
15180             ENER    = PHKK(4,I)
15181             NN      = NN+1
15182             KTEMP   = MSTU(10)
15183             MSTU(10)= 1
15184             P(NN,5) = PHKK(5,I)
15185             CALL PY1ENT(NN,111,ENER,THETA,PHI)
15186             MSTU(10)  = KTEMP
15187             IHISMO(NN)= I
15188          ENDIF
15189     1 CONTINUE
15190       IF (NN.GT.0) THEN
15191          CALL PYEXEC
15192          NLINES = PYK(0,1)
15193          DO 2 II=1,NLINES
15194             IF (PYK(II,7).EQ.1) THEN
15195                DO 3 KK=1,4
15196                   P1(KK) = PYP(II,KK)
15197     3          CONTINUE
15198                ID = PYK(II,8)
15199                MO = IHISMO(PYK(II,15))
15200                CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
15201                IF (LEMCCK)
15202      &            CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
15203      &                                            IDUM,IDUM)
15204 *sr: flag with neg. sign (for HELIOS p/A-W jobs)
15205                ISTHKK(MO) = -2
15206             ENDIF
15207     2    CONTINUE
15208          IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
15209       ENDIF
15210       MDCY(KC,1) = 0
15211
15212       RETURN
15213       END
15214
15215 *$ CREATE DT_DTWOPD.FOR
15216 *COPY DT_DTWOPD
15217 *
15218 *===dtwopd=============================================================*
15219 *
15220       SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
15221      &                                            COF2,SIF2,AM1,AM2)
15222
15223 ************************************************************************
15224 * Two-particle decay.                                                  *
15225 *  UMO                 cm-energy of the decaying system       (input)  *
15226 *  AM1/AM2             masses of the decay products           (input)  *
15227 *  ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) *
15228 *  COD,COF,SIF         direction cosines of the decay prod.   (output) *
15229 * Revised by S. Roesler, 20.11.95                                      *
15230 ************************************************************************
15231
15232       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15233       SAVE
15234       PARAMETER ( LINP = 10 ,
15235      &            LOUT = 6 ,
15236      &            LDAT = 9 )
15237       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
15238
15239       IF (UMO.LT.(AM1+AM2)) THEN
15240          WRITE(LOUT,1000) UMO,AM1,AM2
15241  1000    FORMAT(1X,'DTWOPD:    inconsistent kinematics - UMO,AM1,AM2 ',
15242      &          3E12.3)
15243          STOP
15244       ENDIF
15245
15246       ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
15247       ECM2 = UMO-ECM1
15248       PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
15249       PCM2 = PCM1
15250       CALL DT_DSFECF(SIF1,COF1)
15251       COD1 = TWO*DT_RNDM(PCM2)-ONE
15252       COD2 = -COD1
15253       COF2 = -COF1
15254       SIF2 = -SIF1
15255
15256       RETURN
15257       END
15258
15259 *$ CREATE DT_DTHREP.FOR
15260 *COPY DT_DTHREP
15261 *
15262 *===dthrep=============================================================*
15263 *
15264       SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
15265      &                  SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
15266
15267 ************************************************************************
15268 * Three-particle decay.                                                *
15269 *  UMO                 cm-energy of the decaying system       (input)  *
15270 *  AM1/2/3             masses of the decay products           (input)  *
15271 *  ECM1/2/2,PCM1/2/3   cm-energies/momenta of the decay prod. (output) *
15272 *  COD,COF,SIF         direction cosines of the decay prod.   (output) *
15273 *                                                                      *
15274 * Threpd89: slight revision by A. Ferrari                              *
15275 * Last change on   11-oct-93   by    Alfredo Ferrari, INFN - Milan     *
15276 * Revised by S. Roesler, 20.11.95                                      *
15277 ************************************************************************
15278
15279       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15280       SAVE
15281       PARAMETER ( LINP = 10 ,
15282      &            LOUT = 6 ,
15283      &            LDAT = 9 )
15284
15285       PARAMETER ( ANGLSQ = 2.5D-31 )
15286       PARAMETER ( AZRZRZ = 1.0D-30 )
15287       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
15288       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
15289       PARAMETER ( ONEONE = 1.D+00 )
15290       PARAMETER ( TWOTWO = 2.D+00 )
15291       PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
15292
15293       COMMON /HNGAMR/ REDU,AMO,AMM(15)
15294 * flags for input different options
15295       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15296       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15297      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15298
15299       DIMENSION F(5),XX(5)
15300       DATA EPS /AZRZRZ/
15301
15302       UMOO=UMO+UMO
15303 C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
15304 C***J. VON NEUMANN - RANDOM - SELECTION OF S2
15305 C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
15306       UUMO=UMO
15307       AAM1=AM1
15308       AAM2=AM2
15309       AAM3=AM3
15310       GU=(AM2+AM3)**2
15311       GO=(UMO-AM1)**2
15312 *     UFAK=1.0000000000001D0
15313 *     IF (GU.GT.GO) UFAK=0.9999999999999D0
15314       IF (GU.GT.GO) THEN
15315          UFAK=ONEMNS
15316       ELSE
15317          UFAK=ONEPLS
15318       END IF
15319       OFAK=2.D0-UFAK
15320       GU=GU*UFAK
15321       GO=GO*OFAK
15322       DS2=(GO-GU)/99.D0
15323       AM11=AM1*AM1
15324       AM22=AM2*AM2
15325       AM33=AM3*AM3
15326       UMO2=UMO*UMO
15327       RHO2=0.D0
15328       S22=GU
15329       DO 124 I=1,100
15330          S21=S22
15331          S22=GU+(I-1.D0)*DS2
15332          RHO1=RHO2
15333          RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
15334      *                                             (S22+EPS)
15335          IF(RHO2.LT.RHO1) GO TO 125
15336   124 CONTINUE
15337   125 S2SUP=(S22-S21)*.5D0+S21
15338       SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
15339      *                                           (S2SUP+EPS)
15340       SUPRHO=SUPRHO*1.05D0
15341       XO=S21-DS2
15342       IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
15343       IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
15344       XX(1)=XO
15345       XX(3)=S22
15346       X1=(XO+S22)*0.5D0
15347       XX(2)=X1
15348       F(3)=RHO2
15349       F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS)
15350       F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS)
15351       DO 126 I=1,16
15352          X4=(XX(1)+XX(2))*0.5D0
15353          X5=(XX(2)+XX(3))*0.5D0
15354          F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/
15355      *                                               (X4+EPS)
15356          F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
15357      *                                               (X5+EPS)
15358          XX(4)=X4
15359          XX(5)=X5
15360          DO 128 II=1,5
15361             IA=II
15362             DO 128 III=IA,5
15363                IF (F (II).GE.F (III)) GO TO 128
15364                FH=F(II)
15365                F(II)=F(III)
15366                F(III)=FH
15367                FH=XX(II)
15368                XX(II)=XX(III)
15369                XX(III)=FH
15370 128      CONTINUE
15371          SUPRHO=F(1)
15372          S2SUP=XX(1)
15373          DO 129 II=1,3
15374             IA=II
15375             DO 129 III=IA,3
15376                IF (XX(II).GE.XX(III)) GO TO 129
15377                FH=F(II)
15378                F(II)=F(III)
15379                F(III)=FH
15380                FH=XX(II)
15381                XX(II)=XX(III)
15382                XX(III)=FH
15383 129      CONTINUE
15384 126   CONTINUE
15385       AM23=(AM2+AM3)**2
15386       ITH=0
15387       REDU=2.D0
15388     1 CONTINUE
15389       ITH=ITH+1
15390       IF (ITH.GT.200) REDU=-9.D0
15391       IF (ITH.GT.200) GO TO 400
15392       C=DT_RNDM(REDU)
15393 *     S2=AM23+C*((UMO-AM1)**2-AM23)
15394       S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
15395       Y=DT_RNDM(S2)
15396       Y=Y*SUPRHO
15397       RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
15398       IF(Y.GT.RHO) GO TO 1
15399 C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
15400       S1=DT_RNDM(S2)
15401       S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
15402      &RHO*.5D0
15403       S3=UMO2+AM11+AM22+AM33-S1-S2
15404       ECM1=(UMO2+AM11-S2)/UMOO
15405       ECM2=(UMO2+AM22-S3)/UMOO
15406       ECM3=(UMO2+AM33-S1)/UMOO
15407       PCM1=SQRT((ECM1+AM1)*(ECM1-AM1))
15408       PCM2=SQRT((ECM2+AM2)*(ECM2-AM2))
15409       PCM3=SQRT((ECM3+AM3)*(ECM3-AM3))
15410       CALL DT_DSFECF(SFE,CFE)
15411 C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
15412 C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
15413       PCM12 = PCM1 * PCM2
15414       IF ( PCM12 .LT. ANGLSQ ) GO TO 200
15415       COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12
15416       GO TO 300
15417  200  CONTINUE
15418          UW=DT_RNDM(S1)
15419          COSTH=(UW-0.5D+00)*2.D+00
15420  300  CONTINUE
15421 *     IF(ABS(COSTH).GT.0.9999999999999999D0)
15422 *    &COSTH=SIGN(0.9999999999999999D0,COSTH)
15423       IF(ABS(COSTH).GT.ONEONE)
15424      &COSTH=SIGN(ONEONE,COSTH)
15425       IF (REDU.LT.1.D+00) RETURN
15426       COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3)
15427 *     IF(ABS(COSTH2).GT.0.9999999999999999D0)
15428 *    &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
15429       IF(ABS(COSTH2).GT.ONEONE)
15430      &COSTH2=SIGN(ONEONE,COSTH2)
15431       SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2))
15432       SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH))
15433       SINTH1=COSTH2*SINTH-COSTH*SINTH2
15434       COSTH1=COSTH*COSTH2+SINTH2*SINTH
15435 C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
15436 C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
15437 C***THE DIRECTION OF PARTICLE 3
15438 C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
15439       CX11=-COSTH1
15440       CY11=SINTH1*CFE
15441       CZ11=SINTH1*SFE
15442       CX22=-COSTH2
15443       CY22=-SINTH2*CFE
15444       CZ22=-SINTH2*SFE
15445       CALL DT_DSFECF(SIF3,COF3)
15446       COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
15447       SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
15448     2 FORMAT(5F20.15)
15449       COD1=CX11*COD3+CZ11*SID3
15450       CHLP=(ONEONE-COD1)*(ONEONE+COD1)
15451       IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3,
15452      &CX11,CZ11
15453       SID1=SQRT(CHLP)
15454       COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1
15455       SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1
15456       COD2=CX22*COD3+CZ22*SID3
15457       SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2))
15458       COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2
15459       SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2
15460  400  CONTINUE
15461 * === Energy conservation check: === *
15462       EOCHCK = UMO - ECM1 - ECM2 - ECM3
15463 *     SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
15464 *     SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
15465 *     SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
15466       PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3
15467       PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2
15468      &       + PCM3 * COF3 * SID3
15469       PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2
15470      &       + PCM3 * SIF3 * SID3
15471       EOCMPR = 1.D-12 * UMO
15472       IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK)
15473      &     .GT. EOCMPR ) THEN
15474 **sr 5.5.95 output-unit changed
15475          IF (IOULEV(1).GT.0) THEN
15476             WRITE(LOUT,*)
15477      &      ' *** Threpd: energy/momentum conservation failure! ***',
15478      &      EOCHCK,PXCHCK,PYCHCK,PZCHCK
15479             WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
15480          ENDIF
15481 **
15482       END IF
15483       RETURN
15484       END
15485
15486 *$ CREATE DT_DBKLAS.FOR
15487 *COPY DT_DBKLAS
15488 *
15489 *===dbklas=============================================================*
15490 *
15491       SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
15492
15493       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15494       SAVE
15495       PARAMETER ( LINP = 10 ,
15496      &            LOUT = 6 ,
15497      &            LDAT = 9 )
15498
15499 * quark-content to particle index conversion (DTUNUC 1.x)
15500       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15501      &                IA08(6,21),IA10(6,21)
15502
15503       IF (I) 20,20,10
15504 * baryons
15505    10 CONTINUE
15506       CALL DT_INDEXD(J,K,IND)
15507       I8  = IB08(I,IND)
15508       I10 = IB10(I,IND)
15509       IF (I8.LE.0) I8 = I10
15510       RETURN
15511 * antibaryons
15512    20 CONTINUE
15513       II = IABS(I)
15514       JJ = IABS(J)
15515       KK = IABS(K)
15516       CALL DT_INDEXD(JJ,KK,IND)
15517       I8  = IA08(II,IND)
15518       I10 = IA10(II,IND)
15519       IF (I8.LE.0) I8 = I10
15520
15521       RETURN
15522       END
15523
15524 *$ CREATE DT_INDEXD.FOR
15525 *COPY DT_INDEXD
15526 *
15527 *===indexd=============================================================*
15528 *
15529       SUBROUTINE DT_INDEXD(KA,KB,IND)
15530
15531       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15532       SAVE
15533       PARAMETER ( LINP = 10 ,
15534      &            LOUT = 6 ,
15535      &            LDAT = 9 )
15536
15537       KP = KA*KB
15538       KS = KA+KB
15539       IF (KP.EQ.1) IND=1
15540       IF (KP.EQ.2) IND=2
15541       IF (KP.EQ.3) IND=3
15542       IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
15543       IF (KP.EQ.5) IND=5
15544       IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6
15545       IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7
15546       IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8
15547       IF (KP.EQ.8)  IND=9
15548       IF (KP.EQ.10) IND=10
15549       IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11
15550       IF (KP.EQ.9)  IND=12
15551       IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13
15552       IF (KP.EQ.15) IND=14
15553       IF (KP.EQ.18) IND=15
15554       IF (KP.EQ.16) IND=16
15555       IF (KP.EQ.20) IND=17
15556       IF (KP.EQ.24) IND=18
15557       IF (KP.EQ.25) IND=19
15558       IF (KP.EQ.30) IND=20
15559       IF (KP.EQ.36) IND=21
15560
15561       RETURN
15562       END
15563
15564 *$ CREATE DT_DCHANT.FOR
15565 *COPY DT_DCHANT
15566 *
15567 *===dchant=============================================================*
15568 *
15569       SUBROUTINE DT_DCHANT
15570
15571       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15572       SAVE
15573       PARAMETER ( LINP = 10 ,
15574      &            LOUT = 6 ,
15575      &            LDAT = 9 )
15576       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15577
15578 * HADRIN: decay channel information
15579       PARAMETER (IDMAX9=602)
15580       CHARACTER*8 ZKNAME
15581       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15582 * particle properties (BAMJET index convention)
15583       CHARACTER*8  ANAME
15584       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15585      &                IICH(210),IIBAR(210),K1(210),K2(210)
15586
15587       DIMENSION HWT(IDMAX9)
15588
15589 * change of weights wt from absolut values into the sum of wt of a dec.
15590       DO 10 J=1,IDMAX9
15591          HWT(J) = ZERO
15592    10 CONTINUE
15593 C     DO 999 KKK=1,210
15594 C        WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
15595 C    &      ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
15596 C    &      K1(KKK),K2(KKK)
15597 C 999 CONTINUE
15598 C     STOP
15599       DO 30 I=1,210
15600          IK1 = K1(I)
15601          IK2 = K2(I)
15602          HV  = ZERO
15603          DO 20 J=IK1,IK2
15604             HV     = HV+WT(J)
15605             HWT(J) = HV
15606 **sr 13.1.95
15607             IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1
15608  1000       FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
15609    20    CONTINUE
15610    30 CONTINUE
15611       DO 40 J=1,IDMAX9
15612          WT(J) = HWT(J)
15613    40 CONTINUE
15614
15615       RETURN
15616       END
15617
15618 *$ CREATE DT_DDATAR.FOR
15619 *COPY DT_DDATAR
15620 *
15621 *===ddatar=============================================================*
15622 *
15623       SUBROUTINE DT_DDATAR
15624
15625       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15626       SAVE
15627       PARAMETER ( LINP = 10 ,
15628      &            LOUT = 6 ,
15629      &            LDAT = 9 )
15630       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15631
15632 * quark-content to particle index conversion (DTUNUC 1.x)
15633       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15634      &                IA08(6,21),IA10(6,21)
15635
15636       DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
15637
15638       DATA IV/ 33, 34, 38,123,  0,  0, 32, 33, 39,124,
15639      &          0,  0, 36, 37, 96,127,  0,  0,126,125,
15640      &        128,129,14*0/
15641       DATA IP/ 23, 14, 16,116,  0,  0, 13, 23, 25,117,
15642      &          0,  0, 15, 24, 31,120,  0,  0,119,118,
15643      &        121,122,14*0/
15644       DATA IB/  0,  1, 21,140,  0,  0,  8, 22,137,  0,
15645      &          0, 97,138,  0,  0,146,  0,  0,  0,  0,
15646      &          0,  1,  8, 22,137,  0,  0,  0, 20,142,
15647      &          0,  0, 98,139,  0,  0,147,  0,  0,  0,
15648      &          0,  0, 21, 22, 97,138,  0,  0, 20, 98,
15649      &        139,  0,  0,  0,145,  0,  0,148,  0,  0,
15650      &          0,  0,  0,140,137,138,146,  0,  0,142,
15651      &        139,147,  0,  0,145,148,           50*0/
15652       DATA IBB/53, 54,104,161,  0,  0, 55,105,162,  0,
15653      &          0,107,164,  0,  0,167,  0,  0,  0,  0,
15654      &          0, 54, 55,105,162,  0,  0, 56,106,163,
15655      &          0,  0,108,165,  0,  0,168,  0,  0,  0,
15656      &          0,  0,104,105,107,164,  0,  0,106,108,
15657      &        165,  0,  0,109,166,  0,  0,169,  0,  0,
15658      &          0,  0,  0,161,162,164,167,  0,  0,163,
15659      &        165,168,  0,  0,166,169,  0,  0,170,47*0/
15660       DATA IA/  0,  2, 99,152,  0,  0,  9,100,149,  0,
15661      &          0,102,150,  0,  0,158,  0,  0,  0,  0,
15662      &          0,  2,  9,100,149,  0,  0,  0,101,154,
15663      &          0,  0,103,151,  0,  0,159,  0,  0,  0,
15664      &          0,  0, 99,100,102,150,  0,  0,101,103,
15665      &        151,  0,  0,  0,157,  0,  0,160,  0,  0,
15666      &          0,  0,  0,152,149,150,158,  0,  0,154,
15667      &        151,159,  0,  0,157,160,           50*0/
15668       DATA IAA/67, 68,110,171,  0,  0, 69,111,172,  0,
15669      &          0,113,174,  0,  0,177,  0,  0,  0,  0,
15670      &          0, 68, 69,111,172,  0,  0, 70,112,173,
15671      &          0,  0,114,175,  0,  0,178,  0,  0,  0,
15672      &          0,  0,110,111,113,174,  0,  0,112,114,
15673      &        175,  0,  0,115,176,  0,  0,179,  0,  0,
15674      &          0,  0,  0,171,172,174,177,  0,  0,173,
15675      &        175,178,  0,  0,176,179,  0,  0,180,47*0/
15676
15677       L=0
15678       DO 2 I=1,6
15679          DO 1 J=1,6
15680             L = L+1
15681             IMPS(I,J) = IP(L)
15682             IMVE(I,J) = IV(L)
15683     1    CONTINUE
15684     2 CONTINUE
15685       L=0
15686       DO 4 I=1,6
15687          DO 3 J=1,21
15688             L = L+1
15689             IB08(I,J) = IB(L)
15690             IB10(I,J) = IBB(L)
15691             IA08(I,J) = IA(L)
15692             IA10(I,J) = IAA(L)
15693     3    CONTINUE
15694     4 CONTINUE
15695 C     A1  = 0.88D0
15696 C     B1  = 3.0D0
15697 C     B2  = 3.0D0
15698 C     B3  = 8.0D0
15699 C     LT  = 0
15700 C     LB  = 0
15701 C     BET = 12.0D0
15702 C     AS  = 0.25D0
15703 C     B8  = 0.33D0
15704 C     AME = 0.95D0
15705 C     DIQ = 0.375D0
15706 C     ISU = 4
15707
15708       RETURN
15709       END
15710
15711 *$ CREATE DT_INITJS.FOR
15712 *COPY DT_INITJS
15713 *
15714 *===initjs=============================================================*
15715 *
15716       SUBROUTINE DT_INITJS(MODE)
15717
15718 ************************************************************************
15719 * Initialize JETSET paramters.                                         *
15720 *           MODE = 0 default settings                                  *
15721 *                = 1 PHOJET settings                                   *
15722 *                = 2 DTUNUC settings                                   *
15723 * This version dated 16.02.96 is written by S. Roesler                 *
15724 *                                                                      *
15725 * Last change 27.12.2006 by S. Roesler.                                *
15726 ************************************************************************
15727
15728       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15729       SAVE
15730       PARAMETER ( LINP = 10 ,
15731      &            LOUT = 6 ,
15732      &            LDAT = 9 )
15733       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15734
15735       LOGICAL LFIRST,LFIRDT,LFIRPH
15736
15737       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15738       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15739       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15740 * flags for particle decays
15741       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
15742      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
15743      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
15744 * flags for input different options
15745       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15746       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15747      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15748
15749       INTEGER PYCOMP
15750
15751       DIMENSION IDXSTA(40)
15752       DATA IDXSTA
15753 *          K0s   pi0  lam   alam  sig+  asig+ sig-  asig- tet0  atet0
15754      &  /  310,  111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322,
15755 *          tet- atet-  om-  aom-   D+    D-    D0    aD0   Ds+   aDs+
15756      &    3312,-3312, 3334,-3334,  411, -411,  421, -421,  431, -431,
15757 *          etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+
15758      &     441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232,
15759 *         Ksic0 aKsic+aKsic0 sig0 asig0
15760      &    4132,-4232,-4132, 3212,-3212, 5*0/
15761
15762       DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
15763
15764       IF (LFIRST) THEN
15765 * save default settings
15766          PDEF1  = PARJ(1)
15767          PDEF2  = PARJ(2)
15768          PDEF3  = PARJ(3)
15769          PDEF5  = PARJ(5)
15770          PDEF6  = PARJ(6)
15771          PDEF7  = PARJ(7)
15772          PDEF18 = PARJ(18)
15773          PDEF19 = PARJ(19)
15774          PDEF21 = PARJ(21)
15775          PDEF42 = PARJ(42)
15776          MDEF12 = MSTJ(12)
15777 * LUJETS / PYJETS array-dimensions
15778          MSTU(4) = 4000
15779 * increase maximum number of JETSET-error prints
15780          MSTU(22) = 50000
15781 * prevent particles decaying
15782          DO 1 I=1,35
15783             IF (I.LT.34) THEN
15784                KC = PYCOMP(IDXSTA(I))
15785                IF (KC.GT.0) THEN
15786                   IF (I.EQ.2) THEN
15787 *  pi0 decay
15788 C                    MDCY(KC,1) = 1
15789                      MDCY(KC,1) = 0
15790 **cr mode
15791 C                 ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
15792 C   &                    (I.EQ.8).OR.(I.EQ.10)) THEN
15793 C                 ELSEIF (I.EQ.4) THEN
15794 C                    MDCY(KC,1) = 1
15795 **
15796                   ELSE
15797 C AM                     MDCY(KC,1) = 0
15798                   ENDIF
15799                ENDIF
15800             ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
15801                KC = PYCOMP(IDXSTA(I))
15802                IF (KC.GT.0) THEN
15803 C AM                 MDCY(KC,1) = 0
15804                ENDIF
15805             ENDIF
15806     1    CONTINUE
15807 *
15808 *
15809 * popcorn:
15810          IF (PDB.LE.ZERO) THEN
15811 *   no popcorn-mechanism
15812             MSTJ(12) = 1
15813          ELSE
15814             MSTJ(12) = 3
15815             PARJ(5)  = PDB
15816          ENDIF
15817 * set JETSET-parameter requested by input cards
15818          IF (NMSTU.GT.0) THEN
15819             DO 2 I=1,NMSTU
15820                MSTU(IMSTU(I)) = MSTUX(I)
15821     2       CONTINUE
15822          ENDIF
15823          IF (NMSTJ.GT.0) THEN
15824             DO 3 I=1,NMSTJ
15825                MSTJ(IMSTJ(I)) = MSTJX(I)
15826     3       CONTINUE
15827          ENDIF
15828          IF (NPARU.GT.0) THEN
15829             DO 4 I=1,NPARU
15830                PARU(IPARU(I)) = PARUX(I)
15831     4       CONTINUE
15832          ENDIF
15833          LFIRST = .FALSE.
15834       ENDIF
15835 *
15836 * PARJ(1)  suppression of qq-aqaq pair prod. compared to
15837 *          q-aq pair prod.                      (default: 0.1)
15838 * PARJ(2)  strangeness suppression               (default: 0.3)
15839 * PARJ(3)  extra suppression of strange diquarks (default: 0.4)
15840 * PARJ(6)  extra suppression of sas-pair shared by B and
15841 *          aB in BMaB                           (default: 0.5)
15842 * PARJ(7)  extra suppression of strange meson M in BMaB
15843 *          configuration                        (default: 0.5)
15844 * PARJ(18) spin 3/2 baryon suppression           (default: 1.0)
15845 * PARJ(21) width sigma in Gaussian p_x, p_y transverse
15846 *          momentum distrib. for prim. hadrons  (default: 0.35)
15847 * PARJ(42) b-parameter for symmetric Lund-fragmentation
15848 *          function                             (default: 0.9 GeV^-2)
15849 *
15850 * PHOJET settings
15851       IF (MODE.EQ.1) THEN
15852 *   JETSET default
15853 C        PARJ(1)  = PDEF1
15854 C        PARJ(2)  = PDEF2
15855 C        PARJ(3)  = PDEF3
15856 C        PARJ(6)  = PDEF6
15857 C        PARJ(7)  = PDEF7
15858 C        PARJ(18) = PDEF18
15859 C        PARJ(21) = PDEF21
15860 C        PARJ(42) = PDEF42
15861 **sr 18.11.98 parameter tuning
15862 C        PARJ(1)  = 0.092D0
15863 C        PARJ(2)  = 0.25D0
15864 C        PARJ(3)  = 0.45D0
15865 C        PARJ(19) = 0.3D0
15866 C        PARJ(21) = 0.45D0
15867 C        PARJ(42) = 1.0D0
15868 **sr 28.04.99 parameter tuning (May 99 minor modifications)
15869          PARJ(1)  = 0.085D0
15870          PARJ(2)  = 0.26D0
15871          PARJ(3)  = 0.8D0
15872          PARJ(11) = 0.38D0
15873          PARJ(18) = 0.3D0
15874          PARJ(19) = 0.4D0
15875          PARJ(21) = 0.36D0
15876          PARJ(41) = 0.3D0
15877          PARJ(42) = 0.86D0
15878          IF (NPARJ.GT.0) THEN
15879             DO 10 I=1,NPARJ
15880                IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
15881    10       CONTINUE
15882          ENDIF
15883          IF (LFIRPH) THEN
15884             WRITE(LOUT,'(1X,A)')
15885      &         'DT_INITJS: JETSET-parameter for PHOJET'
15886             CALL DT_JSPARA(0)
15887             LFIRPH = .FALSE.
15888          ENDIF
15889 * DTUNUC settings
15890       ELSEIF (MODE.EQ.2) THEN
15891          IF (IFRAG(2).EQ.1) THEN
15892 **sr parameters before 9.3.96
15893 C           PARJ(2)  = 0.27D0
15894 C           PARJ(3)  = 0.6D0
15895 C           PARJ(6)  = 0.75D0
15896 C           PARJ(7)  = 0.75D0
15897 C           PARJ(21) = 0.55D0
15898 C           PARJ(42) = 1.3D0
15899 **sr 18.11.98 parameter tuning
15900 C           PARJ(1)  = 0.05D0
15901 C           PARJ(2)  = 0.27D0
15902 C           PARJ(3)  = 0.4D0
15903 C           PARJ(19) = 0.2D0
15904 C           PARJ(21) = 0.45D0
15905 C           PARJ(42) = 1.0D0
15906 **sr 28.04.99 parameter tuning
15907             PARJ(1)  = 0.11D0
15908             PARJ(2)  = 0.36D0
15909             PARJ(3)  = 0.8D0
15910             PARJ(19) = 0.2D0
15911             PARJ(21) = 0.3D0
15912             PARJ(41) = 0.3D0
15913             PARJ(42) = 0.58D0
15914             IF (NPARJ.GT.0) THEN
15915                DO 20 I=1,NPARJ
15916                   IF (IPARJ(I).LT.0) THEN
15917                      IDX = ABS(IPARJ(I))
15918                      PARJ(IDX) = PARJX(I)
15919                   ENDIF
15920    20          CONTINUE
15921             ENDIF
15922             IF (LFIRDT) THEN
15923                WRITE(LOUT,'(1X,A)')
15924      &           'DT_INITJS: JETSET-parameter for DTUNUC'
15925                CALL DT_JSPARA(0)
15926                LFIRDT = .FALSE.
15927             ENDIF
15928          ELSEIF (IFRAG(2).EQ.2) THEN
15929             PARJ(1)  = 0.11D0
15930             PARJ(2)  = 0.27D0
15931             PARJ(3)  = 0.3D0
15932             PARJ(6)  = 0.35D0
15933             PARJ(7)  = 0.45D0
15934             PARJ(18) = 0.66D0
15935 C           PARJ(21) = 0.55D0
15936 C           PARJ(42) = 1.0D0
15937             PARJ(21) = 0.60D0
15938             PARJ(42) = 1.3D0
15939          ELSE
15940             PARJ(1)  = PDEF1
15941             PARJ(2)  = PDEF2
15942             PARJ(3)  = PDEF3
15943             PARJ(6)  = PDEF6
15944             PARJ(7)  = PDEF7
15945             PARJ(18) = PDEF18
15946             PARJ(21) = PDEF21
15947             PARJ(42) = PDEF42
15948          ENDIF
15949       ELSE
15950          PARJ(1)  = PDEF1
15951          PARJ(2)  = PDEF2
15952          PARJ(3)  = PDEF3
15953          PARJ(5)  = PDEF5
15954          PARJ(6)  = PDEF6
15955          PARJ(7)  = PDEF7
15956          PARJ(18) = PDEF18
15957          PARJ(19) = PDEF19
15958          PARJ(21) = PDEF21
15959          PARJ(42) = PDEF42
15960          MSTJ(12) = MDEF12
15961       ENDIF
15962
15963       RETURN
15964       END
15965
15966 *$ CREATE DT_JSPARA.FOR
15967 *COPY DT_JSPARA
15968 *
15969 *===jspara=============================================================*
15970 *
15971       SUBROUTINE DT_JSPARA(MODE)
15972
15973       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15974       SAVE
15975       PARAMETER ( LINP = 10 ,
15976      &            LOUT = 6 ,
15977      &            LDAT = 9 )
15978       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
15979      &           ONE=1.0D0,ZERO=0.0D0)
15980
15981       LOGICAL LFIRST
15982
15983       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15984
15985       DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
15986
15987       DATA LFIRST /.TRUE./
15988
15989 * save the default JETSET-parameter on the first call
15990       IF (LFIRST) THEN
15991          DO 1 I=1,200
15992             ISTU(I) = MSTU(I)
15993             QARU(I) = PARU(I)
15994             ISTJ(I) = MSTJ(I)
15995             QARJ(I) = PARJ(I)
15996     1    CONTINUE
15997          LFIRST = .FALSE.
15998       ENDIF
15999
16000       WRITE(LOUT,1000)
16001  1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
16002
16003 * compare the default JETSET-parameter with the present values
16004       DO 2 I=1,200
16005          IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
16006             WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
16007 C           ISTU(I) = MSTU(I)
16008          ENDIF
16009          DIFF = ABS(PARU(I)-QARU(I))
16010          IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
16011             WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
16012 C           QARU(I) = PARU(I)
16013          ENDIF
16014          IF (MSTJ(I).NE.ISTJ(I)) THEN
16015             WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
16016 C           ISTJ(I) = MSTJ(I)
16017          ENDIF
16018          DIFF = ABS(PARJ(I)-QARJ(I))
16019          IF (DIFF.GE.1.0D-5) THEN
16020             WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
16021 C           QARJ(I) = PARJ(I)
16022          ENDIF
16023     2 CONTINUE
16024  1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
16025  1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
16026
16027       RETURN
16028       END
16029
16030 *$ CREATE DT_FOZOCA.FOR
16031 *COPY DT_FOZOCA
16032 *
16033 *===fozoca=============================================================*
16034 *
16035       SUBROUTINE DT_FOZOCA(LFZC,IREJ)
16036
16037 ************************************************************************
16038 * This subroutine treats the complete FOrmation ZOne supressed intra-  *
16039 * nuclear CAscade.                                                     *
16040 *               LFZC = .true.  cascade has been treated                *
16041 *                    = .false. cascade skipped                         *
16042 * This is a completely revised version of the original FOZOKL.         *
16043 * This version dated 18.11.95 is written by S. Roesler                 *
16044 ************************************************************************
16045
16046       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16047       SAVE
16048       PARAMETER ( LINP = 10 ,
16049      &            LOUT = 6 ,
16050      &            LDAT = 9 )
16051       PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
16052       PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16053
16054       LOGICAL LSTART,LCAS,LFZC
16055
16056 * event history
16057       PARAMETER (NMXHKK=200000)
16058       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16059      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16060      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16061 * extended event history
16062       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16063      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16064      &                IHIST(2,NMXHKK)
16065 * rejection counter
16066       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
16067      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
16068      &                IREXCI(3),IRDIFF(2),IRINC
16069 * properties of interacting particles
16070       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
16071 * Glauber formalism: collision properties
16072       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16073      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
16074      &                NCP,NCT
16075 * flags for input different options
16076       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16077       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16078      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16079 * final state after intranuclear cascade step
16080       COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16081 * parameter for intranuclear cascade
16082       LOGICAL LPAULI
16083       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16084
16085       DIMENSION NCWOUN(2)
16086
16087       DATA LSTART /.TRUE./
16088
16089       LFZC = .TRUE.
16090       IREJ = 0
16091
16092 * skip cascade if hadron-hadron interaction or if supressed by user
16093       IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999
16094 * skip cascade if not all possible chains systems are hadronized
16095       DO 1 I=1,8
16096          IF (.NOT.LHADRO(I)) GOTO 9999
16097     1 CONTINUE
16098
16099       IF (LSTART) THEN
16100          WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD
16101  1000    FORMAT(/,1X,'FOZOCA:  intranuclear cascade treated for a ',
16102      &          'maximum of',I4,' generations',/,10X,'formation time ',
16103      &          'parameter:',F5.1,'  fm/c',9X,'modus:',I2)
16104          IF (ITAUVE.EQ.1) WRITE(LOUT,1001)
16105          IF (ITAUVE.EQ.2) WRITE(LOUT,1002)
16106  1001    FORMAT(10X,'p_t dependent formation zone',/)
16107  1002    FORMAT(10X,'constant formation zone',/)
16108          LSTART = .FALSE.
16109       ENDIF
16110
16111 * in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons
16112 * which may interact with final state particles are stored in a seperate
16113 * array - here all proj./target nucleon-indices (just for simplicity)
16114       NOINC = 0
16115       DO 9 I=1,NPOINT(1)-1
16116          NOINC = NOINC+1
16117          IDXINC(NOINC) = I
16118     9 CONTINUE
16119
16120 * initialize Pauli-principle treatment (find wounded nucleons)
16121       NWOUND(1) = 0
16122       NWOUND(2) = 0
16123       NCWOUN(1) = 0
16124       NCWOUN(2) = 0
16125       DO 2 J=1,NPOINT(1)
16126          DO 3 I=1,2
16127             IF (ISTHKK(J).EQ.10+I) THEN
16128                NWOUND(I) = NWOUND(I)+1
16129                EWOUND(I,NWOUND(I)) = PHKK(4,J)
16130                IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1
16131             ENDIF
16132     3    CONTINUE
16133     2 CONTINUE
16134
16135 * modify nuclear potential for wounded nucleons
16136       IPRCL  = IP -NWOUND(1)
16137       IPZRCL = IPZ-NCWOUN(1)
16138       ITRCL  = IT -NWOUND(2)
16139       ITZRCL = ITZ-NCWOUN(2)
16140       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
16141
16142       NSTART = NPOINT(4)
16143       NEND   = NHKK
16144
16145     7 CONTINUE
16146       DO 8 I=NSTART,NEND
16147
16148          IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
16149 * select nucleus the cascade starts first (proj. - 1, target - -1)
16150             NCAS   = 1
16151 *   projectile/target with probab. 1/2
16152             IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN
16153                IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16154 *   in the nucleus with highest mass
16155             ELSEIF (INCMOD.EQ.2) THEN
16156                IF (IP.GT.IT) THEN
16157                   NCAS = -NCAS
16158                ELSEIF (IP.EQ.IT) THEN
16159                   IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16160                ENDIF
16161 * the nucleus the cascade starts first is requested to be the one
16162 * moving in the direction of the secondary
16163             ELSEIF (INCMOD.EQ.3) THEN
16164                NCAS = INT(SIGN(1.0D0,PHKK(3,I)))
16165             ENDIF
16166 * check that the selected "nucleus" is not a hadron
16167             IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR.
16168      &          ((NCAS.EQ.-1).AND.(IT.LE.1)))    NCAS = -NCAS
16169
16170 * treat intranuclear cascade in the nucleus selected first
16171             LCAS = .FALSE.
16172             CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16173             IF (IREJ1.NE.0) GOTO 9998
16174 * treat intranuclear cascade in the other nucleus if this isn't a had.
16175             NCAS = -NCAS
16176             IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR.
16177      &          ((NCAS.EQ.-1).AND.(IT.GT.1)))    THEN
16178                IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16179                IF (IREJ1.NE.0) GOTO 9998
16180             ENDIF
16181
16182          ENDIF
16183
16184     8 CONTINUE
16185       NSTART = NEND+1
16186       NEND   = NHKK
16187       IF (NSTART.LE.NEND) GOTO 7
16188
16189       RETURN
16190
16191  9998 CONTINUE
16192 * reject this event
16193       IRINC = IRINC+1
16194       IREJ = 1
16195
16196  9999 CONTINUE
16197 * intranucl. cascade not treated because of interaction properties or
16198 * it is supressed by user or it was rejected or...
16199       LFZC = .FALSE.
16200 * reset flag characterizing direction of motion in n-n-cms
16201 **sr14-11-95
16202 C     DO 9990 I=NPOINT(5),NHKK
16203 C        IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
16204 C9990 CONTINUE
16205
16206       RETURN
16207       END
16208
16209 *$ CREATE DT_INUCAS.FOR
16210 *COPY DT_INUCAS
16211 *
16212 *===inucas=============================================================*
16213 *
16214       SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
16215
16216 ************************************************************************
16217 * Formation zone supressed IntraNUclear CAScade for one final state    *
16218 * particle.                                                            *
16219 *           IT, IP    mass numbers of target, projectile nuclei        *
16220 *           IDXCAS    index of final state particle in DTEVT1          *
16221 *           NCAS =  1 intranuclear cascade in projectile               *
16222 *                = -1 intranuclear cascade in target                   *
16223 * This version dated 18.11.95 is written by S. Roesler                 *
16224 ************************************************************************
16225
16226       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16227       SAVE
16228       PARAMETER ( LINP = 10 ,
16229      &            LOUT = 6 ,
16230      &            LDAT = 9 )
16231
16232       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
16233      &           OHALF=0.5D0,ONE=1.0D0)
16234       PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16235       PARAMETER (TWOPI=6.283185307179586454D+00)
16236       PARAMETER (PLOWH=0.01D0,PHIH=9.0D0)
16237
16238       LOGICAL LABSOR,LCAS
16239
16240 * event history
16241       PARAMETER (NMXHKK=200000)
16242       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16243      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16244      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16245 * extended event history
16246       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16247      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16248      &                IHIST(2,NMXHKK)
16249 * final state after inc step
16250       PARAMETER (MAXFSP=10)
16251       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
16252 * flags for input different options
16253       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16254       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16255      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16256 * particle properties (BAMJET index convention)
16257       CHARACTER*8  ANAME
16258       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
16259      &                IICH(210),IIBAR(210),K1(210),K2(210)
16260 * Glauber formalism: collision properties
16261       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16262      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
16263      &                NCP,NCT
16264 * nuclear potential
16265       LOGICAL LFERMI
16266       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
16267      &                EBINDP(2),EBINDN(2),EPOT(2,210),
16268      &                ETACOU(2),ICOUL,LFERMI
16269 * parameter for intranuclear cascade
16270       LOGICAL LPAULI
16271       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16272 * final state after intranuclear cascade step
16273       COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16274 * nucleon-nucleon event-generator
16275       CHARACTER*8 CMODEL
16276       LOGICAL LPHOIN
16277       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
16278 * statistics: residual nuclei
16279       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
16280      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
16281      &                NINCST(2,4),NINCEV(2),
16282      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
16283      &                NRESPB(2),NRESCH(2),NRESEV(4),
16284      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
16285      &                NEVAFI(2,2)
16286
16287       DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4),
16288      &          PCAS1(5),PNUC(5),BGTA(4),
16289      &          BGCAS(2),GACAS(2),BECAS(2),
16290      &          RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2)
16291
16292       DATA PDIF /0.545D0/
16293
16294       IREJ = 0
16295
16296 * update counter
16297       IF (NINCEV(1).NE.NEVHKK) THEN
16298          NINCEV(1) = NEVHKK
16299          NINCEV(2) = NINCEV(2)+1
16300       ENDIF
16301
16302 * "BAMJET-index" of this hadron
16303       IDCAS = IDBAM(IDXCAS)
16304       IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
16305
16306 * skip gammas, electrons, etc..
16307       IF (AAM(IDCAS).LT.TINY2) RETURN
16308
16309 * Lorentz-trsf. into projectile rest system
16310       IF (IP.GT.1) THEN
16311          CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16312      &               PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3),
16313      &               PCAS(1,4),IDCAS,-2)
16314          PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2)
16315          PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1))
16316          IF (PCAS(1,5).GT.ZERO) THEN
16317             PCAS(1,5) = SQRT(PCAS(1,5))
16318          ELSE
16319             PCAS(1,5) = AAM(IDCAS)
16320          ENDIF
16321          DO 20 K=1,3
16322             COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
16323    20    CONTINUE
16324 * Lorentz-parameters
16325 *   particle rest system --> projectile rest system
16326          BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10)
16327          GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10)
16328          BECAS(1) = BGCAS(1)/GACAS(1)
16329       ELSE
16330          DO 21 K=1,5
16331             PCAS(1,K) = ZERO
16332             IF (K.LE.3) COSCAS(1,K) = ZERO
16333    21    CONTINUE
16334          PTOCAS(1) = ZERO
16335          BGCAS(1)  = ZERO
16336          GACAS(1)  = ZERO
16337          BECAS(1)  = ZERO
16338       ENDIF
16339 * Lorentz-trsf. into target rest system
16340       IF (IT.GT.1) THEN
16341 * LEPTO: final state particles are already in target rest frame
16342 C        IF (MCGENE.EQ.3) THEN
16343 C           PCAS(2,1) = PHKK(1,IDXCAS)
16344 C           PCAS(2,2) = PHKK(2,IDXCAS)
16345 C           PCAS(2,3) = PHKK(3,IDXCAS)
16346 C           PCAS(2,4) = PHKK(4,IDXCAS)
16347 C        ELSE
16348             CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16349      &                  PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3),
16350      &                  PCAS(2,4),IDCAS,-3)
16351 C        ENDIF
16352          PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2)
16353          PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2))
16354          IF (PCAS(2,5).GT.ZERO) THEN
16355             PCAS(2,5) = SQRT(PCAS(2,5))
16356          ELSE
16357             PCAS(2,5) = AAM(IDCAS)
16358          ENDIF
16359          DO 22 K=1,3
16360             COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
16361    22    CONTINUE
16362 * Lorentz-parameters
16363 *   particle rest system --> target rest system
16364          BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10)
16365          GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10)
16366          BECAS(2) = BGCAS(2)/GACAS(2)
16367       ELSE
16368          DO 23 K=1,5
16369             PCAS(2,K) = ZERO
16370             IF (K.LE.3) COSCAS(2,K) = ZERO
16371    23    CONTINUE
16372          PTOCAS(2) = ZERO
16373          BGCAS(2)  = ZERO
16374          GACAS(2)  = ZERO
16375          BECAS(2)  = ZERO
16376       ENDIF
16377
16378 * radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
16379 * potential (see CONUCL)
16380       RNUC(1)  = (RPROJ+4.605D0*PDIF)*FM2MM
16381       RNUC(2)  = (RTARG+4.605D0*PDIF)*FM2MM
16382 * impact parameter (the projectile moving along z)
16383       BIMPC(1) = ZERO
16384       BIMPC(2) = BIMPAC*FM2MM
16385
16386 * get position of initial hadron in projectile/target rest-syst.
16387       DO 3 K=1,4
16388          VTXCAS(1,K) = WHKK(K,IDXCAS)
16389          VTXCAS(2,K) = VHKK(K,IDXCAS)
16390     3 CONTINUE
16391
16392       ICAS = 1
16393       I2   = 2
16394       IF (NCAS.EQ.-1) THEN
16395          ICAS = 2
16396          I2   = 1
16397       ENDIF
16398
16399       IF (PTOCAS(ICAS).LT.TINY10) THEN
16400          WRITE(LOUT,1000) PTOCAS
16401  1000    FORMAT(1X,'INUCAS:   warning! zero momentum of initial',
16402      &          '  hadron ',/,20X,2E12.4)
16403          GOTO 9999
16404       ENDIF
16405
16406 * reset spectator flags
16407       NSPE = 0
16408       IDXSPE(1) = 0
16409       IDXSPE(2) = 0
16410       IDSPE(1)  = 0
16411       IDSPE(2)  = 0
16412
16413 * formation length (in fm)
16414 C     IF (LCAS) THEN
16415 C        DEL0 = ZERO
16416 C     ELSE
16417          DEL0 = TAUFOR*BGCAS(ICAS)
16418          IF (ITAUVE.EQ.1) THEN
16419             AMT  = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2
16420             DEL0 = DEL0*PCAS(ICAS,5)**2/AMT
16421          ENDIF
16422 C     ENDIF
16423 *   sample from exp(-del/del0)
16424       DEL1   = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10))
16425 * save formation time
16426       TAUSA1 = DEL1/BGCAS(ICAS)
16427       REL1   = TAUSA1*BGCAS(I2)
16428
16429       DEL    = DEL1
16430       TAUSAM = DEL/BGCAS(ICAS)
16431       REL    = TAUSAM*BGCAS(I2)
16432
16433 * special treatment for negative particles unable to escape
16434 * nuclear potential (implemented for ap, pi-, K- only)
16435       LABSOR = .FALSE.
16436       IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN
16437 *   threshold energy = nuclear potential + Coulomb potential
16438 *   (nuclear potential for hadron-nucleus interactions only)
16439          ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS)
16440          IF (PCAS(ICAS,4).LT.ETHR) THEN
16441             DO 4 K=1,5
16442                PCAS1(K) = PCAS(ICAS,K)
16443     4       CONTINUE
16444 *   "absorb" negative particle in nucleus
16445             CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1)
16446             IF (IREJ1.NE.0) GOTO 9999
16447             IF (NSPE.GE.1) LABSOR = .TRUE.
16448          ENDIF
16449       ENDIF
16450
16451 * if the initial particle has not been absorbed proceed with
16452 * "normal" cascade
16453       IF (.NOT.LABSOR) THEN
16454
16455 *   calculate coordinates of hadron at the end of the formation zone
16456 *   transport-time and -step in the rest system where this step is
16457 *   treated
16458          DSTEP  = DEL*FM2MM
16459          DTIME  = DSTEP/BECAS(ICAS)
16460          RSTEP  = REL*FM2MM
16461          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16462             RTIME = RSTEP/BECAS(I2)
16463          ELSE
16464             RTIME = ZERO
16465          ENDIF
16466 *   save step whithout considering the overlapping region
16467          DSTEP1 = DEL1*FM2MM
16468          DTIME1 = DSTEP1/BECAS(ICAS)
16469          RSTEP1 = REL1*FM2MM
16470          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16471             RTIME1 = RSTEP1/BECAS(I2)
16472          ELSE
16473             RTIME1 = ZERO
16474          ENDIF
16475 *   transport to the end of the formation zone in this system
16476          DO 5 K=1,3
16477             VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K)
16478             VTXCA1(I2,K)   = VTXCAS(I2,K)  +RSTEP1*COSCAS(I2,K)
16479             VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K)
16480             VTXCAS(I2,K)   = VTXCAS(I2,K)  +RSTEP*COSCAS(I2,K)
16481     5    CONTINUE
16482          VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1
16483          VTXCA1(I2,4)   = VTXCAS(I2,4)  +RTIME1
16484          VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME
16485          VTXCAS(I2,4)   = VTXCAS(I2,4)  +RTIME
16486
16487          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16488             XCAS   = VTXCAS(ICAS,1)
16489             YCAS   = VTXCAS(ICAS,2)
16490             XNCLTA = BIMPAC*FM2MM
16491             RNCLPR = (RPROJ+RNUCLE)*FM2MM
16492             RNCLTA = (RTARG+RNUCLE)*FM2MM
16493 C           RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
16494 C           RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
16495 C           RNCLPR = (RPROJ)*FM2MM
16496 C           RNCLTA = (RTARG)*FM2MM
16497             RCASPR = SQRT( XCAS**2        +YCAS**2)
16498             RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2)
16499             IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN
16500                IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3
16501             ENDIF
16502          ENDIF
16503
16504 *   check if particle is already outside of the corresp. nucleus
16505          RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+
16506      &                VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2)
16507          IF (RDIST.GE.RNUC(ICAS)) THEN
16508 *   here: IDCH is the generation of the final state part. starting
16509 *   with zero for hadronization products
16510 *   flag particles of generation 0 being outside the nuclei after
16511 *   formation time (to be used for excitation energy calculation)
16512             IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3))
16513      &         NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS
16514             GOTO 9997
16515          ENDIF
16516          DIST   = DLARGE
16517          DISTP  = DLARGE
16518          DISTN  = DLARGE
16519          IDXP   = 0
16520          IDXN   = 0
16521
16522 *   already here: skip particles being outside HADRIN "energy-window"
16523 *   to avoid wasting of time
16524          NINCHR(ICAS,1) = NINCHR(ICAS,1)+1
16525          IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN
16526             NINCHR(ICAS,2) = NINCHR(ICAS,2)+1
16527 C           WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
16528 C1002       FORMAT(1X,'INUCAS:   warning! momentum of particle with ',
16529 C    &             'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
16530 C    &             E12.4,', above or below HADRIN-thresholds',I6)
16531             NSPE = 0
16532             GOTO 9997
16533          ENDIF
16534
16535          DO 7 IDXHKK=1,NOINC
16536             I = IDXINC(IDXHKK)
16537 *   scan DTEVT1 for unwounded or excited nucleons
16538             IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
16539                DO 8 K=1,3
16540                   IF (ICAS.EQ.1) THEN
16541                      VTXDST(K) = WHKK(K,I)-VTXCAS(1,K)
16542                   ELSEIF (ICAS.EQ.2) THEN
16543                      VTXDST(K) = VHKK(K,I)-VTXCAS(2,K)
16544                   ENDIF
16545     8          CONTINUE
16546                POSNUC = VTXDST(1)*COSCAS(ICAS,1)+
16547      &                  VTXDST(2)*COSCAS(ICAS,2)+
16548      &                  VTXDST(3)*COSCAS(ICAS,3)
16549 *   check if nucleon is situated in forward direction
16550                IF (POSNUC.GT.ZERO) THEN
16551 *   distance between hadron and this nucleon
16552                   DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16553      &                          VTXDST(3)**2)
16554 *   impact parameter
16555                   BIMNU2 = DISTNU**2-POSNUC**2
16556                   IF (BIMNU2.LT.ZERO) THEN
16557                      WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2
16558  1001                FORMAT(1X,'INUCAS:   warning! inconsistent impact',
16559      &                      '  parameter ',/,20X,3E12.4)
16560                      GOTO 7
16561                   ENDIF
16562                   BIMNU  = SQRT(BIMNU2)
16563 *   maximum impact parameter to have interaction
16564                   IDNUC  = IDT_ICIHAD(IDHKK(I))
16565                   IDNUC1 = IDT_MCHAD(IDNUC)
16566                   IDCAS1 = IDT_MCHAD(IDCAS)
16567                   DO 19 K=1,5
16568                      PCAS1(K) = PCAS(ICAS,K)
16569                      PNUC(K)  = PHKK(K,I)
16570    19             CONTINUE
16571 * Lorentz-parameter for trafo into rest-system of target
16572                   DO 18 K=1,4
16573                      BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
16574    18             CONTINUE
16575 * transformation of projectile into rest-system of target
16576                   CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
16577      &                        PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4),
16578      &                        PPTOT,PX,PY,PZ,PE)
16579 **
16580 C                 CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
16581 C                 CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
16582                   DUMZER = ZERO
16583                   CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL)
16584                   CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB)
16585                   IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND.
16586      &                (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0
16587                   SIGIN = SIGTOT-SIGEL-SIGAB
16588 C                 SIGTOT = SIGIN+SIGEL+SIGAB
16589 **
16590                   BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM
16591 *   check if interaction is possible
16592                   IF (BIMNU.LE.BIMMAX) THEN
16593 *   get nucleon with smallest distance and kind of interaction
16594 *   (elastic/inelastic)
16595                      IF (DISTNU.LT.DIST) THEN
16596                         DIST      = DISTNU
16597                         BINT      = BIMNU
16598                         IF (IDNUC.NE.IDSPE(1)) THEN
16599                            IDSPE(2)  = IDSPE(1)
16600                            IDXSPE(2) = IDXSPE(1)
16601                            IDSPE(1)  = IDNUC
16602                         ENDIF
16603                         IDXSPE(1) = I
16604                         NSPE      = 1
16605 **sr
16606                         SELA = SIGEL
16607                         SABS = SIGAB
16608                         STOT = SIGTOT
16609 C                       IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
16610 C                          SELA = SIGEL
16611 C                          STOT = SIGIN+SIGEL
16612 C                       ELSE
16613 C                          SELA = SIGEL+0.75D0*SIGIN
16614 C                          STOT = 0.25D0*SIGIN+SELA
16615 C                       ENDIF
16616 **
16617                      ENDIF
16618                   ENDIf
16619                ENDIF
16620                DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16621      &                       VTXDST(3)**2)
16622                IDNUC  = IDT_ICIHAD(IDHKK(I))
16623                IF (IDNUC.EQ.1) THEN
16624                   IF (DISTNU.LT.DISTP) THEN
16625                      DISTP = DISTNU
16626                      IDXP  = I
16627                      POSP  = POSNUC
16628                   ENDIF
16629                ELSEIF (IDNUC.EQ.8) THEN
16630                   IF (DISTNU.LT.DISTN) THEN
16631                      DISTN = DISTNU
16632                      IDXN  = I
16633                      POSN  = POSNUC
16634                   ENDIF
16635                ENDIF
16636             ENDIF
16637     7    CONTINUE
16638
16639 * there is no nucleon for a secondary interaction
16640          IF (NSPE.EQ.0) GOTO 9997
16641
16642 C        IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
16643 C    &      WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
16644          IF (IDXSPE(2).EQ.0) THEN
16645             IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
16646 C              DO 80 K=1,3
16647 C                 IF (ICAS.EQ.1) THEN
16648 C                    VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
16649 C                 ELSEIF (ICAS.EQ.2) THEN
16650 C                    VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
16651 C                 ENDIF
16652 C  80          CONTINUE
16653 C              DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16654 C    &                       VTXDST(3)**2)
16655 C              IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
16656                   IDXSPE(2) = IDXN
16657                   IDSPE(2)  = 8
16658 C              ELSE
16659 C                 STOT = STOT-SABS
16660 C                 SABS = ZERO
16661 C              ENDIF
16662             ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
16663 C              DO 81 K=1,3
16664 C                 IF (ICAS.EQ.1) THEN
16665 C                    VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
16666 C                 ELSEIF (ICAS.EQ.2) THEN
16667 C                    VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
16668 C                 ENDIF
16669 C  81          CONTINUE
16670 C              DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16671 C    &                       VTXDST(3)**2)
16672 C              IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
16673                   IDXSPE(2) = IDXP
16674                   IDSPE(2)  = 1
16675 C              ELSE
16676 C                 STOT = STOT-SABS
16677 C                 SABS = ZERO
16678 C              ENDIF
16679             ELSE
16680                STOT = STOT-SABS
16681                SABS = ZERO
16682             ENDIF
16683          ENDIF
16684          RR = DT_RNDM(DIST)
16685          IF (RR.LT.SELA/STOT) THEN
16686             IPROC = 2
16687          ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
16688             IPROC = 3
16689          ELSE
16690             IPROC = 1
16691          ENDIF
16692
16693          DO 9 K=1,5
16694             PCAS1(K) = PCAS(ICAS,K)
16695             PNUC(K)  = PHKK(K,IDXSPE(1))
16696     9    CONTINUE
16697          IF (IPROC.EQ.3) THEN
16698 * 2-nucleon absorption of pion
16699             NSPE = 2
16700             CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1)
16701             IF (IREJ1.NE.0) GOTO 9999
16702             IF (NSPE.GE.1) LABSOR = .TRUE.
16703          ELSE
16704 * sample secondary interaction
16705             IDNUC = IDBAM(IDXSPE(1))
16706             CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1)
16707             IF (IREJ1.EQ.1) GOTO 9999
16708             IF (IREJ1.GT.1) GOTO 9998
16709          ENDIF
16710       ENDIF
16711
16712 * update arrays to include Pauli-principle
16713       DO 10 I=1,NSPE
16714          IF (NWOUND(ICAS).LE.299) THEN
16715             NWOUND(ICAS) = NWOUND(ICAS)+1
16716             EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
16717          ENDIF
16718    10 CONTINUE
16719
16720 * dump initial hadron for energy-momentum conservation check
16721       IF (LEMCCK)
16722      &   CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
16723      &               PCAS(ICAS,4),1,IDUM,IDUM)
16724
16725 * dump final state particles into DTEVT1
16726
16727 *   check if Pauli-principle is fulfilled
16728       NPAULI = 0
16729       NWTMP(1) = NWOUND(1)
16730       NWTMP(2) = NWOUND(2)
16731       DO 111 I=1,NFSP
16732          NPAULI = 0
16733          J1 = 2
16734          IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16735      &       ((NCAS.EQ.-1).AND.(IP.LE.1)))    J1 = 1
16736          DO 117 J=1,J1
16737             IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
16738             IF (J.EQ.1) THEN
16739                IDX = ICAS
16740                PE  = PFSP(4,I)
16741             ELSE
16742                IDX  = I2
16743                MODE = 1
16744                IF (IDX.EQ.1) MODE = -1
16745                CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
16746             ENDIF
16747 * first check if cascade step is forbidden due to Pauli-principle
16748 * (in case of absorpion this step is forced)
16749             IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16750      &          (IDFSP(I).EQ.8))) THEN
16751 *   get nuclear potential barrier
16752                POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16753                IF (IDFSP(I).EQ.1) THEN
16754                   POTLOW = POT-EBINDP(IDX)
16755                ELSE
16756                   POTLOW = POT-EBINDN(IDX)
16757                ENDIF
16758 *   final state particle not able to escape nucleus
16759                IF (PE.LE.POTLOW) THEN
16760 *     check if there are wounded nucleons
16761                   IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16762      &                 EWOUND(IDX,NWOUND(IDX)))) THEN
16763                      NPAULI      = NPAULI+1
16764                      NWOUND(IDX) = NWOUND(IDX)-1
16765                   ELSE
16766 *     interaction prohibited by Pauli-principle
16767                      NWOUND(1) = NWTMP(1)
16768                      NWOUND(2) = NWTMP(2)
16769                      GOTO 9997
16770                   ENDIF
16771                ENDIF
16772             ENDIF
16773   117    CONTINUE
16774   111 CONTINUE
16775
16776       NPAULI = 0
16777       NWOUND(1) = NWTMP(1)
16778       NWOUND(2) = NWTMP(2)
16779
16780       DO 11 I=1,NFSP
16781
16782          IST = ISTHKK(IDXCAS)
16783
16784          NPAULI = 0
16785          J1 = 2
16786          IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16787      &       ((NCAS.EQ.-1).AND.(IP.LE.1)))    J1 = 1
16788          DO 17 J=1,J1
16789             IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
16790             IDX = ICAS
16791             PE  = PFSP(4,I)
16792             IF (J.EQ.2) THEN
16793                IDX = I2
16794                CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
16795             ENDIF
16796 * first check if cascade step is forbidden due to Pauli-principle
16797 * (in case of absorpion this step is forced)
16798             IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16799      &          (IDFSP(I).EQ.8))) THEN
16800 *   get nuclear potential barrier
16801                POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16802                IF (IDFSP(I).EQ.1) THEN
16803                   POTLOW = POT-EBINDP(IDX)
16804                ELSE
16805                   POTLOW = POT-EBINDN(IDX)
16806                ENDIF
16807 *   final state particle not able to escape nucleus
16808                IF (PE.LE.POTLOW) THEN
16809 *     check if there are wounded nucleons
16810                   IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16811      &                 EWOUND(IDX,NWOUND(IDX)))) THEN
16812                      NWOUND(IDX) = NWOUND(IDX)-1
16813                      NPAULI = NPAULI+1
16814                      IST    = 14+IDX
16815                   ELSE
16816 *     interaction prohibited by Pauli-principle
16817                      NWOUND(1) = NWTMP(1)
16818                      NWOUND(2) = NWTMP(2)
16819                      GOTO 9997
16820                   ENDIF
16821 **sr
16822 c               ELSEIF (PE.LE.POT) THEN
16823 cC              ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
16824 cC                 NWOUND(IDX) = NWOUND(IDX)-1
16825 c**
16826 c                  NPAULI = NPAULI+1
16827 c                  IST    = 14+IDX
16828                ENDIF
16829             ENDIF
16830    17    CONTINUE
16831
16832 * dump final state particles for energy-momentum conservation check
16833          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I),
16834      &                           -PFSP(4,I),2,IDUM,IDUM)
16835
16836          PX = PFSP(1,I)
16837          PY = PFSP(2,I)
16838          PZ = PFSP(3,I)
16839          PE = PFSP(4,I)
16840          IF (ABS(IST).EQ.1) THEN
16841 * transform particles back into n-n cms
16842 * LEPTO: leave final state particles in target rest frame
16843 C           IF (MCGENE.EQ.3) THEN
16844 C              PFSP(1,I) = PX
16845 C              PFSP(2,I) = PY
16846 C              PFSP(3,I) = PZ
16847 C              PFSP(4,I) = PE
16848 C           ELSE
16849                IMODE = ICAS+1
16850                CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16851      &                     PFSP(4,I),IDFSP(I),IMODE)
16852 C           ENDIF
16853          ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN
16854 * target cascade but fsp got stuck in proj. --> transform it into
16855 * proj. rest system
16856             CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16857      &                  PFSP(4,I),IDFSP(I),-1)
16858          ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN
16859 * proj. cascade but fsp got stuck in target --> transform it into
16860 * target rest system
16861             CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16862      &                  PFSP(4,I),IDFSP(I),1)
16863          ENDIF
16864
16865 * dump final state particles into DTEVT1
16866          IGEN = IDCH(IDXCAS)+1
16867          ID   = IDT_IPDGHA(IDFSP(I))
16868          IXR  = 0
16869          IF (LABSOR) IXR = 99
16870          CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I),
16871      &               PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN)
16872
16873 * update the counter for particles which got stuck inside the nucleus
16874          IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
16875             NOINC = NOINC+1
16876             IDXINC(NOINC) = NHKK
16877          ENDIF
16878          IF (LABSOR) THEN
16879 *   in case of absorption the spatial treatment is an approximate
16880 *   solution anyway (the positions of the nucleons which "absorb" the
16881 *   cascade particle are not taken into consideration) therefore the
16882 *   particles are produced at the position of the cascade particle
16883             DO 12 K=1,4
16884                WHKK(K,NHKK) = WHKK(K,IDXCAS)
16885                VHKK(K,NHKK) = VHKK(K,IDXCAS)
16886    12       CONTINUE
16887          ELSE
16888 *   DDISTL - distance the cascade particle moves to the intera. point
16889 *   (the position where impact-parameter = distance to the interacting
16890 *   nucleon), DIST - distance to the interacting nucleon at the time of
16891 *   formation of the cascade particle, BINT - impact-parameter of this
16892 *   cascade-interaction
16893             DDISTL = SQRT(DIST**2-BINT**2)
16894             DTIME  = DDISTL/BECAS(ICAS)
16895             DTIMEL = DDISTL/BGCAS(ICAS)
16896             RDISTL = DTIMEL*BGCAS(I2)
16897             IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16898                RTIME = RDISTL/BECAS(I2)
16899             ELSE
16900                RTIME = ZERO
16901             ENDIF
16902 *   RDISTL, RTIME are this step and time in the rest system of the other
16903 *   nucleus
16904             DO 13 K=1,3
16905                VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
16906                VTXCA1(I2,K)   = VTXCAS(I2,K)  +COSCAS(I2,K)  *RDISTL
16907    13       CONTINUE
16908             VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME
16909             VTXCA1(I2,4)   = VTXCAS(I2,4)  +RTIME
16910 *   position of particle production is half the impact-parameter to
16911 *   the interacting nucleon
16912             DO 14 K=1,3
16913                WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
16914                VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
16915    14       CONTINUE
16916 *   time of production of secondary = time of interaction
16917             WHKK(4,NHKK) = VTXCA1(1,4)
16918             VHKK(4,NHKK) = VTXCA1(2,4)
16919          ENDIF
16920
16921    11 CONTINUE
16922
16923 * modify status and position of cascade particle (the latter for
16924 * statistics reasons only)
16925       ISTHKK(IDXCAS) = 2
16926       IF (LABSOR) ISTHKK(IDXCAS) = 19
16927       IF (.NOT.LABSOR) THEN
16928          DO 15 K=1,4
16929             WHKK(K,IDXCAS) = VTXCA1(1,K)
16930             VHKK(K,IDXCAS) = VTXCA1(2,K)
16931    15    CONTINUE
16932       ENDIF
16933
16934       DO 16 I=1,NSPE
16935          IS = IDXSPE(I)
16936 * dump interacting nucleons for energy-momentum conservation check
16937          IF (LEMCCK)
16938      &      CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
16939      &                                                  2,IDUM,IDUM)
16940 * modify entry for interacting nucleons
16941          IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS
16942          IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2
16943          IF (I.GE.2) THEN
16944             JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
16945             JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
16946          ENDIF
16947    16 CONTINUE
16948
16949 * check energy-momentum conservation
16950       IF (LEMCCK) THEN
16951          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
16952          IF (IREJ1.NE.0) GOTO 9999
16953       ENDIF
16954
16955 * update counter
16956       IF (LABSOR) THEN
16957          NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
16958       ELSE
16959          IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
16960          IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
16961       ENDIF
16962
16963       RETURN
16964
16965  9997 CONTINUE
16966  9998 CONTINUE
16967 * transport-step but no cascade step due to configuration (i.e. there
16968 * is no nucleon for interaction etc.)
16969       IF (LCAS) THEN
16970          DO 100 K=1,4
16971 C           WHKK(K,IDXCAS) = VTXCAS(1,K)
16972 C           VHKK(K,IDXCAS) = VTXCAS(2,K)
16973             WHKK(K,IDXCAS) = VTXCA1(1,K)
16974             VHKK(K,IDXCAS) = VTXCA1(2,K)
16975   100    CONTINUE
16976       ENDIF
16977
16978 C9998 CONTINUE
16979 * no cascade-step because of configuration
16980 * (i.e. hadron outside nucleus etc.)
16981       LCAS = .TRUE.
16982       RETURN
16983
16984  9999 CONTINUE
16985 * rejection
16986       IREJ = 1
16987       RETURN
16988       END
16989
16990 *$ CREATE DT_ABSORP.FOR
16991 *COPY DT_ABSORP
16992 *
16993 *===absorp=============================================================*
16994 *
16995       SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
16996
16997 ************************************************************************
16998 * Two-nucleon absorption of antiprotons, pi-, and K-.                  *
16999 * Antiproton absorption is handled by HADRIN.                          *
17000 * The following channels for meson-absorption are considered:          *
17001 *          pi- + p + p ---> n + p                                      *
17002 *          pi- + p + n ---> n + n                                      *
17003 *          K-  + p + p ---> sigma+ + n / Lam + p / sigma0 + p          *
17004 *          K-  + p + n ---> sigma- + n / Lam + n / sigma0 + n          *
17005 *          K-  + p + p ---> sigma- + n                                 *
17006 *      IDCAS, PCAS   identity, momentum of particle to be absorbed     *
17007 *      NCAS =  1     intranuclear cascade in projectile                *
17008 *           = -1     intranuclear cascade in target                    *
17009 *      NSPE          number of spectator nucleons involved             *
17010 *      IDXSPE(2)     DTEVT1-indices of spectator nucleons involved     *
17011 * Revised version of the original STOPIK written by HJM and J. Ranft.  *
17012 * This version dated 24.02.95 is written by S. Roesler                 *
17013 ************************************************************************
17014
17015       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17016       SAVE
17017       PARAMETER ( LINP = 10 ,
17018      &            LOUT = 6 ,
17019      &            LDAT = 9 )
17020       PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0,
17021      &           ONETHI=0.3333D0,TWOTHI=0.6666D0)
17022
17023 * event history
17024       PARAMETER (NMXHKK=200000)
17025       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17026      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17027      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17028 * extended event history
17029       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17030      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17031      &                IHIST(2,NMXHKK)
17032 * flags for input different options
17033       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17034       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17035      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17036 * final state after inc step
17037       PARAMETER (MAXFSP=10)
17038       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17039 * particle properties (BAMJET index convention)
17040       CHARACTER*8  ANAME
17041       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17042      &                IICH(210),IIBAR(210),K1(210),K2(210)
17043
17044       DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5),
17045      &          PTOT3P(4),BG3P(4),
17046      &          ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2)
17047
17048       IREJ = 0
17049       NFSP = 0
17050
17051 * skip particles others than ap, pi-, K- for mode=0
17052       IF ((MODE.EQ.0).AND.
17053      &    (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN
17054 * skip particles others than pions for mode=1
17055 * (2-nucleon absorption in intranuclear cascade)
17056       IF ((MODE.EQ.1).AND.
17057      &    (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN
17058
17059       NUCAS = NCAS
17060       IF (NUCAS.EQ.-1) NUCAS = 2
17061
17062       IF (MODE.EQ.0) THEN
17063 * scan spectator nucleons for nucleons being able to "absorb"
17064          NSPE      = 0
17065          IDXSPE(1) = 0
17066          IDXSPE(2) = 0
17067          DO 1 I=1,NHKK
17068             IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
17069                NSPE         = NSPE+1
17070                IDXSPE(NSPE) = I
17071                IDSPE(NSPE)  = IDBAM(I)
17072                IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2
17073                IF (NSPE.EQ.2) THEN
17074                   IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND.
17075      &                                  (IDSPE(2).EQ.8)) THEN
17076 *    there is no pi-+n+n channel
17077                      NSPE = 1
17078                      GOTO 1
17079                   ELSE
17080                      GOTO 2
17081                   ENDIF
17082                ENDIF
17083             ENDIF
17084     1    CONTINUE
17085
17086     2    CONTINUE
17087       ENDIF
17088 * transform excited projectile nucleons (status=15) into proj. rest s.
17089       DO 3 I=1,NSPE
17090          DO 4 K=1,5
17091             PSPE(I,K) = PHKK(K,IDXSPE(I))
17092     4    CONTINUE
17093     3 CONTINUE
17094
17095 * antiproton absorption
17096       IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
17097          DO 5 K=1,5
17098             PSPE1(K) = PSPE(1,K)
17099     5    CONTINUE
17100          CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
17101          IF (IREJ1.NE.0) GOTO 9999
17102
17103 * meson absorption
17104       ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23)
17105      &                      .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN
17106          IF (IDCAS.EQ.14) THEN
17107 *   pi- absorption
17108             IDFSP(1) = 8
17109             IDFSP(2) = 8
17110             IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
17111          ELSEIF (IDCAS.EQ.13) THEN
17112 *   pi+ absorption
17113             IDFSP(1) = 1
17114             IDFSP(2) = 1
17115             IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
17116          ELSEIF (IDCAS.EQ.23) THEN
17117 *   pi0 absorption
17118             IDFSP(1) = IDSPE(1)
17119             IDFSP(2) = IDSPE(2)
17120          ELSEIF (IDCAS.EQ.16) THEN
17121 *   K- absorption
17122             R = DT_RNDM(PCAS)
17123             IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
17124                IF (R.LT.ONETHI) THEN
17125                   IDFSP(1) = 21
17126                   IDFSP(2) = 8
17127                ELSEIF (R.LT.TWOTHI) THEN
17128                   IDFSP(1) = 17
17129                   IDFSP(2) = 1
17130                ELSE
17131                   IDFSP(1) = 22
17132                   IDFSP(2) = 1
17133                ENDIF
17134             ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
17135                IDFSP(1) = 20
17136                IDFSP(2) = 8
17137             ELSE
17138                IF (R.LT.ONETHI) THEN
17139                   IDFSP(1) = 20
17140                   IDFSP(2) = 1
17141                ELSEIF (R.LT.TWOTHI) THEN
17142                   IDFSP(1) = 17
17143                   IDFSP(2) = 8
17144                ELSE
17145                   IDFSP(1) = 22
17146                   IDFSP(2) = 8
17147                ENDIF
17148             ENDIF
17149          ENDIF
17150 *   dump initial particles for energy-momentum cons. check
17151          IF (LEMCCK) THEN
17152             CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM)
17153             CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2,
17154      &                                                    IDUM,IDUM)
17155             CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
17156      &                                                    IDUM,IDUM)
17157          ENDIF
17158 *   get Lorentz-parameter of 3 particle initial state
17159          DO 6 K=1,4
17160             PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
17161     6    CONTINUE
17162          P3P  = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
17163          AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
17164          DO 7 K=1,4
17165             BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
17166     7    CONTINUE
17167 *   2-particle decay of the 3-particle compound system
17168          CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2),
17169      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
17170      &               AAM(IDFSP(1)),AAM(IDFSP(2)))
17171          DO 8 I=1,2
17172             SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I)))
17173             PX  = PCMF(I)*COFF(I)*SDF
17174             PY  = PCMF(I)*SIFF(I)*SDF
17175             PZ  = PCMF(I)*CODF(I)
17176             CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ,
17177      &                  ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17178      &                  PFSP(4,I))
17179             PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) )
17180 *   check consistency of kinematics
17181             IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN
17182                WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I)
17183  1001          FORMAT(1X,'ABSORP:   warning! inconsistent',
17184      &                ' tree-particle kinematics',/,20X,'id: ',I3,
17185      &                ' AAM = ',E10.4,' MFSP = ',E10.4)
17186             ENDIF
17187 *   dump final state particles for energy-momentum cons. check
17188             IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17189      &                              -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17190     8    CONTINUE
17191          NFSP = 2
17192          IF (LEMCCK) THEN
17193             CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1)
17194             IF (IREJ1.NE.0) THEN
17195                WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)),
17196      &                      AM3P
17197                GOTO 9999
17198             ENDIF
17199          ENDIF
17200       ELSE
17201          IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
17202  1000    FORMAT(1X,'ABSORP:   warning! absorption for particle ',I3,
17203      &          ' impossible',/,20X,'too few spectators (',I2,')')
17204          NSPE = 0
17205       ENDIF
17206
17207       RETURN
17208
17209  9999 CONTINUE
17210       IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
17211       IREJ = 1
17212       RETURN
17213       END
17214
17215 *$ CREATE DT_HADRIN.FOR
17216 *COPY DT_HADRIN
17217 *
17218 *===hadrin=============================================================*
17219 *
17220       SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
17221
17222 ************************************************************************
17223 * Interface to the HADRIN-routines for inelastic and elastic           *
17224 * scattering.                                                          *
17225 *      IDPR,PPR(5)   identity, momentum of projectile                  *
17226 *      IDTA,PTA(5)   identity, momentum of target                      *
17227 *      MODE  = 1     inelastic interaction                             *
17228 *            = 2     elastic   interaction                             *
17229 * Revised version of the original FHAD.                                *
17230 * This version dated 27.10.95 is written by S. Roesler                 *
17231 ************************************************************************
17232
17233       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17234       SAVE
17235       PARAMETER ( LINP = 10 ,
17236      &            LOUT = 6 ,
17237      &            LDAT = 9 )
17238       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,
17239      &           TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0)
17240
17241       LOGICAL LCORR,LMSSG
17242
17243 * flags for input different options
17244       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17245       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17246      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17247 * final state after inc step
17248       PARAMETER (MAXFSP=10)
17249       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17250 * particle properties (BAMJET index convention)
17251       CHARACTER*8  ANAME
17252       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17253      &                IICH(210),IIBAR(210),K1(210),K2(210)
17254 * output-common for DHADRI/ELHAIN
17255 * final state from HADRIN interaction
17256       PARAMETER (MAXFIN=10)
17257       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
17258      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
17259
17260       DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
17261      &          P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
17262
17263       DATA LMSSG /.TRUE./
17264
17265       IREJ  = 0
17266       NFSP  = 0
17267       KCORR = 0
17268       IMCORR(1) = 0
17269       IMCORR(2) = 0
17270       LCORR = .FALSE.
17271
17272 *   dump initial particles for energy-momentum cons. check
17273       IF (LEMCCK) THEN
17274          CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM)
17275          CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM)
17276       ENDIF
17277
17278       AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2
17279       AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2
17280       IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR.
17281      &    (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR.
17282      &    (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN
17283          IF (LMSSG.AND.(IOULEV(3).GT.0))
17284      &   WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2
17285  1000    FORMAT(1X,'HADRIN:   warning! inconsistent projectile/target',
17286      &          ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ',
17287      &          E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4)
17288          LMSSG = .FALSE.
17289          LCORR = .TRUE.
17290       ENDIF
17291
17292 * convert initial state particles into particles which can be
17293 * handled by HADRIN
17294       IDHPR = IDPR
17295       IDHTA = IDTA
17296       IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
17297          IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
17298          DO 1 K=1,4
17299             P1IN(K) = PPR(K)
17300             P2IN(K) = PTA(K)
17301     1    CONTINUE
17302          XM1 = AAM(IDHPR)
17303          XM2 = AAM(IDHTA)
17304          CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17305          IF (IREJ1.GT.0) THEN
17306             WRITE(LOUT,'(1X,A)') 'HADRIN:   inconsistent mass trsf.'
17307             GOTO 9999
17308          ENDIF
17309          DO 2 K=1,4
17310             PPR(K) = P1OUT(K)
17311             PTA(K) = P2OUT(K)
17312     2    CONTINUE
17313          PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2)
17314          PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2)
17315       ENDIF
17316
17317 * Lorentz-parameter for trafo into rest-system of target
17318       DO 3 K=1,4
17319          BGTA(K) = PTA(K)/PTA(5)
17320     3 CONTINUE
17321 * transformation of projectile into rest-system of target
17322       CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2),
17323      &            PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3),
17324      &            PPR1(4))
17325
17326 * direction cosines of projectile in target rest system
17327       CX = PPR1(1)/PPRTO1
17328       CY = PPR1(2)/PPRTO1
17329       CZ = PPR1(3)/PPRTO1
17330
17331 * sample inelastic interaction
17332       IF (MODE.EQ.1) THEN
17333          CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA)
17334          IF (IRH.EQ.1) GOTO 9998
17335 * sample elastic interaction
17336       ELSEIF (MODE.EQ.2) THEN
17337          CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1)
17338          IF (IREJ1.NE.0) THEN
17339             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN'
17340             GOTO 9999
17341          ENDIF
17342          IF (IRH.EQ.1) GOTO 9998
17343       ELSE
17344          WRITE(LOUT,1001) MODE,INTHAD
17345  1001    FORMAT(1X,'HADRIN:   warning! inconsistent interaction mode',
17346      &          I4,' (INTHAD =',I4,')')
17347          GOTO 9999
17348       ENDIF
17349
17350 * transform final state particles back into Lab.
17351       DO 4 I=1,IRH
17352          NFSP = NFSP+1
17353          PX   = CXRH(I)*PLRH(I)
17354          PY   = CYRH(I)*PLRH(I)
17355          PZ   = CZRH(I)*PLRH(I)
17356          CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3),
17357      &               PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP),
17358      &               PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP))
17359          IDFSP(NFSP) = ITRH(I)
17360          AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2-
17361      &                                            PFSP(3,NFSP)**2
17362          IF (AMFSP2.LT.-TINY3) THEN
17363             WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP),
17364      &                       PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2
17365  1002       FORMAT(1X,'HADRIN:   warning! final state particle (id = ',
17366      &             I2,') with negative mass^2',/,1X,5E12.4)
17367             GOTO 9999
17368          ELSE
17369             PFSP(5,NFSP) = SQRT(ABS(AMFSP2))
17370             IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN
17371                WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
17372      &                          PFSP(5,NFSP)
17373  1003          FORMAT(1X,'HADRIN:   warning! final state particle',
17374      &                ' (id = ',I2,') with inconsistent mass',/,1X,
17375      &                2E12.4)
17376                KCORR         = KCORR+1
17377                IF (KCORR.GT.2) GOTO 9999
17378                IMCORR(KCORR) = NFSP
17379             ENDIF
17380          ENDIF
17381 *   dump final state particles for energy-momentum cons. check
17382          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17383      &                           -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17384     4 CONTINUE
17385
17386 * transform momenta on mass shell in case of inconsistencies in
17387 * HADRIN
17388       IF (KCORR.GT.0) THEN
17389          IF (KCORR.EQ.2) THEN
17390             I1 = IMCORR(1)
17391             I2 = IMCORR(2)
17392          ELSE
17393             IF (IMCORR(1).EQ.1) THEN
17394                I1 = 1
17395                I2 = 2
17396             ELSE
17397                I1 = 1
17398                I2 = IMCORR(1)
17399             ENDIF
17400          ENDIF
17401          IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1),
17402      &                           PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM)
17403          IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2),
17404      &                           PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM)
17405          DO 5 K=1,4
17406             P1IN(K) = PFSP(K,I1)
17407             P2IN(K) = PFSP(K,I2)
17408     5    CONTINUE
17409          XM1 = AAM(IDFSP(I1))
17410          XM2 = AAM(IDFSP(I2))
17411          CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17412          IF (IREJ1.GT.0) THEN
17413             WRITE(LOUT,'(1X,A)') 'HADRIN:   inconsistent mass trsf.'
17414 C           GOTO 9999
17415          ENDIF
17416          DO 6 K=1,4
17417             PFSP(K,I1) = P1OUT(K)
17418             PFSP(K,I2) = P2OUT(K)
17419     6    CONTINUE
17420          PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2
17421      &                    -PFSP(2,I1)**2-PFSP(3,I1)**2)
17422          PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2
17423      &                    -PFSP(2,I2)**2-PFSP(3,I2)**2)
17424 *   dump final state particles for energy-momentum cons. check
17425          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1),
17426      &                           -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM)
17427          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2),
17428      &                           -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM)
17429       ENDIF
17430
17431 * check energy-momentum conservation
17432       IF (LEMCCK) THEN
17433          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
17434          IF (IREJ1.NE.0) GOTO 9999
17435       ENDIF
17436
17437       RETURN
17438
17439  9998 CONTINUE
17440       IREJ = 2
17441       RETURN
17442
17443  9999 CONTINUE
17444       IREJ = 1
17445       RETURN
17446       END
17447
17448 *$ CREATE DT_HADCOL.FOR
17449 *COPY DT_HADCOL
17450 *
17451 *===hadcol=============================================================*
17452 *
17453       SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
17454
17455 ************************************************************************
17456 * Interface to the HADRIN-routines for inelastic and elastic           *
17457 * scattering. This subroutine samples hadron-nucleus interactions      *
17458 * below DPM-threshold.                                                 *
17459 *      IDPROJ        BAMJET-index of projectile hadron                 *
17460 *      PPN           projectile momentum in target rest frame          *
17461 *      IDXTAR        DTEVT1-index of target nucleon undergoing         *
17462 *                    interaction with projectile hadron                *
17463 * This subroutine replaces HADHAD.                                     *
17464 * This version dated 5.5.95 is written by S. Roesler                   *
17465 ************************************************************************
17466
17467       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17468       SAVE
17469       PARAMETER ( LINP = 10 ,
17470      &            LOUT = 6 ,
17471      &            LDAT = 9 )
17472       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0)
17473
17474       LOGICAL LSTART
17475
17476 * event history
17477       PARAMETER (NMXHKK=200000)
17478       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17479      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17480      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17481 * extended event history
17482       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17483      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17484      &                IHIST(2,NMXHKK)
17485 * nuclear potential
17486       LOGICAL LFERMI
17487       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17488      &                EBINDP(2),EBINDN(2),EPOT(2,210),
17489      &                ETACOU(2),ICOUL,LFERMI
17490 * interface HADRIN-DPM
17491       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
17492 * parameter for intranuclear cascade
17493       LOGICAL LPAULI
17494       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
17495 * final state after inc step
17496       PARAMETER (MAXFSP=10)
17497       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17498 * particle properties (BAMJET index convention)
17499       CHARACTER*8  ANAME
17500       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17501      &                IICH(210),IIBAR(210),K1(210),K2(210)
17502
17503       DIMENSION PPROJ(5),PNUC(5)
17504
17505       DATA LSTART /.TRUE./
17506
17507       IREJ   = 0
17508
17509       NPOINT(1) = NHKK+1
17510
17511       TAUSAV = TAUFOR
17512 **sr 6/9/01 commented
17513 C     TAUFOR = TAUFOR/2.0D0
17514 **
17515       IF (LSTART) THEN
17516          WRITE(LOUT,1000)
17517  1000    FORMAT(/,1X,'HADCOL:  Scattering handled by HADRIN')
17518          WRITE(LOUT,1001) TAUFOR
17519  1001    FORMAT(/,1X,'HADCOL:  Formation zone parameter set to ',
17520      &          F5.1,' fm/c')
17521          LSTART = .FALSE.
17522       ENDIF
17523
17524       IDNUC  = IDBAM(IDXTAR)
17525       IDNUC1 = IDT_MCHAD(IDNUC)
17526       IDPRO1 = IDT_MCHAD(IDPROJ)
17527
17528       IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
17529          IPROC = INTHAD
17530       ELSE
17531 **
17532 C        CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
17533 C        CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
17534          DUMZER = ZERO
17535          CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
17536          SIGIN = SIGTOT-SIGEL
17537 C        SIGTOT = SIGIN+SIGEL
17538 **
17539          IPROC  = 1
17540          IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
17541       ENDIF
17542
17543       PPROJ(1) = ZERO
17544       PPROJ(2) = ZERO
17545       PPROJ(3) = PPN
17546       PPROJ(5) = AAM(IDPROJ)
17547       PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
17548       DO 1 K=1,5
17549          PNUC(K)  = PHKK(K,IDXTAR)
17550     1 CONTINUE
17551
17552       ILOOP = 0
17553     2 CONTINUE
17554       ILOOP = ILOOP+1
17555       IF (ILOOP.GT.100) GOTO 9999
17556
17557       CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
17558       IF (IREJ1.EQ.1) GOTO 9999
17559
17560       IF (IREJ1.GT.1) THEN
17561 * no interaction possible
17562 *   require Pauli blocking
17563          IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2
17564          IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2
17565          IF ((IIBAR(IDPROJ).NE.1).AND.
17566      &       (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5)))              GOTO 2
17567 *   store incoming particle as final state particle
17568          CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3)
17569          CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0)
17570          NPOINT(4) = NHKK
17571       ELSE
17572 * require Pauli blocking for final state nucleons
17573          DO 4 I=1,NFSP
17574             IF ((IDFSP(I).EQ.1).AND.
17575      &          (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I))))       GOTO 2
17576             IF ((IDFSP(I).EQ.8).AND.
17577      &          (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I))))       GOTO 2
17578             IF ((IIBAR(IDFSP(I)).NE.1).AND.
17579      &          (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2
17580     4    CONTINUE
17581 * store final state particles
17582          DO 5 I=1,NFSP
17583             IST = 1
17584             IF ((IIBAR(IDFSP(I)).EQ.1).AND.
17585      &          (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16
17586             IDHAD = IDT_IPDGHA(IDFSP(I))
17587             CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3)
17588             CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I),
17589      &                                        PCMS,ECMS,0,0,0)
17590             IF (I.EQ.1) NPOINT(4) = NHKK
17591             VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR))
17592             VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR))
17593             VHKK(3,NHKK) = VHKK(3,IDXTAR)
17594             VHKK(4,NHKK) = VHKK(4,IDXTAR)
17595             WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR))
17596             WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR))
17597             WHKK(3,NHKK) = WHKK(3,1)
17598             WHKK(4,NHKK) = WHKK(4,1)
17599     5    CONTINUE
17600       ENDIF
17601       TAUFOR = TAUSAV
17602       RETURN
17603
17604  9999 CONTINUE
17605       IREJ = 1
17606       TAUFOR = TAUSAV
17607       RETURN
17608       END
17609
17610 *$ CREATE DT_GETEMU.FOR
17611 *COPY DT_GETEMU
17612 *
17613 *===getemu=============================================================*
17614 *
17615       SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
17616
17617 ************************************************************************
17618 * Sampling of emulsion component to be considered as target-nucleus.   *
17619 * This version dated 6.5.95   is written by S. Roesler.                *
17620 ************************************************************************
17621
17622       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17623       SAVE
17624       PARAMETER ( LINP = 10 ,
17625      &            LOUT = 6 ,
17626      &            LDAT = 9 )
17627       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
17628
17629       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
17630 * emulsion treatment
17631       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
17632      &                NCOMPO,IEMUL
17633 * Glauber formalism: flags and parameters for statistics
17634       LOGICAL LPROD
17635       CHARACTER*8 CGLB
17636       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
17637
17638       IF (MODE.EQ.0) THEN
17639          SUMFRA = ZERO
17640          RR = DT_RNDM(SUMFRA)
17641          IT  = 0
17642          ITZ = 0
17643          DO 1 ICOMP=1,NCOMPO
17644             SUMFRA = SUMFRA+EMUFRA(ICOMP)
17645             IF (SUMFRA.GT.RR) THEN
17646                IT    = IEMUMA(ICOMP)
17647                ITZ   = IEMUCH(ICOMP)
17648                KKMAT = ICOMP
17649                GOTO 2
17650             ENDIF
17651     1    CONTINUE
17652     2    CONTINUE
17653          IF (IT.LE.0) THEN
17654             WRITE(LOUT,'(1X,A,E12.3)')
17655      &       'Warning!  norm. failure within emulsion fractions',
17656      &       SUMFRA
17657             STOP
17658          ENDIF
17659       ELSEIF (MODE.EQ.1) THEN
17660          NDIFF = 10000
17661          DO 3 I=1,NCOMPO
17662             IDIFF = ABS(IT-IEMUMA(I))
17663             IF (IDIFF.LT.NDIFF) THEN
17664                KKMAT = I
17665                NDIFF = IDIFF
17666             ENDIF
17667     3    CONTINUE
17668       ELSE
17669          STOP 'DT_GETEMU'
17670       ENDIF
17671
17672 * bypass for variable projectile/target/energy runs: the correct
17673 * Glauber data will be always loaded on kkmat=1
17674       IF (IOGLB.EQ.100) THEN
17675          KKMAT = 1
17676       ENDIF
17677
17678       RETURN
17679       END
17680
17681 *$ CREATE DT_NCLPOT.FOR
17682 *COPY DT_NCLPOT
17683 *
17684 *===nclpot=============================================================*
17685 *
17686       SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
17687
17688 ************************************************************************
17689 * Calculation of Coulomb and nuclear potential for a given configurat. *
17690 *               IPZ, IP       charge/mass number of proj.              *
17691 *               ITZ, IT       charge/mass number of targ.              *
17692 *               AFERP,AFERT   factors modifying proj./target pot.      *
17693 *                             if =0, FERMOD is used                    *
17694 *               MODE = 0      calculation of binding energy            *
17695 *                    = 1      pre-calculated binding energy is used    *
17696 * This version dated 16.11.95  is written by S. Roesler.               *
17697 *                                                                      *
17698 * Last change 28.12.2006 by S. Roesler.                                *
17699 ************************************************************************
17700
17701       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17702       SAVE
17703       PARAMETER ( LINP = 10 ,
17704      &            LOUT = 6 ,
17705      &            LDAT = 9 )
17706       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
17707      &           TINY10=1.0D-10)
17708
17709       LOGICAL LSTART
17710
17711 * particle properties (BAMJET index convention)
17712       CHARACTER*8  ANAME
17713       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17714      &                IICH(210),IIBAR(210),K1(210),K2(210)
17715 * nuclear potential
17716       LOGICAL LFERMI
17717       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17718      &                EBINDP(2),EBINDN(2),EPOT(2,210),
17719      &                ETACOU(2),ICOUL,LFERMI
17720
17721       DIMENSION IDXPOT(14)
17722 *                   ap   an  lam  alam sig- sig+ sig0 tet0 tet- asig-
17723       DATA IDXPOT /   2,   9,  17,  18,  20,  21,  22,  97,  98,  99,
17724 *                 asig0 asig+ atet0 atet+
17725      &              100, 101, 102, 103/
17726
17727       DATA AN     /0.4D0/
17728       DATA LSTART /.TRUE./
17729
17730       IF (MODE.EQ.0) THEN
17731          EBINDP(1) = ZERO
17732          EBINDN(1) = ZERO
17733          EBINDP(2) = ZERO
17734          EBINDN(2) = ZERO
17735       ENDIF
17736       AIP  = DBLE(IP)
17737       AIPZ = DBLE(IPZ)
17738       AIT  = DBLE(IT)
17739       AITZ = DBLE(ITZ)
17740
17741       FERMIP = AFERP
17742       IF (AFERP.LE.ZERO) FERMIP = FERMOD
17743       FERMIT = AFERT
17744       IF (AFERT.LE.ZERO) FERMIT = FERMOD
17745
17746 * Fermi momenta and binding energy for projectile
17747       IF ((IP.GT.1).AND.LFERMI) THEN
17748          IF (MODE.EQ.0) THEN
17749 C           EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
17750 C           EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
17751             BIP  = AIP -ONE
17752             BIPZ = AIPZ-ONE
17753             EBINDP(1) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIP,BIPZ)
17754      &                                            -DT_ENERGY(AIP,AIPZ))
17755             IF (AIP.LE.AIPZ) THEN
17756                EBINDN(1) = EBINDP(1)
17757                WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
17758             ELSE
17759                EBINDN(1) = 1.0D-3*(DT_ENERGY(ONE,ZERO)
17760      &                     +DT_ENERGY(BIP,AIPZ)-DT_ENERGY(AIP,AIPZ))
17761             ENDIF
17762          ENDIF
17763          PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
17764          PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
17765       ELSE
17766          PFERMP(1) = ZERO
17767          PFERMN(1) = ZERO
17768       ENDIF
17769 * effective nuclear potential for projectile
17770 C     EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
17771 C     EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
17772       EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1)
17773       EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1)
17774
17775 * Fermi momenta and binding energy for target
17776       IF ((IT.GT.1).AND.LFERMI) THEN
17777          IF (MODE.EQ.0) THEN
17778 C           EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
17779 C           EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
17780             BIT  = AIT -ONE
17781             BITZ = AITZ-ONE
17782
17783             EBINDP(2) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIT,BITZ)
17784      &                                            -DT_ENERGY(AIT,AITZ))
17785
17786             IF (AIT.LE.AITZ) THEN
17787                EBINDN(2) = EBINDP(2)
17788                WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
17789             ELSE
17790
17791                EBINDN(2) = 1.0D-3*(DT_ENERGY(ONE,ZERO)
17792      &                     +DT_ENERGY(BIT,AITZ)-DT_ENERGY(AIT,AITZ))
17793
17794             ENDIF
17795          ENDIF
17796          PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
17797          PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
17798       ELSE
17799          PFERMP(2) = ZERO
17800          PFERMN(2) = ZERO
17801       ENDIF
17802 * effective nuclear potential for target
17803 C     EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
17804 C     EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
17805       EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2)
17806       EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2)
17807
17808       DO 2 I=1,14
17809          EPOT(1,IDXPOT(I)) = EPOT(1,8)
17810          EPOT(2,IDXPOT(I)) = EPOT(2,8)
17811     2 CONTINUE
17812
17813 * Coulomb energy
17814       ETACOU(1) = ZERO
17815       ETACOU(2) = ZERO
17816       IF (ICOUL.EQ.1) THEN
17817          IF (IP.GT.1)
17818      &   ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
17819          IF (IT.GT.1)
17820      &   ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
17821       ENDIF
17822
17823       IF (LSTART) THEN
17824          WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN,
17825      &                    EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2),
17826      &                    EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2),
17827      &                    FERMOD,ETACOU
17828  1000    FORMAT(/,/,1X,'NCLPOT:    quantities for inclusion of nuclear'
17829      &           ,' effects',/,12X,'---------------------------',
17830      &           '----------------',/,/,38X,'projectile',
17831      &           '      target',/,/,1X,'Mass number / charge',
17832      &           17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy  -',
17833      &           ' proton   (GeV) ',2E14.4,/,17X,'- neutron  (GeV)'
17834      &          ,1X,2E14.4,/,1X,'Fermi-potential - proton   (GeV)',
17835      &           1X,2E14.4,/,17X,'- neutron  (GeV) ',2E14.4,/,/,
17836      &           1X,'Scale factor for Fermi-momentum    ',F4.2,/,
17837      &           /,1X,'Coulomb-energy ',2(E14.4,' GeV  '),/,/)
17838          LSTART = .FALSE.
17839       ENDIF
17840
17841       RETURN
17842       END
17843
17844 *$ CREATE DT_RESNCL.FOR
17845 *COPY DT_RESNCL
17846 *
17847 *===resncl=============================================================*
17848 *
17849       SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
17850
17851 ************************************************************************
17852 * Treatment of residual nuclei and nuclear effects.                    *
17853 *         MODE = 1     initializations                                 *
17854 *              = 2     treatment of final state                        *
17855 * This version dated 16.11.95 is written by S. Roesler.                *
17856 *                                                                      *
17857 * Last change 05.01.2007 by S. Roesler.                                *
17858 ************************************************************************
17859
17860       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17861       SAVE
17862       PARAMETER ( LINP = 10 ,
17863      &            LOUT = 6 ,
17864      &            LDAT = 9 )
17865       PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
17866      &           TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10,
17867      &           ONETHI=ONE/THREE)
17868       PARAMETER (AMUAMU = 0.93149432D0,
17869      &           FM2MM  = 1.0D-12,
17870      &           RNUCLE = 1.12D0)
17871       PARAMETER ( EMVGEV = 1.0                D-03 )
17872       PARAMETER ( AMUGEV = 0.93149432         D+00 )
17873       PARAMETER ( AMPRTN = 0.93827231         D+00 )
17874       PARAMETER ( AMNTRN = 0.93956563         D+00 )
17875       PARAMETER ( AMELCT = 0.51099906         D-03 )
17876       PARAMETER ( HLFHLF = 0.5D+00 )
17877       PARAMETER ( FERTHO = 14.33       D-09 )
17878       PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
17879       PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
17880       PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
17881
17882 * event history
17883       PARAMETER (NMXHKK=200000)
17884       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17885      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17886      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17887 * extended event history
17888       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17889      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17890      &                IHIST(2,NMXHKK)
17891 * particle properties (BAMJET index convention)
17892       CHARACTER*8  ANAME
17893       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17894      &                IICH(210),IIBAR(210),K1(210),K2(210)
17895 * flags for input different options
17896       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17897       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17898      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17899 * nuclear potential
17900       LOGICAL LFERMI
17901       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17902      &                EBINDP(2),EBINDN(2),EPOT(2,210),
17903      &                ETACOU(2),ICOUL,LFERMI
17904 * properties of interacting particles
17905       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
17906 * properties of photon/lepton projectiles
17907       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
17908 * Lorentz-parameters of the current interaction
17909       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
17910      &                UMO,PPCM,EPROJ,PPROJ
17911 * treatment of residual nuclei: wounded nucleons
17912       COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
17913 * treatment of residual nuclei: 4-momenta
17914       LOGICAL LRCLPR,LRCLTA
17915       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
17916      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
17917
17918       DIMENSION PFSP(4),PSEC(4),PSEC0(4)
17919       DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
17920      &          IDXCOR(15000),IDXOTH(NMXHKK)
17921
17922       GOTO (1,2) MODE
17923
17924 *------- initializations
17925     1 CONTINUE
17926
17927 * initialize arrays for residual nuclei
17928       DO 10 K=1,5
17929          IF (K.LE.4) THEN
17930             PFSP(K)     = ZERO
17931          ENDIF
17932          PINIPR(K) = ZERO
17933          PINITA(K) = ZERO
17934          PRCLPR(K) = ZERO
17935          PRCLTA(K) = ZERO
17936          TRCLPR(K) = ZERO
17937          TRCLTA(K) = ZERO
17938    10 CONTINUE
17939       SCPOT = ONE
17940       NLOOP = 0
17941
17942 * correction of projectile 4-momentum for effective target pot.
17943 * and Coulomb-energy (in case of hadron-nucleus interaction only)
17944 *      IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
17945 *         EPNI = EPN
17946 *   Coulomb-energy:
17947 *     positively charged hadron - check energy for Coloumb pot.
17948 *         IF (IICH(IJPROJ).EQ.1) THEN
17949 *            THRESH = ETACOU(2)+AAM(IJPROJ)
17950 *            IF (EPNI.LE.THRESH) THEN
17951 *               WRITE(LOUT,1000)
17952 * 1000          FORMAT(/,1X,'KKINC:  WARNING!  projectile energy',
17953 *     &                ' below Coulomb threshold - event rejected',/)
17954 *               ISTHKK(1) = 1
17955 *               RETURN
17956 *            ENDIF
17957 *     negatively charged hadron - increase energy by Coulomb energy
17958 *         ELSEIF (IICH(IJPROJ).EQ.-1) THEN
17959 *            EPNI = EPNI+ETACOU(2)
17960 *         ENDIF
17961 *         IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN
17962 *   Effective target potential
17963 *sr 6.6. binding energy only (to avoid negative exc. energies)
17964 C           EPNI = EPNI+EPOT(2,IJPROJ)
17965 *            EBIPOT = EBINDP(2)
17966 *            IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3))
17967 *     &         EBIPOT = EBINDN(2)
17968 *            EPNI = EPNI+ABS(EBIPOT)
17969 * re-initialization of DTLTRA
17970 *            DUM1 = ZERO
17971 *            DUM2 = ZERO
17972 *
17973 *            CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
17974 *         ENDIF
17975 *      ENDIF
17976
17977 * projectile in n-n cms
17978       IF ((IP.LE.1).AND.(IT.GT.1)) THEN
17979          PMASS1 = AAM(IJPROJ)
17980 C* VDM assumption
17981 C         IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
17982          IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
17983          PMASS2 = AAM(1)
17984          PM1 = SIGN(PMASS1**2,PMASS1)
17985          PM2 = SIGN(PMASS2**2,PMASS2)
17986          PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
17987          PINIPR(5) = PMASS1
17988          IF (PMASS1.GT.ZERO) THEN
17989             PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
17990      &                      *(PINIPR(4)+PINIPR(5)))
17991          ELSE
17992             PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
17993          ENDIF
17994          AIT  = DBLE(IT)
17995          AITZ = DBLE(ITZ)
17996          PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ)
17997          CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
17998       ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
17999          PMASS1 = AAM(1)
18000          PMASS2 = AAM(IJTARG)
18001          PM1 = SIGN(PMASS1**2,PMASS1)
18002          PM2 = SIGN(PMASS2**2,PMASS2)
18003          PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO)
18004          PINITA(5) = PMASS2
18005          PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
18006      &                    *(PINITA(4)+PINITA(5)))
18007          AIP  = DBLE(IP)
18008          AIPZ = DBLE(IPZ)
18009          PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ)
18010          CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18011       ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
18012          AIP  = DBLE(IP)
18013          AIPZ = DBLE(IPZ)
18014          PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ)
18015          CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18016          AIT  = DBLE(IT)
18017          AITZ = DBLE(ITZ)
18018          PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ)
18019          CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18020       ENDIF
18021
18022       RETURN
18023
18024 *------- treatment of final state
18025     2 CONTINUE
18026
18027       NLOOP = NLOOP+1
18028       IF (NLOOP.GT.1) SCPOT = 0.10D0
18029 C     WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
18030
18031       JPW  = NPW
18032       JPCW = NPCW
18033       JTW  = NTW
18034       JTCW = NTCW
18035       DO 40 K=1,4
18036          PFSP(K)   = ZERO
18037    40 CONTINUE
18038
18039       NOB = 0
18040       NOM = 0
18041       DO 900 I=NPOINT(4),NHKK
18042          IDXOTH(I) = -1
18043          IF (ISTHKK(I).EQ.1) THEN
18044             IF (IDBAM(I).EQ.7) GOTO 900
18045             IPOT = 0
18046             IOTHER = 0
18047 * particle moving into forward direction
18048             IF (PHKK(3,I).GE.ZERO) THEN
18049 *   most likely to be effected by projectile potential
18050                IPOT = 1
18051 *     there is no projectile nucleus, try target
18052                IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
18053                   IPOT   = 2
18054                   IF (IP.GT.1) IOTHER = 1
18055 *       there is no target nucleus --> skip
18056                   IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900
18057                ENDIF
18058 * particle moving into backward direction
18059             ELSE
18060 *   most likely to be effected by target potential
18061                IPOT = 2
18062 *     there is no target nucleus, try projectile
18063                IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
18064                   IPOT   = 1
18065                   IF (IT.GT.1) IOTHER = 1
18066 *       there is no projectile nucleus --> skip
18067                   IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900
18068                ENDIF
18069             ENDIF
18070             IFLG = -IPOT
18071 * nobam=3: particle is in overlap-region or neither inside proj. nor target
18072 *      =1: particle is not in overlap-region AND is inside target (2)
18073 *      =2: particle is not in overlap-region AND is inside projectile (1)
18074 * flag particles which are inside the nucleus ipot but not in its
18075 * overlap region
18076             IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT
18077             IF (IDBAM(I).NE.0) THEN
18078 * baryons: keep all nucleons and all others where flag is set
18079                IF (IIBAR(IDBAM(I)).NE.0) THEN
18080                   IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0))
18081      &                                                              THEN
18082                      NOB = NOB+1
18083                      PMOMB(NOB) = PHKK(3,I)
18084                      IDXB(NOB)  = SIGN(10000000*IABS(IFLG)
18085      &                           +1000000*IOTHER+I,IFLG)
18086                   ENDIF
18087 * mesons: keep only those mesons where flag is set
18088                ELSE
18089                   IF (IFLG.GT.0) THEN
18090                      NOM = NOM+1
18091                      PMOMM(NOM) = PHKK(3,I)
18092                      IDXM(NOM)  = 10000000*IFLG+1000000*IOTHER+I
18093                   ENDIF
18094                ENDIF
18095             ENDIF
18096          ENDIF
18097   900 CONTINUE
18098 *
18099 * sort particles in the arrays according to increasing long. momentum
18100       CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1)
18101       CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1)
18102 *
18103 * shuffle indices into one and the same array according to the later
18104 * sequence of correction
18105       NCOR = 0
18106       IF (IT.GT.1) THEN
18107          DO 910 I=1,NOB
18108             IF (PMOMB(I).GT.ZERO) GOTO 911
18109             NCOR = NCOR+1
18110             IDXCOR(NCOR) = IDXB(I)
18111   910    CONTINUE
18112   911    CONTINUE
18113          IF (IP.GT.1) THEN
18114             DO 912 J=1,NOB
18115                I = NOB+1-J
18116                IF (PMOMB(I).LT.ZERO) GOTO 913
18117                NCOR = NCOR+1
18118                IDXCOR(NCOR) = IDXB(I)
18119   912       CONTINUE
18120   913       CONTINUE
18121          ELSE
18122             DO 914 I=1,NOB
18123                IF (PMOMB(I).GT.ZERO) THEN
18124                   NCOR = NCOR+1
18125                   IDXCOR(NCOR) = IDXB(I)
18126                ENDIF
18127   914       CONTINUE
18128          ENDIF
18129       ELSE
18130          DO 915 J=1,NOB
18131             I = NOB+1-J
18132             NCOR = NCOR+1
18133             IDXCOR(NCOR) = IDXB(I)
18134   915    CONTINUE
18135       ENDIF
18136       DO 925 I=1,NOM
18137          IF (PMOMM(I).GT.ZERO) GOTO 926
18138          NCOR = NCOR+1
18139          IDXCOR(NCOR) = IDXM(I)
18140   925 CONTINUE
18141   926 CONTINUE
18142       DO 927 J=1,NOM
18143          I = NOM+1-J
18144          IF (PMOMM(I).LT.ZERO) GOTO 928
18145          NCOR = NCOR+1
18146          IDXCOR(NCOR) = IDXM(I)
18147   927 CONTINUE
18148   928 CONTINUE
18149 *
18150 C      IF (NEVHKK.EQ.484) THEN
18151 C         WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
18152 C 9000    FORMAT(1X,'wounded nucleons (proj.-p,n  targ.-p,n)',/,4I10)
18153 C         WRITE(LOUT,9001) NOB,NOM,NCOR
18154 C 9001    FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
18155 C         WRITE(LOUT,'(/,A)') ' baryons '
18156 C         DO 950 I=1,NOB
18157 CC           J     = IABS(IDXB(I))
18158 CC           INDEX = J-IABS(J/10000000)*10000000
18159 C            IPOT   = IABS(IDXB(I))/10000000
18160 C            IOTHER = IABS(IDXB(I))/1000000-IPOT*10
18161 C            INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000
18162 C            WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
18163 C  950    CONTINUE
18164 C         WRITE(LOUT,'(/,A)') ' mesons '
18165 C         DO 951 I=1,NOM
18166 CC           INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000
18167 C            IPOT   = IABS(IDXM(I))/10000000
18168 C            IOTHER = IABS(IDXM(I))/1000000-IPOT*10
18169 C            INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000
18170 C            WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
18171 C  951    CONTINUE
18172 C 9002    FORMAT(1X,4I14,E14.5)
18173 C         WRITE(LOUT,'(/,A)') ' all '
18174 C         DO 952 I=1,NCOR
18175 CC           J     = IABS(IDXCOR(I))
18176 CC           INDEX = J-IABS(J/10000000)*10000000
18177 CC            IPOT   = IABS(IDXCOR(I))/10000000
18178 C            IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10
18179 C            INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000
18180 C            WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
18181 C  952    CONTINUE
18182 C 9003    FORMAT(1X,4I14)
18183 C      ENDIF
18184 *
18185       DO 20 ICOR=1,NCOR
18186          IPOT   = IABS(IDXCOR(ICOR))/10000000
18187          IOTHER = IABS(IDXCOR(ICOR))/1000000-IPOT*10
18188          I = IABS(IDXCOR(ICOR))-IPOT*10000000-IOTHER*1000000
18189          IDXOTH(I) = 1
18190
18191          IDSEC  = IDBAM(I)
18192
18193 * reduction of particle momentum by corresponding nuclear potential
18194 * (this applies only if Fermi-momenta are requested)
18195
18196          IF (LFERMI) THEN
18197
18198 *   Lorentz-transformation into the rest system of the selected nucleus
18199             IMODE = -IPOT-1
18200             CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18201      &                  PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE)
18202             PSECO  = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2)
18203             AMSEC  = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO)))
18204             JPMOD  = 0
18205
18206             CHKLEV = TINY3
18207             IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1
18208             IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0
18209             IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN
18210                IF (IOULEV(3).GT.0)
18211      &            WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
18212  2000          FORMAT(1X,'RESNCL: inconsistent mass of particle',
18213      &                ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
18214      &                I4,'   AMSEC: ',E12.3,'  AAM(IDSEC): ',E12.3,/)
18215                GOTO 23
18216             ENDIF
18217
18218             DO 21 K=1,4
18219                PSEC0(K) = PSEC(K)
18220    21       CONTINUE
18221
18222 *   the correction for nuclear potential effects is applied to as many
18223 *   p/n as many nucleons were wounded; the momenta of other final state
18224 *   particles are corrected only if they materialize inside the corresp.
18225 *   nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
18226 *   = 3 part. outside proj. and targ., >=10 in overlapping region)
18227             IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN
18228                IF (IPOT.EQ.1) THEN
18229                   IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN
18230 *      this is most likely a wounded nucleon
18231 **test
18232 C                    RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
18233 C    &                           +(VHKK(2,IPW(JPW))/FM2MM)**2
18234 C    &                           +(VHKK(3,IPW(JPW))/FM2MM)**2)
18235 C                    RAD   = RNUCLE*DBLE(IP)**ONETHI
18236 C                    FDEN  = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
18237 C                    PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18238 **
18239                      PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18240                      JPW = JPW-1
18241                      JPMOD = 1
18242                   ELSE
18243 *      correct only if part. was materialized inside nucleus
18244 *      and if it is ouside the overlapping region
18245                      IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN
18246                         PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18247                         JPMOD = 1
18248                      ENDIF
18249                   ENDIF
18250                ELSEIF (IPOT.EQ.2) THEN
18251                   IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
18252 *      this is most likely a wounded nucleon
18253 **test
18254 C                    RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
18255 C    &                           +(VHKK(2,ITW(JTW))/FM2MM)**2
18256 C    &                           +(VHKK(3,ITW(JTW))/FM2MM)**2)
18257 C                    RAD   = RNUCLE*DBLE(IT)**ONETHI
18258 C                    FDEN  = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
18259 C                    PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18260 **
18261                      PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18262                      JTW = JTW-1
18263                      JPMOD = 1
18264                   ELSE
18265 *      correct only if part. was materialized inside nucleus
18266                      IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN
18267                         PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18268                         JPMOD = 1
18269                      ENDIF
18270                   ENDIF
18271                ENDIF
18272             ELSE
18273                IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
18274                   PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18275                   JPMOD = 1
18276                ENDIF
18277             ENDIF
18278
18279             IF (NLOOP.EQ.1) THEN
18280 * Coulomb energy correction:
18281 * the treatment of Coulomb potential correction is similar to the
18282 * one for nuclear potential
18283                IF (IDSEC.EQ.1) THEN
18284                   IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN
18285                      JPCW = JPCW-1
18286                   ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
18287                      JTCW = JTCW-1
18288                   ELSE
18289                      IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18290                   ENDIF
18291                ELSE
18292                   IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18293                ENDIF
18294                IF (IICH(IDSEC).EQ.1) THEN
18295 *    pos. particles: check if they are able to escape Coulomb potential
18296                   IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN
18297                      ISTHKK(I) = 14+IPOT
18298                      IF (ISTHKK(I).EQ.15) THEN
18299                         DO 26 K=1,4
18300                            PHKK(K,I) = PSEC0(K)
18301                            TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18302    26                CONTINUE
18303                         IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18304                         IF (IDSEC.EQ.1) NPCW = NPCW-1
18305                      ELSEIF (ISTHKK(I).EQ.16) THEN
18306                         DO 27 K=1,4
18307                            PHKK(K,I) = PSEC0(K)
18308                            TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18309    27                   CONTINUE
18310                         IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18311                         IF (IDSEC.EQ.1) NTCW = NTCW-1
18312                      ENDIF
18313                      GOTO 20
18314                   ENDIF
18315                ELSEIF (IICH(IDSEC).EQ.-1) THEN
18316 *    neg. particles: decrease energy by Coulomb-potential
18317                   PSEC(4) = PSEC(4)-ETACOU(IPOT)
18318                   JPMOD = 1
18319                ENDIF
18320             ENDIF
18321
18322    25       CONTINUE
18323
18324             IF (PSEC(4).LT.AMSEC) THEN
18325                IF (IOULEV(6).GT.0)
18326      &            WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
18327  2001          FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5,
18328      &                ' is not allowed to escape nucleus',/,
18329      &                8X,'id : ',I3,'   reduced energy: ',E15.4,
18330      &                '   mass: ',E12.3)
18331                ISTHKK(I) = 14+IPOT
18332                IF (ISTHKK(I).EQ.15) THEN
18333                   DO 28 K=1,4
18334                      PHKK(K,I) = PSEC0(K)
18335                      TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18336    28             CONTINUE
18337                   IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18338                   IF (IDSEC.EQ.1) NPCW = NPCW-1
18339                ELSEIF (ISTHKK(I).EQ.16) THEN
18340                   DO 29 K=1,4
18341                      PHKK(K,I) = PSEC0(K)
18342                      TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18343    29             CONTINUE
18344                   IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18345                   IF (IDSEC.EQ.1) NTCW = NTCW-1
18346                ENDIF
18347                GOTO 20
18348             ENDIF
18349
18350             IF (JPMOD.EQ.1) THEN
18351                PSECN  = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
18352 * 4-momentum after correction for nuclear potential
18353                DO 22 K=1,3
18354                   PSEC(K) = PSEC(K)*PSECN/PSECO
18355    22          CONTINUE
18356
18357 * store recoil momentum from particles escaping the nuclear potentials
18358                DO 30 K=1,4
18359                   IF (IPOT.EQ.1) THEN
18360                      TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K)
18361                   ELSEIF (IPOT.EQ.2) THEN
18362                      TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K)
18363                   ENDIF
18364    30          CONTINUE
18365
18366 * transform momentum back into n-n cms
18367                IMODE = IPOT+1
18368                CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4),
18369      &                     PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18370      &                     IDSEC,IMODE)
18371             ENDIF
18372
18373          ENDIF
18374
18375    23    CONTINUE
18376          DO 31 K=1,4
18377             PFSP(K) = PFSP(K)+PHKK(K,I)
18378    31    CONTINUE
18379
18380    20 CONTINUE
18381
18382       DO 33 I=NPOINT(4),NHKK
18383          IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN
18384             PFSP(1) = PFSP(1)+PHKK(1,I)
18385             PFSP(2) = PFSP(2)+PHKK(2,I)
18386             PFSP(3) = PFSP(3)+PHKK(3,I)
18387             PFSP(4) = PFSP(4)+PHKK(4,I)
18388          ENDIF
18389    33 CONTINUE
18390
18391       DO 34 K=1,5
18392          PRCLPR(K) = TRCLPR(K)
18393          PRCLTA(K) = TRCLTA(K)
18394    34 CONTINUE
18395
18396       IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18397 * hadron-nucleus interactions: get residual momentum from energy-
18398 * momentum conservation
18399          DO 32 K=1,4
18400             PRCLPR(K) = ZERO
18401             PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
18402    32    CONTINUE
18403       ELSE
18404 * nucleus-hadron, nucleus-nucleus: get residual momentum from
18405 * accumulated recoil momenta of particles leaving the spectators
18406 *   transform accumulated recoil momenta of residual nuclei into
18407 *   n-n cms
18408          PZI = PRCLPR(3)
18409          PEI = PRCLPR(4)
18410          CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
18411          PZI = PRCLTA(3)
18412          PEI = PRCLTA(4)
18413          CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
18414 C        IF (IP.GT.1) THEN
18415             PRCLPR(3) = PRCLPR(3)+PINIPR(3)
18416             PRCLPR(4) = PRCLPR(4)+PINIPR(4)
18417 C        ENDIF
18418          IF (IT.GT.1) THEN
18419             PRCLTA(3) = PRCLTA(3)+PINITA(3)
18420             PRCLTA(4) = PRCLTA(4)+PINITA(4)
18421          ENDIF
18422       ENDIF
18423
18424 * check momenta of residual nuclei
18425       IF (LEMCCK) THEN
18426          CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
18427      &               1,IDUM,IDUM)
18428          CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
18429      &               2,IDUM,IDUM)
18430          CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
18431      &               2,IDUM,IDUM)
18432          CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
18433      &               2,IDUM,IDUM)
18434          CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM)
18435 **sr 19.12. changed to avoid output when used with phojet
18436 C        CHKLEV = TINY3
18437          CHKLEV = TINY1
18438          CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
18439 C        IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
18440 C    &      CALL DT_EVTOUT(4)
18441          IF (IREJ1.GT.0) RETURN
18442       ENDIF
18443
18444       RETURN
18445       END
18446
18447 *$ CREATE DT_SCN4BA.FOR
18448 *COPY DT_SCN4BA
18449 *
18450 *===scn4ba=============================================================*
18451 *
18452       SUBROUTINE DT_SCN4BA
18453
18454 ************************************************************************
18455 * SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot.    *
18456 * This version dated 12.12.95 is written by S. Roesler.                *
18457 ************************************************************************
18458
18459       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18460       SAVE
18461       PARAMETER ( LINP = 10 ,
18462      &            LOUT = 6 ,
18463      &            LDAT = 9 )
18464       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
18465      &           TINY10=1.0D-10)
18466
18467 * event history
18468       PARAMETER (NMXHKK=200000)
18469       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18470      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18471      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18472 * extended event history
18473       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18474      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18475      &                IHIST(2,NMXHKK)
18476 * particle properties (BAMJET index convention)
18477       CHARACTER*8  ANAME
18478       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18479      &                IICH(210),IIBAR(210),K1(210),K2(210)
18480 * properties of interacting particles
18481       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18482 * nuclear potential
18483       LOGICAL LFERMI
18484       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18485      &                EBINDP(2),EBINDN(2),EPOT(2,210),
18486      &                ETACOU(2),ICOUL,LFERMI
18487 * treatment of residual nuclei: wounded nucleons
18488       COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18489 * treatment of residual nuclei: 4-momenta
18490       LOGICAL LRCLPR,LRCLTA
18491       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18492      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18493
18494       DIMENSION PLAB(2,5),PCMS(4)
18495
18496       IREJ = 0
18497
18498 * get number of wounded nucleons
18499       NPW    = 0
18500       NPW0   = 0
18501       NPCW   = 0
18502       NPSTCK = 0
18503       NTW    = 0
18504       NTW0   = 0
18505       NTCW   = 0
18506       NTSTCK = 0
18507
18508       ISGLPR = 0
18509       ISGLTA = 0
18510       LRCLPR = .FALSE.
18511       LRCLTA = .FALSE.
18512
18513 C     DO 2 I=1,NHKK
18514       DO 2 I=1,NPOINT(1)
18515 * projectile nucleons wounded in primary interaction and in fzc
18516          IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
18517             NPW      = NPW+1
18518             IPW(NPW) = I
18519             NPSTCK   = NPSTCK+1
18520             IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
18521             IF (ISTHKK(I).EQ.11)  NPW0 = NPW0+1
18522 C           IF (IP.GT.1) THEN
18523                DO 5 K=1,4
18524                   TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
18525     5          CONTINUE
18526 C           ENDIF
18527 * target nucleons wounded in primary interaction and in fzc
18528          ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
18529             NTW      = NTW+1
18530             ITW(NTW) = I
18531             NTSTCK   = NTSTCK+1
18532             IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
18533             IF (ISTHKK(I).EQ.12)  NTW0 = NTW0+1
18534             IF (IT.GT.1) THEN
18535                DO 6 K=1,4
18536                   TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
18537     6          CONTINUE
18538             ENDIF
18539          ELSEIF (ISTHKK(I).EQ.13) THEN
18540             ISGLPR = I
18541          ELSEIF (ISTHKK(I).EQ.14) THEN
18542             ISGLTA = I
18543          ENDIF
18544     2 CONTINUE
18545
18546       DO 11 I=NPOINT(4),NHKK
18547 * baryons which are unable to escape the nuclear potential of proj.
18548          IF (ISTHKK(I).EQ.15) THEN
18549             ISGLPR = I
18550             NPSTCK = NPSTCK-1
18551             IF (IIBAR(IDBAM(I)).NE.0) THEN
18552                NPW    = NPW-1
18553                IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
18554             ENDIF
18555             DO 7 K=1,4
18556                TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18557     7       CONTINUE
18558 * baryons which are unable to escape the nuclear potential of targ.
18559          ELSEIF (ISTHKK(I).EQ.16) THEN
18560             ISGLTA = I
18561             NTSTCK = NTSTCK-1
18562             IF (IIBAR(IDBAM(I)).NE.0) THEN
18563                NTW    = NTW-1
18564                IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
18565             ENDIF
18566             DO 8 K=1,4
18567                TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18568     8       CONTINUE
18569          ENDIF
18570    11 CONTINUE
18571
18572 * residual nuclei so far
18573       IRESP = IP-NPSTCK
18574       IREST = IT-NTSTCK
18575
18576 * ckeck for "residual nuclei" consisting of one nucleon only
18577 * treat it as final state particle
18578       IF (IRESP.EQ.1) THEN
18579          ID  = IDBAM(ISGLPR)
18580          IST = ISTHKK(ISGLPR)
18581          CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR),
18582      &               PHKK(3,ISGLPR),PHKK(4,ISGLPR),
18583      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2)
18584          IF (IST.EQ.13) THEN
18585             ISTHKK(ISGLPR) = 11
18586          ELSE
18587             ISTHKK(ISGLPR) = 2
18588          ENDIF
18589          CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0,
18590      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18591      &               IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR))
18592          NOBAM(NHKK)      = NOBAM(ISGLPR)
18593          JDAHKK(1,ISGLPR) = NHKK
18594          DO 21 K=1,4
18595             TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
18596    21    CONTINUE
18597       ENDIF
18598       IF (IREST.EQ.1) THEN
18599          ID  = IDBAM(ISGLTA)
18600          IST = ISTHKK(ISGLTA)
18601          CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA),
18602      &               PHKK(3,ISGLTA),PHKK(4,ISGLTA),
18603      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3)
18604          IF (IST.EQ.14) THEN
18605             ISTHKK(ISGLTA) = 12
18606          ELSE
18607             ISTHKK(ISGLTA) = 2
18608          ENDIF
18609          CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0,
18610      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18611      &               IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA))
18612          NOBAM(NHKK)      = NOBAM(ISGLTA)
18613          JDAHKK(1,ISGLTA) = NHKK
18614          DO 22 K=1,4
18615             TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
18616    22    CONTINUE
18617       ENDIF
18618
18619 * get nuclear potential corresp. to the residual nucleus
18620       IPRCL  = IP -NPW
18621       IPZRCL = IPZ-NPCW
18622       ITRCL  = IT -NTW
18623       ITZRCL = ITZ-NTCW
18624       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
18625
18626 * baryons unable to escape the nuclear potential are treated as
18627 * excited nucleons (ISTHKK=15,16)
18628       DO 3 I=NPOINT(4),NHKK
18629          IF (ISTHKK(I).EQ.1) THEN
18630             ID  = IDBAM(I)
18631             IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN
18632 *   final state n and p not being outside of both nuclei are considered
18633                NPOTP = 1
18634                NPOTT = 1
18635                IF ( (IP.GT.1)      .AND.(IRESP.GT.1).AND.
18636      &              (NOBAM(I).NE.1).AND.(NPW.GT.0)        ) THEN
18637 *     Lorentz-trsf. into proj. rest sys. for those being inside proj.
18638                   CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18639      &                        PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3),
18640      &                        PLAB(1,4),ID,-2)
18641                   PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2)
18642                   PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)*
18643      &                                  (PLAB(1,4)+PLABT) ))
18644                   EKIN = PLAB(1,4)-PLAB(1,5)
18645                   IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15
18646                   IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1
18647                ENDIF
18648                IF ( (IT.GT.1)      .AND.(IREST.GT.1).AND.
18649      &              (NOBAM(I).NE.2).AND.(NTW.GT.0)        ) THEN
18650 *     Lorentz-trsf. into targ. rest sys. for those being inside targ.
18651                   CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18652      &                        PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3),
18653      &                        PLAB(2,4),ID,-3)
18654                   PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2)
18655                   PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)*
18656      &                                  (PLAB(2,4)+PLABT) ))
18657                   EKIN = PLAB(2,4)-PLAB(2,5)
18658                   IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16
18659                   IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1
18660                ENDIF
18661                IF (PHKK(3,I).GE.ZERO) THEN
18662                   ISTHKK(I) = NPOTT
18663                   IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
18664                ELSE
18665                   ISTHKK(I) = NPOTP
18666                   IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
18667                ENDIF
18668                IF (ISTHKK(I).NE.1) THEN
18669                   J = ISTHKK(I)-14
18670                   DO 4 K=1,5
18671                      PHKK(K,I) = PLAB(J,K)
18672     4             CONTINUE
18673                   IF (ISTHKK(I).EQ.15) THEN
18674                      NPW = NPW-1
18675                      IF (ID.EQ.1) NPCW = NPCW-1
18676                      DO 9 K=1,4
18677                         TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18678     9                CONTINUE
18679                   ELSEIF (ISTHKK(I).EQ.16) THEN
18680                      NTW = NTW-1
18681                      IF (ID.EQ.1) NTCW = NTCW-1
18682                      DO 10 K=1,4
18683                         TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18684    10                CONTINUE
18685                   ENDIF
18686                ENDIF
18687             ENDIF
18688          ENDIF
18689     3 CONTINUE
18690
18691 * again: get nuclear potential corresp. to the residual nucleus
18692       IPRCL  = IP -NPW
18693       IPZRCL = IPZ-NPCW
18694       ITRCL  = IT -NTW
18695       ITZRCL = ITZ-NTCW
18696 c      AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
18697 cC     AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
18698 c     &             *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
18699 C     AFERP = 0.0D0
18700 c      AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
18701 cC     AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
18702 c     &             *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
18703 C     AFERT = 0.0D0
18704 C     IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
18705 C     IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
18706 C     IF (AFERP.GT.0.85D0) AFERP = 0.85D0
18707 C     IF (AFERT.GT.0.85D0) AFERT = 0.85D0
18708       AFERP = FERMOD+0.1D0
18709       AFERT = FERMOD+0.1D0
18710
18711       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
18712
18713       RETURN
18714       END
18715
18716 *$ CREATE DT_FICONF.FOR
18717 *COPY DT_FICONF
18718 *
18719 *===ficonf=============================================================*
18720 *
18721       SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
18722
18723 ************************************************************************
18724 * Treatment of FInal CONFiguration including evaporation, fission and  *
18725 * Fermi-break-up (for light nuclei only).                              *
18726 * Adopted from the original routine FINALE and extended to residual    *
18727 * projectile nuclei.                                                   *
18728 * This version dated 12.12.95 is written by S. Roesler.                *
18729 *                                                                      *
18730 * Last change 27.12.2006 by S. Roesler.                                *
18731 ************************************************************************
18732
18733       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18734       SAVE
18735       PARAMETER ( LINP = 10 ,
18736      &            LOUT = 6 ,
18737      &            LDAT = 9 )
18738       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
18739       PARAMETER (ANGLGB=5.0D-16)
18740       PARAMETER (AMUAMU=0.93149432D0,AMELEC=0.51099906D-3)
18741
18742 * event history
18743       PARAMETER (NMXHKK=200000)
18744       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18745      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18746      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18747 * extended event history
18748       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18749      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18750      &                IHIST(2,NMXHKK)
18751 * rejection counter
18752       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
18753      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
18754      &                IREXCI(3),IRDIFF(2),IRINC
18755 * central particle production, impact parameter biasing
18756       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
18757 * particle properties (BAMJET index convention)
18758       CHARACTER*8  ANAME
18759       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18760      &                IICH(210),IIBAR(210),K1(210),K2(210)
18761 * treatment of residual nuclei: 4-momenta
18762       LOGICAL LRCLPR,LRCLTA
18763       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18764      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18765 * treatment of residual nuclei: properties of residual nuclei
18766       COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
18767      &                NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
18768      &                NTOTFI(2),NPROFI(2)
18769 * statistics: residual nuclei
18770       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
18771      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
18772      &                NINCST(2,4),NINCEV(2),
18773      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
18774      &                NRESPB(2),NRESCH(2),NRESEV(4),
18775      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
18776      &                NEVAFI(2,2)
18777 * flags for input different options
18778       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18779       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18780      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18781 * (original name: FINUC)
18782       PARAMETER (MXP=999)
18783       COMMON /FKFINU/ CXR    (MXP), CYR    (MXP), CZR    (MXP),
18784      &                CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
18785      &                TKI    (MXP), PLR    (MXP), WEI    (MXP),
18786      &                TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
18787      &                KPART  (MXP)
18788 * (original name: RESNUC)
18789       LOGICAL LRNFSS, LFRAGM
18790       COMMON /FKRESN/  AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
18791      &                   ANOW,   ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
18792      &                   ERES,  EKRES, AMNRES, AMMRES,  PTRES,  PXRES,
18793      &                  PYRES,  PZRES, PTRES2,  KTARP,  KTARN, IGREYP,
18794      &                 IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
18795      &                  ICRES,  IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
18796      &                 IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
18797      &                  IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
18798      &                 LFRAGM
18799       COMMON /FKNDAT/ AV0WEL,     APFRMX,     AEFRMX,     AEFRMA,
18800      &                RDSNUC,     V0WELL (2), PFRMMX (2), EFRMMX (2),
18801      &                EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
18802      &                VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
18803      &                PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
18804      &                EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
18805      &                ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV    ,
18806      &                AMRCSQ    , ATO1O3    , ZTO1O3    , ELBNDE (0:100)
18807 * (original name: PAREVT)
18808       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
18809      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
18810       PARAMETER ( NALLWP = 39   )
18811       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
18812      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
18813      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
18814      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
18815 * event flag
18816       COMMON /DTEVNO/ NEVENT,ICASCA
18817
18818       DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2),
18819      &          PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4),
18820      &          P1IN(4),P2IN(4),P1OUT(4),P2OUT(4)
18821
18822       DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260)
18823       LOGICAL LLCPOT
18824       DATA EXC,NEXC /520*ZERO,520*0/
18825       DATA EXPNUC /4.0D-3,4.0D-3/
18826
18827       IREJ   = 0
18828       LRCLPR = .FALSE.
18829       LRCLTA = .FALSE.
18830
18831 * skip residual nucleus treatment if not requested or in case
18832 * of central collisions
18833       IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN
18834
18835       DO 1 K=1,2
18836          IDPAR(K) = 0
18837          IDXPAR(K)= 0
18838          NTOT(K)  = 0
18839          NTOTFI(K)= 0
18840          NPRO(K)  = 0
18841          NPROFI(K)= 0
18842          NN(K)    = 0
18843          NH(K)    = 0
18844          NHPOS(K) = 0
18845          NQ(K)    = 0
18846          EEXC(K)  = ZERO
18847          MO1(K)   = 0
18848          MO2(K)   = 0
18849          DO 2 I=1,4
18850             VRCL(K,I) = ZERO
18851             WRCL(K,I) = ZERO
18852     2    CONTINUE
18853     1 CONTINUE
18854       NFSP = 0
18855       INUC(1) = IP
18856       INUC(2) = IT
18857
18858       DO 3 I=1,NHKK
18859
18860 * number of final state particles
18861          IF (ABS(ISTHKK(I)).EQ.1) THEN
18862             NFSP  = NFSP+1
18863             IDFSP = IDBAM(I)
18864          ENDIF
18865
18866 * properties of remaining nucleon configurations
18867          KF = 0
18868          IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1
18869          IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2
18870          IF (KF.GT.0) THEN
18871             IF (MO1(KF).EQ.0) MO1(KF) = I
18872             MO2(KF)  = I
18873 *   position of residual nucleus = average position of nucleons
18874             DO 4 K=1,4
18875                VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
18876                WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
18877     4       CONTINUE
18878 *   total number of particles contributing to each residual nucleus
18879             NTOT(KF)  = NTOT(KF)+1
18880             IDTMP     = IDBAM(I)
18881             IDXTMP    = I
18882 *   total charge of residual nuclei
18883             NQ(KF) = NQ(KF)+IICH(IDTMP)
18884 *   number of protons
18885             IF (IDHKK(I).EQ.2212) THEN
18886                NPRO(KF) = NPRO(KF)+1
18887 *   number of neutrons
18888             ELSEIF (IDHKK(I).EQ.2112) THEN
18889                NN(KF) = NN(KF)+1
18890             ELSE
18891 *   number of baryons other than n, p
18892                IF (IIBAR(IDTMP).EQ.1) THEN
18893                   NH(KF) = NH(KF)+1
18894                   IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
18895                ELSE
18896 *   any other mesons (status set to 1)
18897 C                 WRITE(LOUT,1002) KF,IDTMP
18898 C1002             FORMAT(1X,'FICONF:   residual nucleus ',I2,
18899 C    &                   ' containing meson ',I4,', status set to 1')
18900                   ISTHKK(I) = 1
18901                   IDTMP     = IDPAR(KF)
18902                   IDXTMP    = IDXPAR(KF)
18903                   NTOT(KF)  = NTOT(KF)-1
18904                ENDIF
18905             ENDIF
18906             IDPAR(KF)  = IDTMP
18907             IDXPAR(KF) = IDXTMP
18908          ENDIF
18909     3 CONTINUE
18910
18911 * reject elastic events (def: one final state particle = projectile)
18912       IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN
18913          IREXCI(3) = IREXCI(3)+1
18914          GOTO 9999
18915 C        RETURN
18916       ENDIF
18917
18918 * check if one nucleus disappeared..
18919 C     IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
18920 C        DO 5 K=1,4
18921 C           PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
18922 C           PRCLPR(K) = ZERO
18923 C   5    CONTINUE
18924 C     ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
18925 C        DO 6 K=1,4
18926 C           PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
18927 C           PRCLTA(K) = ZERO
18928 C   6    CONTINUE
18929 C     ENDIF
18930
18931       ICOR   = 0
18932       INORCL = 0
18933       DO 7 I=1,2
18934          DO 8 K=1,4
18935 * get the average of the nucleon positions
18936             VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1)
18937             WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1)
18938             IF (I.EQ.1) PRCL(1,K) = PRCLPR(K)
18939             IF (I.EQ.2) PRCL(2,K) = PRCLTA(K)
18940     8    CONTINUE
18941 * mass number and charge of residual nuclei
18942          AIF(I)  = DBLE(NTOT(I))
18943          AIZF(I) = DBLE(NPRO(I)+NHPOS(I))
18944          IF (NTOT(I).GT.1) THEN
18945 * masses of residual nuclei in ground state
18946             AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*DT_ENERGY(AIF(I),AIZF(I))
18947 * masses of residual nuclei
18948             PTORCL   = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2)
18949             AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL)
18950             IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I))
18951 *
18952 *   M_res^2 < 0 : configuration not allowed
18953 *
18954 *      a) re-calculate E_exc with scaled nuclear potential
18955 *         (conditional jump to label 9998)
18956 *      b) or reject event if N_loop(max) is exceeded
18957 *         (conditional jump to label 9999)
18958 *
18959             IF (AMRCL(I).LE.ZERO) THEN
18960                IF (IOULEV(3).GT.0)
18961      &            WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3),
18962      &                             PRCL(I,4),NTOT
18963  1000          FORMAT(1X,'warning! negative excitation energy',/,
18964      &                I4,4E15.4,2I4)
18965                AMRCL(I) = ZERO
18966                EEXC(I)  = ZERO
18967                IF (NLOOP.LE.500) THEN
18968                   GOTO 9998
18969                ELSE
18970                   IREXCI(2) = IREXCI(2)+1
18971                   GOTO 9999
18972                ENDIF
18973 *
18974 *   0 < M_res < M_res0 : mass below ground-state mass
18975 *
18976 *      a) we had residual nuclei with mass N_tot and reasonable E_exc
18977 *         before- assign average E_exc of those configurations to this
18978 *         one ( Nexc(i,N_tot) > 0 )
18979 *      b) or (and this applies always if run in transport codes) go up
18980 *         one mass number and
18981 *           i) if mass now larger than proj/targ mass or if run in
18982 *              transport codes assign average E_exc per wounded nucleon
18983 *              x number of wounded nucleons (Inuc-Ntot)
18984 *          ii) or assign average E_exc of those configurations to this
18985 *              one ( Nexc(i,m) > 0 )
18986 *
18987             ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
18988      &                                                         THEN
18989                M = MIN(NTOT(I),260)
18990                IF (NEXC(I,M).GT.0) THEN
18991                   AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
18992                ELSE
18993    70             CONTINUE
18994                   M = M+1
18995 **sr corrected 27.12.06
18996 *                 IF (M.GE.INUC(I)) THEN
18997 *                    AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
18998                   IF ((M.GE.INUC(I)).OR.(ICASCA.GT.0)) THEN
18999                      IF ( INUC (I) .GT. NTOT (I) ) THEN
19000                         AMRCL(I) = AMRCL0(I)
19001      &                         + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0))
19002                      ELSE
19003                         AMRCL(I) = AMRCL0(I) + 0.5D+00 * EXPNUC(I)
19004                      END IF
19005 **
19006                   ELSE
19007                      IF (NEXC(I,M).GT.0) THEN
19008                         AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
19009                      ELSE
19010                         GOTO 70
19011                      ENDIF
19012                   ENDIF
19013                ENDIF
19014                EEXC(I)  = AMRCL(I)-AMRCL0(I)
19015                ICOR     = ICOR+I
19016 *
19017 *   M_res > 2.5 x M_res0 : unreasonably(?) high E_exc
19018 *
19019 *      a) re-calculate E_exc with scaled nuclear potential
19020 *         (conditional jump to label 9998)
19021 *      b) or reject event if N_loop(max) is exceeded
19022 *         (conditional jump to label 9999)
19023 *
19024 *
19025             ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN
19026                IF (IOULEV(3).GT.0)
19027      &            WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK
19028  1004          FORMAT(1X,'warning! too high excitation energy',/,
19029      &                I4,1P,2E15.4,3I5)
19030                AMRCL(I) = ZERO
19031                EEXC(I)  = ZERO
19032                IF (NLOOP.LE.500) THEN
19033                   GOTO 9998
19034                ELSE
19035                   IREXCI(2) = IREXCI(2)+1
19036                   GOTO 9999
19037                ENDIF
19038 *
19039 *   Otherwise (reasonable E_exc) :
19040 *      E_exc = M_res - M_res0
19041 *      in addition: calculate and save E_exc per wounded nucleon as
19042 *                   well as E_exc in <E_exc> counter
19043 *
19044             ELSE
19045 * excitation energies of residual nuclei
19046                EEXC(I)   = AMRCL(I)-AMRCL0(I)
19047 **sr 27.12.06 new excitation energy correction by A.F.
19048 *
19049 * all parts with Ilcopt<3 commented since not used
19050 *
19051 * still to be done/decided:
19052 *   Increase Icor and put back both residual nuclei on mass shell
19053 *   with the exciting correction further below.
19054 *   For the moment the modification in the excitation energy is simply
19055 *   corrected by scaling the energy of the residual nucleus.
19056 *
19057                LLCPOT = .TRUE.
19058                ILCOPT = 3
19059                IF ( LLCPOT ) THEN
19060                   NNCHIT = MAX ( INUC (I) - NTOT (I), 0 )
19061                   IF ( ILCOPT .LE. 2 ) THEN
19062 C* Patch for Fermi momentum reduction correlated with impact parameter:
19063 C                     FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE )
19064 C                     DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I)))
19065 C                     AKPRHO = ONE - DLKPRH
19066 C* f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen
19067 C                     FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO  - ONE,
19068 C     &                              0.05D+00 )
19069 C*                    REDORI = 0.75D+00
19070 C*                    REDORI = ONE
19071 C                     REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
19072                   ELSE
19073                      DLKPRH = ZERO
19074                      RDCORE = 1.14D+00 * DBLE(INUC(I))**(ONE/3.D+00)
19075 *  Take out roughly one/half of the skin:
19076                      RDCORE = RDCORE - 0.5D+00
19077                      FRCFLL = RDCORE**3
19078                      PRSKIN = (RDCORE+2.4D+00)**3 - FRCFLL
19079                      PRSKIN = 0.5D+00 * PRSKIN / ( PRSKIN + FRCFLL )
19080                      FRCFLL = ONE - PRSKIN
19081                      FRMRDC = FRCFLL + 0.5D+00 * PRSKIN
19082                      REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
19083                   END IF
19084                   IF ( NNCHIT .GT. 0 ) THEN
19085 C                     IF ( ILCOPT .EQ. 1 ) THEN
19086 C                        SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE)
19087 C                        DO 1220 NCH = 1, 10
19088 C                           ETAETA = ( ONE - SKINRH**INUC(I)
19089 C     &                            - DBLE(INUC(I))* ( ONE - FRCFLL )
19090 C     &                            * ( ONE - SKINRH ) )
19091 C     &                            / ( SKINRH**INUC(I) - DBLE (INUC(I))
19092 C     &                            * ( ONE - FRCFLL) * SKINRH )
19093 C                           SKINRH = SKINRH * ( ONE + ETAETA )
19094 C 1220                   CONTINUE
19095 C                        PRSKIN = SKINRH**(NNCHIT-1)
19096 C                     ELSE IF ( ILCOPT .EQ. 2 ) THEN
19097 C                        PRSKIN = ONE - FRCFLL
19098 C                     END IF
19099                      REDCTN = ZERO
19100                      DO 1230 NCH = 1, NNCHIT
19101                         IF (DT_RNDM(PRFRMI) .LT. PRSKIN) THEN
19102                            PRFRMI = (( ONE - 2.D+00 * DLKPRH )
19103      &                            * DT_RNDM(PRFRMI))**0.333333333333D+00
19104                         ELSE
19105                            PRFRMI = ( ONE - 2.D+00 * DLKPRH
19106      &                            * DT_RNDM(PRFRMI))**0.333333333333D+00
19107                         END IF
19108                         REDCTN = REDCTN + PRFRMI**2
19109  1230                CONTINUE
19110                      REDCTN = REDCTN / DBLE (NNCHIT)
19111                   ELSE
19112                      REDCTN = 0.5D+00
19113                   END IF
19114                   EEXC  (I) = EEXC   (I) * REDCTN / REDORI
19115                   AMRCL (I) = AMRCL0 (I) + EEXC (I)
19116                   PRCL(I,4) = SQRT ( PTORCL**2 + AMRCL(I)**2 )
19117                END IF
19118 **
19119                IF (ICASCA.EQ.0) THEN
19120                   EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I))
19121                   M = MIN(NTOT(I),260)
19122                   EXC(I,M)  = EXC(I,M)+EEXC(I)
19123                   NEXC(I,M) = NEXC(I,M)+1
19124                ENDIF
19125             ENDIF
19126          ELSEIF (NTOT(I).EQ.1) THEN
19127             WRITE(LOUT,1003) I
19128  1003       FORMAT(1X,'FICONF:   warning! NTOT(I)=1? (I=',I3,')')
19129             GOTO 9999
19130          ELSE
19131             AMRCL0(I) = ZERO
19132             AMRCL(I)  = ZERO
19133             EEXC(I)   = ZERO
19134             INORCL    = INORCL+I
19135          ENDIF
19136     7 CONTINUE
19137
19138       PRCLPR(5) = AMRCL(1)
19139       PRCLTA(5) = AMRCL(2)
19140
19141       IF (ICOR.GT.0) THEN
19142          IF (INORCL.EQ.0) THEN
19143 * one or both residual nuclei consist of one nucleon only, transform
19144 * this nucleon on mass shell
19145             DO 9 K=1,4
19146                P1IN(K) = PRCL(1,K)
19147                P2IN(K) = PRCL(2,K)
19148     9       CONTINUE
19149             XM1 = AMRCL(1)
19150             XM2 = AMRCL(2)
19151             CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
19152             IF (IREJ1.GT.0) THEN
19153                WRITE(LOUT,*) 'ficonf-mashel rejection'
19154                GOTO 9999
19155             ENDIF
19156             DO 10 K=1,4
19157                PRCL(1,K) = P1OUT(K)
19158                PRCL(2,K) = P2OUT(K)
19159                PRCLPR(K) = P1OUT(K)
19160                PRCLTA(K) = P2OUT(K)
19161    10       CONTINUE
19162             PRCLPR(5) = AMRCL(1)
19163             PRCLTA(5) = AMRCL(2)
19164          ELSE
19165             IF (IOULEV(3).GT.0)
19166      &      WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)),
19167      &                       INT(AIF(2)),INT(AIZF(2)),AMRCL0(1),
19168      &                       AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2),
19169      &                       AMRCL(2),AMRCL(2)-AMRCL0(2)
19170  1001       FORMAT(1X,'FICONF:   warning! no residual nucleus for',
19171      &             ' correction',/,11X,'at event',I8,
19172      &             ',  nucleon config. 1:',2I4,' 2:',2I4,
19173      &             2(/,11X,3E12.3))
19174             IF (NLOOP.LE.500) THEN
19175                GOTO 9998
19176             ELSE
19177                IREXCI(1) = IREXCI(1)+1
19178             ENDIF
19179          ENDIF
19180       ENDIF
19181
19182 * update counter
19183 C     IF (NRESEV(1).NE.NEVHKK) THEN
19184 C        NRESEV(1) = NEVHKK
19185 C        NRESEV(2) = NRESEV(2)+1
19186 C     ENDIF
19187       NRESEV(2) = NRESEV(2)+1
19188       DO 15 I=1,2
19189          EXCDPM(I)   = EXCDPM(I)+EEXC(I)
19190          EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1))
19191          NRESTO(I) = NRESTO(I)+NTOT(I)
19192          NRESPR(I) = NRESPR(I)+NPRO(I)
19193          NRESNU(I) = NRESNU(I)+NN(I)
19194          NRESBA(I) = NRESBA(I)+NH(I)
19195          NRESPB(I) = NRESPB(I)+NHPOS(I)
19196          NRESCH(I) = NRESCH(I)+NQ(I)
19197    15 CONTINUE
19198
19199 * evaporation
19200       IF (LEVPRT) THEN
19201          DO 13 I=1,2
19202 * initialize evaporation counter
19203             EEXCFI(I) = ZERO
19204             IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
19205      &          (EEXC(I).GT.ZERO)) THEN
19206 * put residual nuclei into DTEVT1
19207                IDRCL = 80000
19208                JMASS = INT( AIF(I))
19209                JCHAR = INT(AIZF(I))
19210 *  the following patch is required to transmit the correct excitation
19211 *   energy to Eventd
19212                IF (ITRSPT.EQ.1) THEN
19213                   IF ((ABS(AMRCL(I)-AMRCL0(I)-EEXC(I)).GT.1.D-04).AND.
19214      &                (IOULEV(3).GT.0))
19215      &               WRITE(LOUT,*)
19216      &                  ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)',
19217      &                              AMRCL(I),AMRCL0(I),EEXC(I)
19218                   PRCL0 = PRCL(I,4)
19219                   PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
19220      &                                                    +PRCL(I,3)**2)
19221                   IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
19222                      WRITE(LOUT,*)
19223      &                  ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
19224                   ENDIF
19225                ENDIF
19226                CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1),
19227      &              PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0)
19228 **sr 22.6.97
19229                NOBAM(NHKK) = I
19230 **
19231                DO 14 J=1,4
19232                   VHKK(J,NHKK) = VRCL(I,J)
19233                   WHKK(J,NHKK) = WRCL(I,J)
19234    14          CONTINUE
19235 *  interface to evaporation module - fill final residual nucleus into
19236 *  common FKRESN
19237 *   fill resnuc only if code is not used as event generator in Fluka
19238                IF (ITRSPT.NE.1) THEN
19239                   PXRES  = PRCL(I,1)
19240                   PYRES  = PRCL(I,2)
19241                   PZRES  = PRCL(I,3)
19242                   IBRES  = NPRO(I)+NN(I)+NH(I)
19243                   ICRES  = NPRO(I)+NHPOS(I)
19244                   ANOW   = DBLE(IBRES)
19245                   ZNOW   = DBLE(ICRES)
19246                   PTRES  = SQRT(PXRES**2+PYRES**2+PZRES**2)
19247 *   ground state mass of the residual nucleus (should be equal to AM0T)
19248                   AMMRES = AMRCL0(I)
19249                   AMNRES = AMMRES-ZNOW*AMELEC+ELBNDE(ICRES)
19250 *  common FKFINU
19251                   TV = ZERO
19252 *   kinetic energy of residual nucleus
19253                   TVRECL = PRCL(I,4)-AMRCL(I)
19254 *   excitation energy of residual nucleus
19255                   TVCMS  = EEXC(I)
19256                   PTOLD  = PTRES
19257                   PTRES  = SQRT(ABS(TVRECL*(TVRECL+
19258      &                          2.0D0*(AMMRES+TVCMS))))
19259                   IF (PTOLD.LT.ANGLGB) THEN
19260                      CALL DT_RACO(PXRES,PYRES,PZRES)
19261                      PTOLD = ONE
19262                   ENDIF
19263                   PXRES = PXRES*PTRES/PTOLD
19264                   PYRES = PYRES*PTRES/PTOLD
19265                   PZRES = PZRES*PTRES/PTOLD
19266 * zero counter of secondaries from evaporation
19267                   NP = 0
19268 * evaporation
19269                   WE = ONE
19270                   CALL DT_EVEVAP(WE)
19271 * put evaporated particles and residual nuclei to DTEVT1
19272                   MO = NHKK
19273                   CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
19274                ENDIF
19275                EEXCFI(I) = EXCITF
19276                EXCEVA(I) = EXCEVA(I)+EXCITF
19277             ENDIF
19278    13    CONTINUE
19279       ENDIF
19280
19281       RETURN
19282
19283 C9998 IREXCI(1) = IREXCI(1)+1
19284  9998 IREJ   = IREJ+1
19285  9999 CONTINUE
19286       LRCLPR = .TRUE.
19287       LRCLTA = .TRUE.
19288       IREJ   = IREJ+1
19289       RETURN
19290       END
19291
19292 *$ CREATE DT_EVA2HE.FOR
19293 *COPY DT_EVA2HE
19294 *                                                                      *
19295 *====eva2he============================================================*
19296 *                                                                      *
19297       SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
19298
19299 ************************************************************************
19300 * Interface between common's of evaporation module (FKFINU,FKFHVY)     *
19301 * and DTEVT1.                                                          *
19302 *    MO    DTEVT1-index of "mother" (residual) nucleus before evap.    *
19303 *    EEXCF exitation energy of residual nucleus after evaporation      *
19304 *    IRCL  = 1 projectile residual nucleus                             *
19305 *          = 2 target     residual nucleus                             *
19306 * This version dated 19.04.95 is written by S. Roesler.                *
19307 *                                                                      *
19308 * Last change 27.12.2006 by S. Roesler.                                *
19309 ************************************************************************
19310
19311       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19312       SAVE
19313       PARAMETER ( LINP = 10 ,
19314      &            LOUT = 6 ,
19315      &            LDAT = 9 )
19316       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3)
19317
19318 * event history
19319       PARAMETER (NMXHKK=200000)
19320       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19321      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19322      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19323 * Note: DTEVT2 - special use for heavy fragments !
19324 *       (IDRES(I) = mass number, IDXRES(I) = charge)
19325 * extended event history
19326       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19327      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19328      &                IHIST(2,NMXHKK)
19329 * particle properties (BAMJET index convention)
19330       CHARACTER*8  ANAME
19331       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19332      &                IICH(210),IIBAR(210),K1(210),K2(210)
19333 * flags for input different options
19334       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
19335       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
19336      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
19337 * statistics: residual nuclei
19338       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
19339      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
19340      &                NINCST(2,4),NINCEV(2),
19341      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
19342      &                NRESPB(2),NRESCH(2),NRESEV(4),
19343      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
19344      &                NEVAFI(2,2)
19345 * treatment of residual nuclei: properties of residual nuclei
19346       COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
19347      &                NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
19348      &                NTOTFI(2),NPROFI(2)
19349 * (original name: FINUC)
19350       PARAMETER (MXP=999)
19351       COMMON /FKFINU/ CXR    (MXP), CYR    (MXP), CZR    (MXP),
19352      &                CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
19353      &                TKI    (MXP), PLR    (MXP), WEI    (MXP),
19354      &                TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
19355      &                KPART  (MXP)
19356 * (original name: FHEAVY,FHEAVC)
19357       PARAMETER ( MXHEAV = 100 )
19358       CHARACTER*8 ANHEAV
19359       COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
19360      &                CZHEAV (MXHEAV), TKHEAV (MXHEAV),
19361      &                PHEAVY (MXHEAV), WHEAVY (MXHEAV),
19362      &                AMHEAV  ( 12 ) , AMNHEA  ( 12 ) ,
19363      &                KHEAVY (MXHEAV), ICHEAV  ( 12 ) ,
19364      &                IBHEAV  ( 12 ) , NPHEAV
19365       COMMON /FKFHVC/ ANHEAV  ( 12 )
19366 * (original name: RESNUC)
19367       LOGICAL LRNFSS, LFRAGM
19368       COMMON /FKRESN/  AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
19369      &                   ANOW,   ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
19370      &                   ERES,  EKRES, AMNRES, AMMRES,  PTRES,  PXRES,
19371      &                  PYRES,  PZRES, PTRES2,  KTARP,  KTARN, IGREYP,
19372      &                 IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
19373      &                  ICRES,  IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
19374      &                 IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
19375      &                  IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
19376      &                 LFRAGM
19377
19378       DIMENSION IPTOKP(39)
19379       DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
19380      & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
19381      & 100, 101, 97, 102, 98, 103, 109, 115 /
19382
19383       IREJ = 0
19384
19385 * skip if evaporation package is not included
19386       IF (.NOT.LEVAPO) RETURN
19387
19388 * update counter
19389       IF (NRESEV(3).NE.NEVHKK) THEN
19390          NRESEV(3) = NEVHKK
19391          NRESEV(4) = NRESEV(4)+1
19392       ENDIF
19393
19394       IF (LEMCCK)
19395      &   CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
19396      &                                                   IDUM,IDUM)
19397 * mass number/charge of residual nucleus before evaporation
19398       IBTOT = IDRES(MO)
19399       IZTOT = IDXRES(MO)
19400
19401 * protons/neutrons/gammas
19402       DO 1 I=1,NP
19403          PX    = CXR(I)*PLR(I)
19404          PY    = CYR(I)*PLR(I)
19405          PZ    = CZR(I)*PLR(I)
19406          ID    = IPTOKP(KPART(I))
19407          IDPDG = IDT_IPDGHA(ID)
19408          AM    = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/
19409      &           (2.0D0*MAX(TKI(I),TINY10))
19410          IF (ABS(AM-AAM(ID)).GT.TINY3) THEN
19411             WRITE(LOUT,1000) ID,AM,AAM(ID)
19412  1000       FORMAT(1X,'EVA2HE:  inconsistent mass of evap. ',
19413      &             'particle',I3,2E10.3)
19414          ENDIF
19415          PE = TKI(I)+AM
19416          CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
19417          NOBAM(NHKK) = IRCL
19418          IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19419          IBTOT = IBTOT-IIBAR(ID)
19420          IZTOT = IZTOT-IICH(ID)
19421     1 CONTINUE
19422
19423 * heavy fragments
19424       DO 2 I=1,NPHEAV
19425          PX     = CXHEAV(I)*PHEAVY(I)
19426          PY     = CYHEAV(I)*PHEAVY(I)
19427          PZ     = CZHEAV(I)*PHEAVY(I)
19428          IDHEAV = 80000
19429          AM     = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
19430      &            (2.0D0*MAX(TKHEAV(I),TINY10))
19431          PE     = TKHEAV(I)+AM
19432          CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
19433      &                  IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
19434          NOBAM(NHKK) = IRCL
19435          IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19436          IBTOT = IBTOT-IBHEAV(KHEAVY(I))
19437          IZTOT = IZTOT-ICHEAV(KHEAVY(I))
19438     2 CONTINUE
19439
19440       IF (IBRES.GT.0) THEN
19441 * residual nucleus after evaporation
19442          IDNUC = 80000
19443          CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
19444      &                                        IBRES,ICRES,0)
19445          NOBAM(NHKK) = IRCL
19446       ENDIF
19447       EEXCF = TVCMS
19448       NTOTFI(IRCL) = IBRES
19449       NPROFI(IRCL) = ICRES
19450       IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM)
19451       IBTOT = IBTOT-IBRES
19452       IZTOT = IZTOT-ICRES
19453
19454 * count events with fission
19455       NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
19456       IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
19457
19458 * energy-momentum conservation check
19459       IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
19460 C     IF (IREJ.GT.0) THEN
19461 C        CALL DT_EVTOUT(4)
19462 C        WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
19463 C     ENDIF
19464 * baryon-number/charge conservation check
19465       IF (IBTOT+IZTOT.NE.0) THEN
19466          WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT
19467  1001    FORMAT(1X,'EVA2HE:   baryon-number/charge conservation ',
19468      &          'failure at event ',I8,' :  IBTOT,IZTOT = ',2I3)
19469       ENDIF
19470
19471       RETURN
19472       END
19473
19474 *$ CREATE DT_EBIND.FOR
19475 *COPY DT_EBIND
19476 *
19477 *===ebind==============================================================*
19478 *
19479       DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
19480
19481 ************************************************************************
19482 * Binding energy for nuclei.                                           *
19483 * (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972)                  *
19484 *                 IA        mass number                                *
19485 *                 IZ        atomic number                              *
19486 * This version dated 5.5.95   is updated by S. Roesler.                *
19487 ************************************************************************
19488
19489       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19490       SAVE
19491       PARAMETER ( LINP = 10 ,
19492      &            LOUT = 6 ,
19493      &            LDAT = 9 )
19494       PARAMETER (ZERO=0.0D0)
19495
19496       DATA       A1,       A2,        A3,        A4,      A5
19497      &     / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
19498
19499       IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN
19500          WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0.  ',IA,IZ
19501          DT_EBIND = ZERO
19502          RETURN
19503       ENDIF
19504       AA = IA
19505       DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0)
19506      &        -A4*(IA-2*IZ)**2/AA
19507       IF (MOD(IA,2).EQ.1) THEN
19508          IA5 = 0
19509       ELSEIF (MOD(IZ,2).EQ.1) THEN
19510          IA5 = 1
19511       ELSE
19512          IA5 = -1
19513       ENDIF
19514       DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
19515
19516       RETURN
19517       END
19518
19519 **sr 30.6. routine replaced completely
19520 *$ CREATE DT_ENERGY.FOR
19521 *COPY DT_ENERGY
19522 *                                                                      *
19523 *=== energy ===========================================================*
19524 *                                                                      *
19525       DOUBLE PRECISION FUNCTION DT_ENERGY( A, Z )
19526
19527 C     INCLUDE '(DBLPRC)'
19528 * DBLPRC.ADD
19529       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19530       SAVE
19531 * (original name: GLOBAL)
19532       PARAMETER ( KALGNM = 2 )
19533       PARAMETER ( ANGLGB = 5.0D-16 )
19534       PARAMETER ( ANGLSQ = 2.5D-31 )
19535       PARAMETER ( AXCSSV = 0.2D+16 )
19536       PARAMETER ( ANDRFL = 1.0D-38 )
19537       PARAMETER ( AVRFLW = 1.0D+38 )
19538       PARAMETER ( AINFNT = 1.0D+30 )
19539       PARAMETER ( AZRZRZ = 1.0D-30 )
19540       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
19541       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
19542       PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
19543       PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
19544       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
19545       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
19546       PARAMETER ( CSNNRM = 2.0D-15 )
19547       PARAMETER ( DMXTRN = 1.0D+08 )
19548       PARAMETER ( ZERZER = 0.D+00 )
19549       PARAMETER ( ONEONE = 1.D+00 )
19550       PARAMETER ( TWOTWO = 2.D+00 )
19551       PARAMETER ( THRTHR = 3.D+00 )
19552       PARAMETER ( FOUFOU = 4.D+00 )
19553       PARAMETER ( FIVFIV = 5.D+00 )
19554       PARAMETER ( SIXSIX = 6.D+00 )
19555       PARAMETER ( SEVSEV = 7.D+00 )
19556       PARAMETER ( EIGEIG = 8.D+00 )
19557       PARAMETER ( ANINEN = 9.D+00 )
19558       PARAMETER ( TENTEN = 10.D+00 )
19559       PARAMETER ( HLFHLF = 0.5D+00 )
19560       PARAMETER ( ONETHI = ONEONE / THRTHR )
19561       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
19562       PARAMETER ( ONEFOU = ONEONE / FOUFOU )
19563       PARAMETER ( THRTWO = THRTHR / TWOTWO )
19564       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
19565       PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
19566       PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
19567       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
19568       PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
19569       PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
19570       PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
19571       PARAMETER ( EULERO = 0.577215664901532860606512      D+00 )
19572       PARAMETER ( EULEXP = 1.781072417990197985236504      D+00 )
19573       PARAMETER ( EULLOG =-0.5495393129816448223376619     D+00 )
19574       PARAMETER ( E1M2EU = 0.8569023337737540831433017     D+00 )
19575       PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
19576       PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
19577       PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
19578       PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
19579       PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
19580       PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
19581       PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
19582       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
19583       PARAMETER ( CLIGHT = 2.99792458         D+10 )
19584       PARAMETER ( AVOGAD = 6.0221367          D+23 )
19585       PARAMETER ( BOLTZM = 1.380658           D-23 )
19586       PARAMETER ( AMELGR = 9.1093897          D-28 )
19587       PARAMETER ( PLCKBR = 1.05457266         D-27 )
19588       PARAMETER ( ELCCGS = 4.8032068          D-10 )
19589       PARAMETER ( ELCMKS = 1.60217733         D-19 )
19590       PARAMETER ( AMUGRM = 1.6605402          D-24 )
19591       PARAMETER ( AMMUMU = 0.113428913        D+00 )
19592       PARAMETER ( AMPRMU = 1.007276470        D+00 )
19593       PARAMETER ( AMNEMU = 1.008664904        D+00 )
19594       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
19595       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
19596       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
19597       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
19598       PARAMETER ( PLABRC = 0.197327053        D+00 )
19599       PARAMETER ( AMELCT = 0.51099906         D-03 )
19600       PARAMETER ( AMUGEV = 0.93149432         D+00 )
19601       PARAMETER ( AMMUON = 0.105658389        D+00 )
19602       PARAMETER ( AMPRTN = 0.93827231         D+00 )
19603       PARAMETER ( AMNTRN = 0.93956563         D+00 )
19604       PARAMETER ( AMDEUT = 1.87561339         D+00 )
19605       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
19606      &                   * 1.D-09 )
19607       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
19608       PARAMETER ( BLTZMN = 8.617385           D-14 )
19609       PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
19610       PARAMETER ( GFOHB3 = 1.16639            D-05 )
19611       PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
19612       PARAMETER ( SIN2TW = 0.2319             D+00 )
19613       PARAMETER ( GEVMEV = 1.0                D+03 )
19614       PARAMETER ( EMVGEV = 1.0                D-03 )
19615       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
19616       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
19617       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
19618       LOGICAL LGBIAS, LGBANA
19619       COMMON /FKGLOB/ LGBIAS, LGBANA
19620 C     INCLUDE '(DIMPAR)'
19621 * DIMPAR.ADD
19622       PARAMETER ( MXXRGN = 5000 )
19623       PARAMETER ( MXXMDF = 82   )
19624       PARAMETER ( MXXMDE = 54   )
19625       PARAMETER ( MFSTCK = 1000 )
19626       PARAMETER ( MESTCK = 100  )
19627       PARAMETER ( NALLWP = 39   )
19628       PARAMETER ( NELEMX = 80   )
19629       PARAMETER ( MPDPDX = 8    )
19630       PARAMETER ( ICOMAX = 180  )
19631       PARAMETER ( NSTBIS = 304  )
19632       PARAMETER ( IDMAXP = 220  )
19633       PARAMETER ( IDMXDC = 640  )
19634       PARAMETER ( MKBMX1 = 1    )
19635       PARAMETER ( MKBMX2 = 1    )
19636 C     INCLUDE '(IOUNIT)'
19637 * IOUNIT.ADD
19638       PARAMETER ( LUNIN  =  5 )
19639       PARAMETER ( LUNOUT =  6 )
19640 **sr 19.5. set error output-unit from 15 to 6
19641       PARAMETER ( LUNERR = 6  )
19642       PARAMETER ( LUNBER = 14 )
19643       PARAMETER ( LUNECH =  8 )
19644       PARAMETER ( LUNFLU = 13 )
19645       PARAMETER ( LUNGEO = 16 )
19646       PARAMETER ( LUNPMF = 12 )
19647       PARAMETER ( LUNRAN =  2 )
19648       PARAMETER ( LUNXSC =  9 )
19649       PARAMETER ( LUNDET = 17 )
19650       PARAMETER ( LUNRAY = 10 )
19651       PARAMETER ( LUNRDB =  1 )
19652       PARAMETER ( LUNPGO =  7 )
19653       PARAMETER ( LUNPGS =  4 )
19654       PARAMETER ( LUNSCR =  3 )
19655 *
19656 *----------------------------------------------------------------------*
19657 *                                                                      *
19658 *     Revised version of the original routine from EVAP:               *
19659 *                                                                      *
19660 *     Created on   15 may 1990     by    Alfredo Ferrari & Paola Sala  *
19661 *                                                   Infn - Milan       *
19662 *                                                                      *
19663 *     Last change on 19-sep-95     by    Alfredo Ferrari               *
19664 *                                                                      *
19665 *     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!     *
19666 *     !!!  It is supposed to be used with the updated atomic   !!!     *
19667 *     !!!                    mass data file                    !!!     *
19668 *     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!     *
19669 *                                                                      *
19670 *----------------------------------------------------------------------*
19671 *
19672 *  Mass number below which "unknown" isotopes out of the Z-interval
19673 *  reported in the mass tabulations are completely unstable and made
19674 *  up by Z proton masses + N neutron masses:
19675       PARAMETER ( KAFREE =  4 )
19676 *  Mass number below which "unknown" isotopes out of the Z-interval
19677 *  reported in the mass tabulations are supposed to be particle unstable
19678       PARAMETER ( KAPUNS = 12 )
19679 *  Minimum energy required for particle unstable isotopes
19680       PARAMETER ( DEPUNS = 0.5D+00 )
19681 *
19682 * (original name: EVA0)
19683       COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
19684      *                FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
19685      *                CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
19686      *                T (4,7), RMASS (297), ALPH (297), BET (297),
19687      *                APRIME (250), IA (6), IZ (6)
19688 * (original name: ISOTOP)
19689       PARAMETER ( NAMSMX = 270 )
19690       PARAMETER ( NZGVAX =  15 )
19691       PARAMETER ( NISMMX = 574 )
19692       COMMON /FKISOT/ WAPS   (NAMSMX,NZGVAX),  T12NUC (NAMSMX,NZGVAX),
19693      &                WAPISM (NISMMX), T12ISM (NISMMX),
19694      &                ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
19695      &                AMSSST (100)  , ISOMNM (NSTBIS), ISONDX (2,100),
19696      &                JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
19697      &                INWAPS (NAMSMX), JSPISM (NISMMX),
19698      &                JPTISM (NISMMX), IZWISM (NISMMX),
19699      &                INWISM (0:NAMSMX)
19700 *
19701 CPH      SAVE KA0, KZ0, IZ0
19702       DATA KA0, KZ0, IZ0 / -1, -1, -1 /
19703 *
19704       IFLAG = 1
19705       GO TO 10
19706 *======================================================================*
19707 *                                                                      *
19708 *     Entry ENergy - KNOWn                                             *
19709 *                                                                      *
19710 *======================================================================*
19711       ENTRY DT_ENKNOW ( A, Z, IZZ0 )
19712       IZZ0  =-1
19713       IFLAG = 2
19714    10 CONTINUE
19715 *
19716       KA0 = NINT ( A )
19717       KZ0 = NINT ( Z )
19718       N   = KA0 - KZ0
19719 *  +-------------------------------------------------------------------*
19720 *  |  Null residual nucleus:
19721       IF ( KA0 .EQ. 0 .AND. KZ0 .LE. 0 ) THEN
19722          IF ( IFLAG .EQ. 1 ) THEN
19723             DT_ENERGY = ZERZER
19724          ELSE
19725             DT_ENKNOW = ZERZER
19726             IZZ0   = -1
19727          END IF
19728          RETURN
19729 *  |
19730 *  +-------------------------------------------------------------------*
19731 *  |  Only protons:
19732       ELSE IF ( N .LE. 0 ) THEN
19733          IF ( N .LT. 0 ) THEN
19734             WRITE ( LUNOUT, * )
19735      &     ' DPMJET stopped in energy: mass number =< atomic number !!',
19736      &       KA0, KZ0
19737             WRITE ( LUNOUT, * )
19738      &     ' DPMJET stopped in energy: mass number =< atomic number !!',
19739      &       KA0, KZ0
19740                WRITE ( 77, * )
19741      &  ' ^^^DPMJET stopped in energy: mass number =< atomic number !!',
19742      &       KA0, KZ0
19743             STOP 'DT_ENERGY:KA0-KZ0'
19744          END IF
19745          IZ0    = -1
19746          IF ( IFLAG .EQ. 1 ) THEN
19747             DT_ENERGY = Z * WAPS ( 1, 2 )
19748          ELSE
19749             DT_ENKNOW = Z * WAPS ( 1, 2 )
19750             IZZ0   = -1
19751          END IF
19752          RETURN
19753 *  |
19754 *  +-------------------------------------------------------------------*
19755 *  |  Only neutrons:
19756       ELSE IF ( KZ0 .LE. 0 ) THEN
19757          IF ( KZ0 .LT. 0 ) THEN
19758             WRITE ( LUNOUT, * )
19759      &   ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19760             WRITE ( LUNOUT, * )
19761      &   ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19762             WRITE ( 77, * )
19763      &' ^^^DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19764             STOP 'DT_ENERGY:KZ0<0'
19765          END IF
19766          IZ0    = -1
19767          IF ( IFLAG .EQ. 1 ) THEN
19768             DT_ENERGY = A * WAPS ( 1, 1 )
19769          ELSE
19770             DT_ENKNOW = A * WAPS ( 1, 1 )
19771             IZZ0   = -1
19772          END IF
19773          RETURN
19774       END IF
19775 *  |
19776 *  +-------------------------------------------------------------------*
19777 *  +-------------------------------------------------------------------*
19778 *  |  No actual nucleus
19779 *  |
19780 *  +-------------------------------------------------------------------*
19781 *  +-------------------------------------------------------------------*
19782 *  |  A larger than maximum allowed:
19783       IF ( KA0 .GT. NAMSMX ) THEN
19784          IZ0    = -1
19785          IF ( IFLAG .EQ. 1 ) THEN
19786             DT_ENERGY = DT_ENRG( A, Z )
19787          ELSE
19788             DT_ENKNOW = DT_ENRG( A, Z )
19789             IZZ0   = -1
19790          END IF
19791          RETURN
19792       END IF
19793 *  |
19794 *  +-------------------------------------------------------------------*
19795       IZZ = INWAPS ( KA0 )
19796 *  +-------------------------------------------------------------------*
19797 *  |  Too much neutron rich with respect to the stability line:
19798       IF ( KZ0 .LT. IZZ ) THEN
19799 *  |  +----------------------------------------------------------------*
19800 *  |  |  Up to A=Kafree all "bound" masses are known, set it unbound:
19801          IF ( KA0 .LE. KAFREE ) THEN
19802             DT_ENERGY = AINFNT
19803 *  |  |
19804 *  |  +----------------------------------------------------------------*
19805 *  |  |  Up to Kapuns: be sure it is particle unstable
19806          ELSE IF ( KA0 .LE. KAPUNS ) THEN
19807 *  |  |  Exp. excess mass for A,IZZ
19808             ENEEXP = WAPS ( KA0, 1 )
19809 *  |  |  Cameron excess mass for A, IZZ
19810             ENECA1 = DT_ENRG( A, DBLE (IZZ) )
19811 *  |  |  Cameron excess mass for A, Z
19812             DT_ENERGY = DT_ENRG( A, Z )
19813 *  |  |  Use just the difference according to Cameron!!!
19814             DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19815             JZZ    = INWAPS ( KA0 - 1 )
19816             LZZ    = INWAPS ( KA0 - 2 )
19817 *  |  |  +-------------------------------------------------------------*
19818 *  |  |  |  Residual mass for n-decay known:
19819             IF ( KZ0 .GE. JZZ .AND. KZ0 .LE. JZZ + NZGVAX - 1 ) THEN
19820                IZ0    = KZ0 - JZZ + 1
19821                DT_ENERGY = MAX(DT_ENERGY,WAPS (KA0-1,IZ0) + WAPS (1,1)
19822      &                      + DEPUNS )
19823 *  |  |  |
19824 *  |  |  +-------------------------------------------------------------*
19825 *  |  |  |  Residual mass for 2n-decay known:
19826             ELSE IF ( KZ0 .GE. LZZ .AND. KZ0 .LE. LZZ + NZGVAX - 1 )THEN
19827                IZ0    = KZ0 - LZZ + 1
19828                DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO *
19829      &                      ( WAPS (1,1) + DEPUNS ) )
19830 *  |  |  |
19831 *  |  |  +-------------------------------------------------------------*
19832 *  |  |  |  Set it unbound:
19833             ELSE
19834                DT_ENERGY = AINFNT
19835             END IF
19836 *  |  |  |
19837 *  |  |  +-------------------------------------------------------------*
19838 *  |  |
19839 *  |  +----------------------------------------------------------------*
19840 *  |  |  Proceed as usual:
19841          ELSE
19842 *  |  |  Exp. excess mass for A,IZZ
19843             ENEEXP = WAPS ( KA0, 1 )
19844 *  |  |  Cameron excess mass for A, IZZ
19845             ENECA1 = DT_ENRG( A, DBLE (IZZ) )
19846 *  |  |  Cameron excess mass for A, Z
19847             DT_ENERGY = DT_ENRG( A, Z )
19848 *  |  |  Use just the difference according to Cameron!!!
19849             DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19850          END IF
19851 *  |  |
19852 *  |  +----------------------------------------------------------------*
19853 *  |  Be sure not to have a positive energy state:
19854          DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) )
19855          IZ0    = -1
19856          IF ( IFLAG .EQ. 2 ) THEN
19857             DT_ENKNOW = DT_ENERGY
19858             IZZ0   = -1
19859          END IF
19860          RETURN
19861 *  |
19862 *  +-------------------------------------------------------------------*
19863 *  |  Too much proton rich with respect to the stability line:
19864       ELSE IF ( KZ0 .GT. IZZ + NZGVAX - 1 ) THEN
19865 *  |  +----------------------------------------------------------------*
19866 *  |  |  Up to A=Kafree all "bound" masses are known, set it unbound:
19867          IF ( KA0 .LE. KAFREE ) THEN
19868             DT_ENERGY = AINFNT
19869 *  |  |
19870 *  |  +----------------------------------------------------------------*
19871 *  |  |  Up to Kapuns: be sure it is particle unstable
19872          ELSE IF ( KA0 .LE. KAPUNS ) THEN
19873 *  |  |  Exp. excess mass for A,IZZ+NZGVAX-1
19874             ENEEXP = WAPS ( KA0, NZGVAX )
19875 *  |  |  Cameron excess mass for A, IZZ+NZGVAX-1
19876             ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) )
19877 *  |  |  Cameron excess mass for A, Z
19878             DT_ENERGY = DT_ENRG( A, Z )
19879 *  |  |  Use just the difference according to Cameron!!!
19880             DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19881             JZZ    = INWAPS ( KA0 - 1 )
19882             LZZ    = INWAPS ( KA0 - 2 )
19883 *  |  |  +-------------------------------------------------------------*
19884 *  |  |  |  Residual mass for p-decay known:
19885             IF ( KZ0-1 .GE. JZZ .AND. KZ0-1 .LE. JZZ + NZGVAX - 1 ) THEN
19886                IZ0    = KZ0 - 1 - JZZ + 1
19887                DT_ENERGY = MAX (DT_ENERGY, WAPS (KA0-1,IZ0) + WAPS (1,2)
19888      &                      + DEPUNS )
19889 *  |  |  |
19890 *  |  |  +-------------------------------------------------------------*
19891 *  |  |  |  Residual mass for 2p-decay known:
19892             ELSE IF ( KZ0-2 .GE. LZZ .AND. KZ0-2 .LE. LZZ + NZGVAX - 1 )
19893      &         THEN
19894                IZ0    = KZ0 - 2 - LZZ + 1
19895                DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO *
19896      &                      ( WAPS (1,2) + DEPUNS ) )
19897 *  |  |  |
19898 *  |  |  +-------------------------------------------------------------*
19899 *  |  |  |  Set it unbound:
19900             ELSE
19901                DT_ENERGY = AINFNT
19902             END IF
19903 *  |  |  |
19904 *  |  |  +-------------------------------------------------------------*
19905 *  |  |
19906 *  |  +----------------------------------------------------------------*
19907 *  |  |  Proceed as usual:
19908          ELSE
19909 *  |  |  Exp. excess mass for A,IZZ+NZGVAX-1
19910             ENEEXP = WAPS ( KA0, NZGVAX )
19911 *  |  |  Cameron excess mass for A, IZZ+NZGVAX-1
19912             ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) )
19913 *  |  |  Cameron excess mass for A, Z
19914             DT_ENERGY = DT_ENRG( A, Z )
19915 *  |  |  Use just the difference according to Cameron!!!
19916             DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19917          END IF
19918 *  |  |
19919 *  |  +----------------------------------------------------------------*
19920 *  |  Be sure not to have a positive energy state:
19921          DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) )
19922          IZ0    = -1
19923          IF ( IFLAG .EQ. 2 ) THEN
19924             DT_ENKNOW = DT_ENERGY
19925             IZZ0   = -1
19926          END IF
19927          RETURN
19928 *  |
19929 *  +-------------------------------------------------------------------*
19930 *  |  Known isotope or anyway isotope "inside" the stability zone
19931       ELSE
19932          IZ0    = KZ0 - IZZ + 1
19933          DT_ENERGY = WAPS ( KA0, IZ0 )
19934          IF ( IFLAG .EQ. 2 ) IZZ0 = IZ0
19935 *  |  +----------------------------------------------------------------*
19936 *  |  |  Mass not known
19937          IF ( ABS (DT_ENERGY) .LT. ANGLGB .AND. (KA0 .NE. 12 .OR. KZ0
19938      &        .NE. 6) ) THEN
19939             IF ( IFLAG .EQ. 2 ) IZZ0 = -1
19940 *  |  |  +-------------------------------------------------------------*
19941 *  |  |  |  Set it unbound:
19942             IF ( KA0 .LE. KAFREE ) THEN
19943                DT_ENERGY = AINFNT
19944 *  |  |  |
19945 *  |  |  +-------------------------------------------------------------*
19946 *  |  |  |  Try to get a reasonable excess mass:
19947             ELSE
19948                JZ0 = -100
19949 *  |  |  |  +----------------------------------------------------------*
19950 *  |  |  |  |  Check the closest one known:
19951                DO 500 JZZ = 1, NZGVAX
19952                   IF ( ABS ( WAPS (KA0,JZZ) ) .GT. ANGLGB .AND.
19953      &                 ABS (JZZ-IZ0) .LT. ABS (JZ0-IZ0) ) JZ0 = JZZ
19954                   IF ( ABS (JZ0-IZ0) .EQ. 1 ) GO TO 550
19955   500          CONTINUE
19956 *  |  |  |  |
19957 *  |  |  |  +----------------------------------------------------------*
19958   550          CONTINUE
19959 *  |  |  |  Exp. excess mass for A,IZZ+JZ0-1
19960                ENEEXP = WAPS ( KA0, JZ0 )
19961 *  |  |  |  Cameron excess mass for A, IZZ+JZ0-1
19962                ENECA1 = DT_ENRG( A, DBLE (IZZ+JZ0-1) )
19963 *  |  |  |  Cameron excess mass for A, Z
19964                DT_ENERGY = DT_ENRG( A, Z )
19965 *  |  |  |  Use just the difference according to Cameron!!!
19966                DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19967                IZ0    = -1
19968             END IF
19969 *  |  |  |
19970 *  |  |  +-------------------------------------------------------------*
19971 *  |  |  Be sure not to have a positive energy state:
19972             DT_ENERGY = MIN(DT_ENERGY,(A-Z)*WAPS(1,1)+Z*WAPS (1,2) )
19973          END IF
19974 *  |  |
19975 *  |  +----------------------------------------------------------------*
19976          IF ( IFLAG .EQ. 2 ) DT_ENKNOW = DT_ENERGY
19977          RETURN
19978       END IF
19979 *  |
19980 *  +-------------------------------------------------------------------*
19981 *=== End of Function Energy ===========================================*
19982 *     RETURN
19983       END
19984 **
19985
19986 *$ CREATE DT_ENRG.FOR
19987 *COPY DT_ENRG
19988 *                                                                      *
19989 *=== enrg =============================================================*
19990 *                                                                      *
19991       DOUBLE PRECISION FUNCTION DT_ENRG(A,Z)
19992
19993       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19994       SAVE
19995
19996       PARAMETER ( ZERZER = 0.D+00 )
19997       PARAMETER ( ONEONE = 1.D+00 )
19998       PARAMETER ( LUNIN  = 5  )
19999       PARAMETER ( LUNOUT = 6  )
20000 *
20001 *----------------------------------------------------------------------*
20002 *                                                                      *
20003 *     Revised version of the original routine from EVAP:               *
20004 *                                                                      *
20005 *     Created on   15 may 1990     by    Alfredo Ferrari & Paola Sala  *
20006 *                                                   Infn - Milan       *
20007 *                                                                      *
20008 *     Last change on 01-oct-94     by    Alfredo Ferrari               *
20009 *                                                                      *
20010 *     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!     *
20011 *     !!!  It is supposed to be used with the updated atomic   !!!     *
20012 *     !!!                    mass data file                    !!!     *
20013 *     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!     *
20014 *                                                                      *
20015 *----------------------------------------------------------------------*
20016 *
20017       PARAMETER ( O16OLD = 931.145  D+00 )
20018       PARAMETER ( O16NEW = 931.19826D+00 )
20019       PARAMETER ( O16RAT = O16NEW / O16OLD )
20020       PARAMETER ( C12NEW = 931.49432D+00 )
20021       PARAMETER ( ADJUST = -8.322737768178909D-02 )
20022       PARAMETER ( AINFNT = 1.0D+30 )
20023 * (original name: EVA0)
20024       COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
20025      *                FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
20026      *                CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
20027      *                T (4,7), RMASS (297), ALPH (297), BET (297),
20028      *                APRIME (250), IA (6), IZ (6)
20029       LOGICAL LFIRST
20030 CPH      SAVE LFIRST, EXHYDR, EXNEUT
20031       DATA LFIRST / .TRUE. /
20032 *
20033       IF ( LFIRST ) THEN
20034          LFIRST = .FALSE.
20035 **sr 30.6.
20036 C        EXHYDR = DT_ENERGY( ONEONE, ONEONE )
20037 C        EXNEUT = DT_ENERGY( ONEONE, ZERZER )
20038          EXHYDR = A
20039          EXNEUT = Z
20040          DT_ENRG   = -AINFNT
20041          RETURN
20042 **
20043       END IF
20044       IZ0 = NINT (Z)
20045       IF ( IZ0 .LE. 0 ) THEN
20046          DT_ENRG = A * EXNEUT
20047          RETURN
20048       END IF
20049       N   = NINT (A-Z)
20050       IF ( N .LE. 0 ) THEN
20051          DT_ENRG = Z * EXHYDR
20052          RETURN
20053       END IF
20054       AM2ZOA= (A-Z-Z)/A
20055       AM2ZOA=AM2ZOA*AM2ZOA
20056       A13 = RMASS(NINT(A))
20057 *     A13 = A**.3333333333333333D+00
20058       AM13 = 1.D+00/A13
20059       EV=-17.0354D+00*(1.D+00 -1.84619 D+00*AM2ZOA)*A
20060       ES= 25.8357D+00*(1.D+00 -1.712185D+00*AM2ZOA)*
20061      &    (1.D+00 -0.62025D+00*AM13*AM13)*
20062      &    (A13*A13 -.62025D+00)
20063       EC= 0.799D+00*Z*(Z-1.D+00)*AM13*(((1.5772D+00*AM13 +1.2273D+00)*
20064      &    AM13-1.5849D+00)*
20065      &    AM13*AM13 +1.D+00)
20066       EEX= -0.4323D+00*AM13*Z**1.3333333D+00*
20067      &   (((0.49597D+00*AM13 -0.14518D+00)*AM13 -0.57811D+00) * AM13
20068      &   + 1.D+00)
20069       DT_ENRG=8.367D+00*A-0.783D+00*Z +EV +ES +EC +EEX+CAM2(IZ0)+CAM3(N)
20070       DT_ENRG=(DT_ENRG + A * O16OLD ) * O16RAT - A * ( C12NEW - ADJUST )
20071       DT_ENRG  = MIN ( DT_ENRG, Z * EXHYDR + ( A - Z ) * EXNEUT )
20072       RETURN
20073 *=== End of function Enrg =============================================*
20074       END
20075
20076 *$ CREATE DT_INCINI.FOR
20077 *COPY DT_INCINI
20078 *                                                                      *
20079 *=== incini ===========================================================*
20080 *                                                                      *
20081       SUBROUTINE DT_INCINI
20082
20083       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20084       SAVE
20085
20086       PARAMETER ( ZERZER = 0.D+00 )
20087       PARAMETER ( ONEONE = 1.D+00 )
20088       PARAMETER ( TWOTWO = 2.D+00 )
20089       PARAMETER ( THRTHR = 3.D+00 )
20090       PARAMETER ( FOUFOU = 4.D+00 )
20091       PARAMETER ( EIGEIG = 8.D+00 )
20092       PARAMETER ( ANINEN = 9.D+00 )
20093       PARAMETER ( HLFHLF = 0.5D+00 )
20094       PARAMETER ( ONETHI = ONEONE / THRTHR )
20095       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20096       PARAMETER ( PLABRC = 0.197327053        D+00 )
20097       PARAMETER ( AMELCT = 0.51099906         D-03 )
20098       PARAMETER ( AMUGEV = 0.93149432         D+00 )
20099       PARAMETER ( AMPRTN = 0.93827231         D+00 )
20100       PARAMETER ( AMNTRN = 0.93956563         D+00 )
20101       PARAMETER ( AMDEUT = 1.87561339         D+00 )
20102       PARAMETER ( EMVGEV = 1.0                D-03 )
20103
20104       PARAMETER ( LUNOUT = 6  )
20105 *
20106 *----------------------------------------------------------------------*
20107 *                                                                      *
20108 *     Created on  10  june  1990   by    Alfredo Ferrari & Paola Sala  *
20109 *                                                   Infn - Milan       *
20110 *                                                                      *
20111 *     Last change on 02-may-95     by    Alfredo Ferrari               *
20112 *                                                                      *
20113 *                                                                      *
20114 *----------------------------------------------------------------------*
20115 *
20116 * (original name: FHEAVY,FHEAVC)
20117       PARAMETER ( MXHEAV = 100 )
20118       CHARACTER*8 ANHEAV
20119       COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
20120      &                CZHEAV (MXHEAV), TKHEAV (MXHEAV),
20121      &                PHEAVY (MXHEAV), WHEAVY (MXHEAV),
20122      &                AMHEAV  ( 12 ) , AMNHEA  ( 12 ) ,
20123      &                KHEAVY (MXHEAV), ICHEAV  ( 12 ) ,
20124      &                IBHEAV  ( 12 ) , NPHEAV
20125       COMMON /FKFHVC/ ANHEAV  ( 12 )
20126 * (original name: INPFLG)
20127       COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
20128 * (original name: FRBKCM)
20129       PARAMETER ( MXFFBK =     6 )
20130       PARAMETER ( MXZFBK =     9 )
20131       PARAMETER ( MXNFBK =    10 )
20132       PARAMETER ( MXAFBK =    16 )
20133       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
20134       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
20135       PARAMETER ( NXAFBK = MXAFBK + 1 )
20136       PARAMETER ( MXPSST =   300 )
20137       PARAMETER ( MXPSFB = 41000 )
20138       LOGICAL LFRMBK, LNCMSS
20139       COMMON /FKFRBK/  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
20140      &          EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
20141      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
20142      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
20143      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
20144      &          IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
20145      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
20146      &          IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
20147      &          IFBFRB, NBUFBK, LFRMBK, LNCMSS
20148 * (original name: NUCDAT)
20149       PARAMETER ( AMUAMU = AMUGEV )
20150       PARAMETER ( AMPROT = AMPRTN )
20151       PARAMETER ( AMNEUT = AMNTRN )
20152       PARAMETER ( AMELEC = AMELCT )
20153       PARAMETER ( R0NUCL = 1.12        D+00 )
20154       PARAMETER ( RCCOUL = 1.7         D+00 )
20155       PARAMETER ( FERTHO = 14.33       D-09 )
20156       PARAMETER ( EXPEBN = 2.39        D+00 )
20157       PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
20158       PARAMETER ( AMUC12 = AMUGEV - HLFHLF * AMELCT + BEXC12 / 12.D+00 )
20159       PARAMETER ( AMHYDR = AMPRTN + AMELCT  )
20160       PARAMETER ( AMHTON = AMHYDR - AMNTRN  )
20161       PARAMETER ( AMNTOU = AMNTRN - AMUC12  )
20162       PARAMETER ( AMUCSQ = AMUC12 * AMUC12 )
20163       PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 )
20164       PARAMETER ( GAMMIN = 1.0D-06 )
20165       PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN )
20166       PARAMETER ( TVEPSI = GAMMIN / 100.D+00 )
20167       COMMON /FKNDAT/ AV0WEL,     APFRMX,     AEFRMX,     AEFRMA,
20168      &                RDSNUC,     V0WELL (2), PFRMMX (2), EFRMMX (2),
20169      &                EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
20170      &                VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
20171      &                PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
20172      &                EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
20173      &                ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV    ,
20174      &                AMRCSQ    , ATO1O3    , ZTO1O3    , ELBNDE (0:100)
20175 * (original name: PAREVT)
20176       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
20177      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
20178       PARAMETER ( NALLWP = 39   )
20179       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
20180      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
20181      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
20182      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
20183 * (original name: NUCOLD)
20184       COMMON /FKNOLD/ HELP (2), HHLP (2), FTVTH (2), FINCX (2),
20185      &                EKPOLD (2), BBOLD, ZZOLD, SQROLD, ASEASQ,
20186      &                FSPRED, FEX0RD
20187 *
20188       BBOLD  = - 1.D+10
20189       ZZOLD  = - 1.D+10
20190       SQROLD = - 1.D+10
20191       APFRMX = PLABRC * ( ANINEN * PIPIPI / EIGEIG )**ONETHI / R0NUCL
20192       AMNUCL (1) = AMPROT
20193       AMNUCL (2) = AMNEUT
20194       AMNUSQ (1) = AMPROT * AMPROT
20195       AMNUSQ (2) = AMNEUT * AMNEUT
20196       AMNHLP = HLFHLF * ( AMNUCL (1) + AMNUCL (2) )
20197       ASQHLP = AMNHLP**2
20198 *     ASQHLP = HLFHLF * ( AMNUSQ (1) + AMNUSQ (2) )
20199       AEFRMX = SQRT ( ASQHLP + APFRMX**2 ) - AMNHLP
20200       AEFRMA = 0.3D+00 * APFRMX**2 / AMNHLP * ( ONEONE - APFRMX**2 /
20201      &         ( 5.6D+00 * ASQHLP ) )
20202       AV0WEL = AEFRMX + EBNDAV
20203       EBNDNG (1) = EBNDAV
20204       EBNDNG (2) = EBNDAV
20205       AEXC12 = EMVGEV * DT_ENERGY( 12.D+00, 6.D+00 )
20206       CEXC12 = EMVGEV * DT_ENRG( 12.D+00, 6.D+00 )
20207       AMMC12 = 12.D+00 * AMUGEV + AEXC12
20208       AMNC12 = AMMC12 - 6.D+00 * AMELCT + FERTHO * 6.D+00**EXPEBN
20209       AEXO16 = EMVGEV * DT_ENERGY( 16.D+00, 8.D+00 )
20210       CEXO16 = EMVGEV * DT_ENRG( 16.D+00, 8.D+00 )
20211       AMMO16 = 16.D+00 * AMUGEV + AEXO16
20212       AMNO16 = AMMO16 - 8.D+00 * AMELCT + FERTHO * 8.D+00**EXPEBN
20213       AEXS28 = EMVGEV * DT_ENERGY( 28.D+00, 14.D+00 )
20214       CEXS28 = EMVGEV * DT_ENRG( 28.D+00, 14.D+00 )
20215       AMMS28 = 28.D+00 * AMUGEV + AEXS28
20216       AMNS28 = AMMS28 - 14.D+00 * AMELCT + FERTHO * 14.D+00**EXPEBN
20217       AEXC40 = EMVGEV * DT_ENERGY( 40.D+00, 20.D+00 )
20218       CEXC40 = EMVGEV * DT_ENRG( 40.D+00, 20.D+00 )
20219       AMMC40 = 40.D+00 * AMUGEV + AEXC40
20220       AMNC40 = AMMC40 - 20.D+00 * AMELCT + FERTHO * 20.D+00**EXPEBN
20221       AEXF56 = EMVGEV * DT_ENERGY( 56.D+00, 26.D+00 )
20222       CEXF56 = EMVGEV * DT_ENRG( 56.D+00, 26.D+00 )
20223       AMMF56 = 56.D+00 * AMUGEV + AEXF56
20224       AMNF56 = AMMF56 - 26.D+00 * AMELCT + FERTHO * 26.D+00**EXPEBN
20225       AEX107 = EMVGEV * DT_ENERGY( 107.D+00, 47.D+00 )
20226       CEX107 = EMVGEV * DT_ENRG( 107.D+00, 47.D+00 )
20227       AMM107 = 107.D+00 * AMUGEV + AEX107
20228       AMN107 = AMM107 - 47.D+00 * AMELCT + FERTHO * 47.D+00**EXPEBN
20229       AEX132 = EMVGEV * DT_ENERGY( 132.D+00, 54.D+00 )
20230       CEX132 = EMVGEV * DT_ENRG( 132.D+00, 54.D+00 )
20231       AMM132 = 132.D+00 * AMUGEV + AEX132
20232       AMN132 = AMM132 - 54.D+00 * AMELCT + FERTHO * 54.D+00**EXPEBN
20233       AEX181 = EMVGEV * DT_ENERGY( 181.D+00, 73.D+00 )
20234       CEX181 = EMVGEV * DT_ENRG( 181.D+00, 73.D+00 )
20235       AMM181 = 181.D+00 * AMUGEV + AEX181
20236       AMN181 = AMM181 - 73.D+00 * AMELCT + FERTHO * 73.D+00**EXPEBN
20237       AEX208 = EMVGEV * DT_ENERGY( 208.D+00, 82.D+00 )
20238       CEX208 = EMVGEV * DT_ENRG( 208.D+00, 82.D+00 )
20239       AMM208 = 208.D+00 * AMUGEV + AEX208
20240       AMN208 = AMM208 - 82.D+00 * AMELCT + FERTHO * 82.D+00**EXPEBN
20241       AEX238 = EMVGEV * DT_ENERGY( 238.D+00, 92.D+00 )
20242       CEX238 = EMVGEV * DT_ENRG( 238.D+00, 92.D+00 )
20243       AMM238 = 238.D+00 * AMUGEV + AEX238
20244       AMN238 = AMM238 - 92.D+00 * AMELCT + FERTHO * 92.D+00**EXPEBN
20245
20246       AMHEAV (1) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ZERZER )
20247       AMHEAV (2) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ONEONE )
20248       AMHEAV (3) = TWOTWO * AMUGEV
20249      &             + EMVGEV * DT_ENERGY( TWOTWO, ONEONE )
20250       AMHEAV (4) = THRTHR * AMUGEV
20251      &             + EMVGEV * DT_ENERGY( THRTHR, ONEONE )
20252       AMHEAV (5) = THRTHR * AMUGEV
20253      &             + EMVGEV * DT_ENERGY( THRTHR, TWOTWO )
20254       AMHEAV (6) = FOUFOU * AMUGEV
20255      &             + EMVGEV * DT_ENERGY( FOUFOU, TWOTWO )
20256       ELBNDE (0) = ZERZER
20257       ELBNDE (1) = 13.6D-09
20258       DO 2000 IZ = 2, 100
20259          ELBNDE ( IZ ) = FERTHO * DBLE ( IZ )**EXPEBN
20260 2000  CONTINUE
20261       AMNHEA (1) = AMHEAV (1) + ELBNDE (0)
20262       AMNHEA (2) = AMHEAV (2) - AMELCT + ELBNDE (1)
20263       AMNHEA (3) = AMHEAV (3) - AMELCT + ELBNDE (1)
20264       AMNHEA (4) = AMHEAV (4) - AMELCT + ELBNDE (1)
20265       AMNHEA (5) = AMHEAV (5) - TWOTWO * AMELCT + ELBNDE (2)
20266       AMNHEA (6) = AMHEAV (6) - TWOTWO * AMELCT + ELBNDE (2)
20267       IF ( LEVPRT ) THEN
20268          WRITE ( LUNOUT, * )' **** Evaporation from residual nucleus',
20269      &                      ' activated **** '
20270          IF ( LDEEXG ) WRITE ( LUNOUT, * )' **** Deexcitation gamma',
20271      &                      ' production activated **** '
20272 **sr 18.5.95
20273 * commented, since obsolete
20274 C        IF ( LHEAVY ) WRITE ( LUNOUT, * )' **** Evaporated "heavies"',
20275 C    &                      ' transport activated **** '
20276          IF ( IFISS .GT. 0 )
20277      &                 WRITE ( LUNOUT, * )' **** High Energy fission ',
20278      &                      ' requested & activated **** '
20279          IF ( LFRMBK )
20280      &                 WRITE ( LUNOUT, * )' **** Fermi Break Up ',
20281      &                      ' requested & activated **** '
20282          IF ( LFRMBK ) CALL DT_FRBKIN(.FALSE.,.FALSE.)
20283       ELSE
20284          LDEEXG = .FALSE.
20285          LHEAVY = .FALSE.
20286          LFRMBK = .FALSE.
20287          IFISS  = 0
20288       END IF
20289       RETURN
20290 *=== End of subroutine incini =========================================*
20291       END
20292
20293 *$ CREATE DT_STALIN.FOR
20294 *COPY DT_STALIN
20295 *                                                                      *
20296 *=== stalin ===========================================================*
20297 *                                                                      *
20298       SUBROUTINE DT_STALIN
20299
20300       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20301       SAVE
20302       PARAMETER ( ANGLGB = 5.0D-16 )
20303       PARAMETER ( ZERZER = 0.D+00 )
20304       PARAMETER ( ONEONE = 1.D+00 )
20305       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20306       PARAMETER ( AMUGEV = 0.93149432         D+00 )
20307       PARAMETER ( EMVGEV = 1.0                D-03 )
20308       PARAMETER ( NSTBIS = 304  )
20309       PARAMETER ( LUNIN  = 5  )
20310       PARAMETER ( LUNOUT = 6  )
20311 *
20312 *----------------------------------------------------------------------*
20313 *                                                                      *
20314 *     STAbility LINe calculation:                                      *
20315 *                                                                      *
20316 *     Created on 04 december 1992  by    Alfredo Ferrari & Paola Sala  *
20317 *                                                   Infn - Milan       *
20318 *                                                                      *
20319 *     Last change on 04-dec-92     by    Alfredo Ferrari               *
20320 *                                                                      *
20321 *                                                                      *
20322 *----------------------------------------------------------------------*
20323 *
20324 * (original name: ISOTOP)
20325       PARAMETER ( NAMSMX = 270 )
20326       PARAMETER ( NZGVAX =  15 )
20327       PARAMETER ( NISMMX = 574 )
20328       COMMON /FKISOT/ WAPS   (NAMSMX,NZGVAX),  T12NUC (NAMSMX,NZGVAX),
20329      &                WAPISM (NISMMX), T12ISM (NISMMX),
20330      &                ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
20331      &                AMSSST (100)  , ISOMNM (NSTBIS), ISONDX (2,100),
20332      &                JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
20333      &                INWAPS (NAMSMX), JSPISM (NISMMX),
20334      &                JPTISM (NISMMX), IZWISM (NISMMX),
20335      &                INWISM (0:NAMSMX)
20336 *
20337       DIMENSION ZNORM (260)
20338 *  +-------------------------------------------------------------------*
20339 *  |
20340       DO 1000 IZ=1,100
20341          DO 500 J=1,2
20342             ASTLIN (J,IZ) = ZERZER
20343   500    CONTINUE
20344  1000 CONTINUE
20345 *  |
20346 *  +-------------------------------------------------------------------*
20347 *  +-------------------------------------------------------------------*
20348 *  |
20349       DO 2000 IA=1,260
20350          ZNORM (IA) = ZERZER
20351          DO 1500 J=1,2
20352             ZSTLIN (J,IA) = ZERZER
20353  1500    CONTINUE
20354  2000 CONTINUE
20355 *  |
20356 *  +-------------------------------------------------------------------*
20357 *  +-------------------------------------------------------------------*
20358 *  |  Loop on the Atomic Number
20359       DO 3000 IZ=1,100
20360          AMSSST (IZ) = ZERZER
20361          ANORM       = ONEONE
20362          ZTAR        = IZ
20363 *  |  +----------------------------------------------------------------*
20364 *  |  |    Loop on the stable isotopes
20365          DO 2500 IS = ISONDX (1,IZ), ISONDX (2,IZ)
20366             IA = ISOMNM (IS)
20367             ASTLIN (1,IZ) = ASTLIN (1,IZ) + ABUISO (IS) * IA
20368             ASTLIN (2,IZ) = ASTLIN (2,IZ) + ABUISO (IS) * IA**2
20369             ZNORM    (IA) = ZNORM (IA) + ABUISO (IS)
20370             ZSTLIN (1,IA) = ZSTLIN (1,IA) + ABUISO (IS) * IZ
20371             ZSTLIN (2,IA) = ZSTLIN (2,IA) + ABUISO (IS) * IZ**2
20372             AHELP  = IA
20373             IF ( AHELP .LE. 1.00001D+00 ) THEN
20374                ANORM = ONEONE / ( ONEONE - ABUISO (IS) )
20375                GO TO 2500
20376             END IF
20377             AMSSST (IZ) = ABUISO (IS) * ( AHELP * AMUGEV
20378      &                  + EMVGEV * DT_ENERGY(AHELP,ZTAR) ) + AMSSST (IZ)
20379  2500    CONTINUE
20380 *  |  |
20381 *  |  +----------------------------------------------------------------*
20382          AMSSST (IZ) = ANORM * AMSSST (IZ) / AMUGEV
20383 *  |  Normalize and print A_stab versus Z data:
20384          ASTLIN (2,IZ) = MAX ( SQRT (ASTLIN(2,IZ)-ASTLIN(1,IZ)**2),
20385      &                         0.5D+00 )
20386 *        WRITE (LUNOUT,*)'  Z:',IZ,' A_stab:',SNGL(ASTLIN(1,IZ)),
20387 *    &                   '  Sigma_st',SNGL(ASTLIN(2,IZ))
20388  3000 CONTINUE
20389 *  |
20390 *  +-------------------------------------------------------------------*
20391 *  +-------------------------------------------------------------------*
20392 *  |  Normalize and print Z_stab versus A data:
20393       DO 4000 IA=1,260
20394          ZSTLIN (1,IA) = ZSTLIN (1,IA) / MAX ( ZNORM (IA), 1.D-10 )
20395          ZSTLIN (2,IA) = ZSTLIN (2,IA) / MAX ( ZNORM (IA), 1.D-10 )
20396          ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ZSTLIN (1,IA)**2 )
20397          IF ( ZNORM (IA) .GT. ANGLGB )
20398 **sr 2.11. avoid underflows at Pentium
20399      &      ZSTLIN (2,IA) =
20400      &               MAX ( SQRT ( ABS(ZSTLIN(2,IA)-ZSTLIN(1,IA)**2) ),
20401 C    &      ZSTLIN (2,IA) = MAX ( SQRT (ZSTLIN(2,IA)-ZSTLIN(1,IA)**2),
20402      &                            0.3D+00 )
20403  4000 CONTINUE
20404 *  |
20405 *  +-------------------------------------------------------------------*
20406 *  +-------------------------------------------------------------------*
20407 *  |  Normalize and print Z_stab versus A data:
20408       DO 5000 IA=1,260
20409          IF ( ZNORM (IA) .LE. ANGLGB ) THEN
20410             DO 4200 JA = IA-1,1,-1
20411                IF ( ZNORM (JA) .GT. ANGLGB ) THEN
20412                   IA1 = JA
20413                   GO TO 4300
20414                END IF
20415  4200       CONTINUE
20416  4300       CONTINUE
20417             DO 4400 JA = IA+1,260
20418                IF ( ZNORM (JA) .GT. ANGLGB ) THEN
20419                   IA2 = JA
20420                   GO TO 4500
20421                END IF
20422  4400       CONTINUE
20423             IA2 = IA1
20424             IA1 = IA1 - 1
20425  4500       CONTINUE
20426             ZSTLIN (1,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1)
20427      &                    * ( ZSTLIN (1,IA2) - ZSTLIN (1,IA1) )
20428      &                    + ZSTLIN (1,IA1)
20429             ZSTLIN (2,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1)
20430      &                    * ( ZSTLIN (2,IA2) - ZSTLIN (2,IA1) )
20431      &                    + ZSTLIN (2,IA1)
20432          END IF
20433          IZ = MIN ( 100, NINT (ZSTLIN(1,IA)) )
20434          ATOZ = IZ / ASTLIN (1,IZ)
20435          ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ATOZ * ASTLIN (2,IZ) )
20436 *        WRITE (LUNOUT,*)'  A:',IA,' Z_stab:',SNGL(ZSTLIN(1,IA)),
20437 *    &                   '  Sigma_st',SNGL(ZSTLIN(2,IA))
20438  5000 CONTINUE
20439 *  |
20440 *  +-------------------------------------------------------------------*
20441       RETURN
20442       END
20443
20444 *$ CREATE DT_BERTTP.FOR
20445 *COPY DT_BERTTP
20446 *
20447 *=== berttp ===========================================================*
20448 *                                                                      *
20449       SUBROUTINE DT_BERTTP
20450
20451       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20452       SAVE
20453
20454       PARAMETER ( CSNNRM = 2.0D-15 )
20455       PARAMETER ( ZERZER = 0.D+00 )
20456       PARAMETER ( ONEONE = 1.D+00 )
20457       PARAMETER ( THRTHR = 3.D+00 )
20458       PARAMETER ( SIXSIX = 6.D+00 )
20459       PARAMETER ( ONETHI = ONEONE / THRTHR )
20460       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20461       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
20462       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
20463       PARAMETER ( EMVGEV = 1.0                D-03 )
20464
20465       PARAMETER ( NSTBIS = 304  )
20466
20467       PARAMETER ( LUNIN  = 5  )
20468       PARAMETER ( LUNOUT = 6  )
20469 **sr 19.5. set error output-unit from 15 to 6
20470       PARAMETER ( LUNERR = 6  )
20471 C---------------------------------------------------------------------
20472 C SUBNAME = DT_BERTTP --- READ BERTINI DATA
20473 C---------------------------------------------------------------------
20474 C     ---------------------------------- I-N-C DATA
20475 C     COMMON R8(2127),R4(64),CRSC(600,4),R8B(336),CS(29849)
20476 C     REAL*8 R8,R8B,CRSC,CS
20477 C     REAL*4 R4
20478 C     --------------------------------- EVAPORATION DATA
20479 * (original name: COOKCM)
20480       PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 )
20481       LOGICAL LDEFOZ, LDEFON
20482       PARAMETER ( INCOOK = 150, IZCOOK = 98 )
20483       COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN,
20484      &                SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK),
20485      &                PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK)
20486 * (original name: EVA0)
20487       COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
20488      *                FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
20489      *                CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
20490      *                T (4,7), RMASS (297), ALPH (297), BET (297),
20491      *                APRIME (250), IA (6), IZ (6)
20492 * (original name: FRBKCM)
20493       PARAMETER ( MXFFBK =     6 )
20494       PARAMETER ( MXZFBK =     9 )
20495       PARAMETER ( MXNFBK =    10 )
20496       PARAMETER ( MXAFBK =    16 )
20497       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
20498       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
20499       PARAMETER ( NXAFBK = MXAFBK + 1 )
20500       PARAMETER ( MXPSST =   300 )
20501       PARAMETER ( MXPSFB = 41000 )
20502       LOGICAL LFRMBK, LNCMSS
20503       COMMON /FKFRBK/  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
20504      &          EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
20505      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
20506      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
20507      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
20508      &          IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
20509      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
20510      &          IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
20511      &          IFBFRB, NBUFBK, LFRMBK, LNCMSS
20512 * (original name: HETTP)
20513       COMMON /FKHETP/  NHSTP,NBERTP,IOSUB,INSRS
20514 * (original name: INPFLG)
20515       COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
20516 * (original name: ISOTOP)
20517       PARAMETER ( NAMSMX = 270 )
20518       PARAMETER ( NZGVAX =  15 )
20519       PARAMETER ( NISMMX = 574 )
20520       COMMON /FKISOT/ WAPS   (NAMSMX,NZGVAX),  T12NUC (NAMSMX,NZGVAX),
20521      &                WAPISM (NISMMX), T12ISM (NISMMX),
20522      &                ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
20523      &                AMSSST (100)  , ISOMNM (NSTBIS), ISONDX (2,100),
20524      &                JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
20525      &                INWAPS (NAMSMX), JSPISM (NISMMX),
20526      &                JPTISM (NISMMX), IZWISM (NISMMX),
20527      &                INWISM (0:NAMSMX)
20528 * (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII)
20529       PARAMETER ( PI     = PIPIPI )
20530       PARAMETER ( PISQ   = PIPISQ )
20531       PARAMETER ( SKTOHL = 0.5456645846610345D+00 )
20532       PARAMETER ( RZNUCL = 1.12        D+00 )
20533       PARAMETER ( RMSPRO = 0.8         D+00 )
20534       PARAMETER ( R0PROT = RMSPRO / SQRT12  )
20535       PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT
20536      &          / R0PROT )
20537       PARAMETER ( RLLE04 = RZNUCL )
20538       PARAMETER ( RLLE16 = RZNUCL )
20539       PARAMETER ( RLGT16 = RZNUCL )
20540       PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 )
20541       PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 )
20542       PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 )
20543       PARAMETER ( SKLE04 = 1.4D+00 )
20544       PARAMETER ( SKLE16 = 1.9D+00 )
20545       PARAMETER ( SKGT16 = 2.4D+00 )
20546       PARAMETER ( HLLE04 = SKTOHL * SKLE04 )
20547       PARAMETER ( HLLE16 = SKTOHL * SKLE16 )
20548       PARAMETER ( HLGT16 = SKTOHL * SKGT16 )
20549       PARAMETER ( ALPHA0 = 0.1D+00 )
20550       PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 )
20551       PARAMETER ( GAMSK0 = 0.9D+00 )
20552       PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 )
20553       PARAMETER ( POTME0 = 0.6666666666666667D+00 )
20554       PARAMETER ( POTBA0 = 1.D+00 )
20555       PARAMETER ( PNFRAT = 1.533D+00 )
20556       PARAMETER ( RADPIM = 0.035D+00 )
20557       PARAMETER ( RDPMHL = 14.D+00   )
20558       PARAMETER ( APMRST = 4.D+00 / 44.D+00 )
20559       PARAMETER ( APMPRO = 1.D+00 / 6.D+00 )
20560       PARAMETER ( APPPRO = 5.D+00 / 6.D+00 )
20561       PARAMETER ( AP0PFS = 0.5D+00 )
20562       PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 )
20563       PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 )
20564       PARAMETER ( XPAUCO = 1.88495407241652 D+00 )
20565       PARAMETER ( MXSCIN = 50     )
20566       LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY,
20567      &        LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC
20568       COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260),
20569      &                RADTAB (2:260), SKITAB (2:260), HALTAB (2:260),
20570      &                SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260),
20571      &                CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260),
20572      &                PFRTAB (2:260)
20573       COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP,
20574      &                ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO,
20575      &                RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR,
20576      &                YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN,
20577      &                RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM,
20578      &                PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2,
20579      &                PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT,
20580      &                BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2,
20581      &                YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3,
20582      &                XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC,
20583      &                SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ,
20584      &                R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE,
20585      &                PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY,
20586      &                EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ,
20587      &                PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM,
20588      &                EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3,
20589      &                PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM,
20590      &                BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN
20591       COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2),
20592      &                RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN,
20593      &                EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF,
20594      &                BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC,
20595      &                WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES,
20596      &                POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND,
20597      &                BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4),
20598      &                SIGPAB (3), SIGNAB (3), HHLP   (2), FORTOT (2),
20599      &                FPNBLC, DPNBLC, FFTFLG, IFTFLG,
20600      &                IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2,
20601      &                KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3,
20602      &                NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM,
20603      &                IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ,
20604      &                LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC
20605       COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT
20606       COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN),
20607      &                YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN),
20608      &                AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX,
20609      &                NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN),
20610      &                NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN),
20611      &                ISCTYP (0:MXSCIN), NUSCIN, NEXPEM,
20612      &                LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH,
20613      &                LNCDCY, LNUSCT
20614       DIMENSION AWSTAB (2:260), SIGMAB (3)
20615       EQUIVALENCE ( DEFPRO, DEFNUC (1) )
20616       EQUIVALENCE ( DEFNEU, DEFNUC (2) )
20617       EQUIVALENCE ( RHOIPP, RHONCP (1) )
20618       EQUIVALENCE ( RHOINP, RHONCP (2) )
20619       EQUIVALENCE ( RHOIP2, RHONC2 (1) )
20620       EQUIVALENCE ( RHOIN2, RHONC2 (2) )
20621       EQUIVALENCE ( RHOIP3, RHONC3 (1) )
20622       EQUIVALENCE ( RHOIN3, RHONC3 (2) )
20623       EQUIVALENCE ( RHOIPT, RHONCT (1) )
20624       EQUIVALENCE ( RHOINT, RHONCT (2) )
20625       EQUIVALENCE ( OMALHL, SK3PAR )
20626       EQUIVALENCE ( ALPHAL, HABPAR )
20627       EQUIVALENCE ( ALPTAB (2), AWSTAB (2) )
20628       EQUIVALENCE ( SIGMPE, SIGMPR (1) )
20629       EQUIVALENCE ( SIGMPC, SIGMPR (2) )
20630       EQUIVALENCE ( SIGMPI, SIGMPR (3) )
20631       EQUIVALENCE ( SIGMPA, SIGMPR (4) )
20632       EQUIVALENCE ( SIGMNE, SIGMNU (1) )
20633       EQUIVALENCE ( SIGMNC, SIGMNU (2) )
20634       EQUIVALENCE ( SIGMNI, SIGMNU (3) )
20635       EQUIVALENCE ( SIGMNA, SIGMNU (4) )
20636       EQUIVALENCE ( SIGMA2, SIGPAB (1) )
20637       EQUIVALENCE ( SIGMA3, SIGPAB (2) )
20638       EQUIVALENCE ( SIGMAS, SIGPAB (3) )
20639       EQUIVALENCE ( SIGPAB (1), SIGMAB (1) )
20640 * (original name: NUCLEV)
20641       LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL
20642       COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2),
20643      &                DEFMAG (2), ENNCLV (160,2), RANCLV (160,2),
20644      &                CUMRAD (0:160,2), RUSNUC (2),
20645      &                ENPLVL (114), ENNLVL(164), JUSNUC (160,2),
20646      &                NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2),
20647      &                NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2),
20648      &                JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8),
20649      &                MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2),
20650      &                NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL,
20651      &                LFLVSL, LRLVSL, LEQSBL
20652       DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8),
20653      &          MGSSPR (19) , MGSSNE (25)
20654       EQUIVALENCE ( RUSNUC (1), RUSPRO )
20655       EQUIVALENCE ( RUSNUC (2), RUSNEU )
20656       EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) )
20657       EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) )
20658       EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) )
20659       EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) )
20660       EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) )
20661       EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) )
20662       EQUIVALENCE ( NTANUC (1), NTAPRO )
20663       EQUIVALENCE ( NTANUC (2), NTANEU )
20664       EQUIVALENCE ( NAVNUC (1), NAVPRO )
20665       EQUIVALENCE ( NAVNUC (2), NAVNEU )
20666       EQUIVALENCE ( NLSNUC (1), NLSPRO )
20667       EQUIVALENCE ( NLSNUC (2), NLSNEU )
20668       EQUIVALENCE ( NCONUC (1), NCOPRO )
20669       EQUIVALENCE ( NCONUC (2), NCONEU )
20670       EQUIVALENCE ( NSKNUC (1), NSKPRO )
20671       EQUIVALENCE ( NSKNUC (2), NSKNEU )
20672       EQUIVALENCE ( NHANUC (1), NHAPRO )
20673       EQUIVALENCE ( NHANUC (2), NHANEU )
20674       EQUIVALENCE ( NUSNUC (1), NUSPRO )
20675       EQUIVALENCE ( NUSNUC (2), NUSNEU )
20676       EQUIVALENCE ( NACNUC (1), NACPRO )
20677       EQUIVALENCE ( NACNUC (2), NACNEU )
20678       EQUIVALENCE ( JMXNUC (1), JMXPRO )
20679       EQUIVALENCE ( JMXNUC (2), JMXNEU )
20680       EQUIVALENCE ( MAGNUC (1), MAGPRO )
20681       EQUIVALENCE ( MAGNUC (2), MAGNEU )
20682 * (original name: PAREVT)
20683       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
20684      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
20685       PARAMETER ( NALLWP = 39   )
20686       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
20687      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
20688      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
20689      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
20690 * (original name: XSEPAR)
20691       COMMON /FKXSEP/ AANXSE (100), BBNXSE (100), CCNXSE (100),
20692      &                DDNXSE (100), EENXSE (100), ZZNXSE (100),
20693      &                EMNXSE (100), XMNXSE (100),
20694      &                AAPXSE (100), BBPXSE (100), CCPXSE (100),
20695      &                DDPXSE (100), EEPXSE (100), FFPXSE (100),
20696      &                ZZPXSE (100), EMPXSE (100), XMPXSE (100)
20697
20698 C---------------------------------------------------------------------
20699 **sr 17.5.95
20700 * modified for use in DPMJET
20701 C     WRITE( LUNOUT,'(A,I2)')
20702 C    & ' *** Reading evaporation and nuclear data from unit: ', NBERTP
20703 C     REWIND NBERTP
20704       IF (LEVPRT) WRITE(LUNOUT,1000)
20705  1000 FORMAT(/,1X,'BERTTP:',4X,'Initialization of evaporation module',
20706      &       /,12X,'------------------------------------',/)
20707       NBERNW = 23
20708 CPH      OPEN (UNIT=NBERNW,FILE='dpmjet.dat',STATUS='UNKNOWN')
20709
20710 **sr 17.5.
20711 *!!!! changed to be able to read the ASCII !!!!
20712 **
20713 C A. Ferrari: first of all read isotopic data
20714       READ (NBERNW,*) ISONDX
20715       READ (NBERNW,*) ISOMNM
20716       READ (NBERNW,*) ABUISO
20717 C     READ (NBERTP) ISONDX
20718 C     READ (NBERTP) ISOMNM
20719 C     READ (NBERTP) ABUISO
20720       DO 1 I=1,4
20721 C        READ  (NBERTP) (CRSC(J,I),J=1,600)
20722 C A. Ferrari: commented also the dummy read to save disk space
20723 C        READ  (NBERTP)
20724     1 CONTINUE
20725 C     READ  (NBERTP) CS
20726 C A. Ferrari: commented also the dummy read to save disk space
20727 C     READ  (NBERTP)
20728 C---------------------------------------------------------------------
20729       READ (NBERNW,*) (P0(I),P1(I),P2(I),I=1,1001)
20730       READ (NBERNW,*) IA,IZ
20731       DO 2 I=1,6
20732          FLA(I)=IA(I)
20733          FLZ(I)=IZ(I)
20734     2 CONTINUE
20735       READ (NBERNW,*) RHO,OMEGA
20736       READ (NBERNW,*) EXMASS
20737       READ (NBERNW,*) CAM2
20738       READ (NBERNW,*) CAM3
20739       READ (NBERNW,*) CAM4
20740       READ (NBERNW,*) CAM5
20741       READ (NBERNW,*) ((T(I,J),J=1,7),I=1,3)
20742       DO 3 I=1,7
20743          T(4,I) = ZERZER
20744     3 CONTINUE
20745       READ (NBERNW,*) RMASS
20746       READ (NBERNW,*) ALPH
20747       READ (NBERNW,*) BET
20748       READ (NBERNW,*) INWAPS
20749       READ (NBERNW,*) WAPS
20750       READ (NBERNW,*) T12NUC
20751       READ (NBERNW,*) JSPNUC
20752       READ (NBERNW,*) JPTNUC
20753       READ (NBERNW,*) INWISM
20754       READ (NBERNW,*) IZWISM
20755       READ (NBERNW,*) WAPISM
20756       READ (NBERNW,*) T12ISM
20757       READ (NBERNW,*) JSPISM
20758       READ (NBERNW,*) JPTISM
20759       READ (NBERNW,*) APRIME
20760       IF (LEVPRT)
20761      &WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***'
20762       READ (NBERNW,*) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP
20763       IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR.
20764      &     ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN
20765          WRITE (LUNOUT,*)
20766      &         ' *** Inconsistent Nuclear Geometry data on file ***'
20767          STOP
20768       END IF
20769       READ (NBERNW,*) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB,
20770      &              EKATAB, PFATAB, PFRTAB
20771       READ (NBERNW,*) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE,
20772      &              EMNXSE, XMNXSE
20773       READ (NBERNW,*) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE,
20774      &              ZZPXSE, EMPXSE, XMPXSE
20775 *  Data about Fermi-breakup:
20776       READ (NBERNW,*) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF
20777       IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE.
20778      &     MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN
20779          WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data',
20780      &                   ' in the Nuclear Data file ***'
20781          STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA'
20782       END IF
20783       READ (NBERNW,*) IFRBKN
20784       READ (NBERNW,*) IFRBKZ
20785       READ (NBERNW,*) IFBKSP
20786       READ (NBERNW,*) IFBKST
20787       READ (NBERNW,*) EEXFBK
20788
20789       CLOSE (UNIT=NBERNW)
20790
20791 C     READ (NBERTP) (P0(I),P1(I),P2(I),I=1,1001)
20792 C     READ (NBERTP) IA,IZ
20793 C     DO 2 I=1,6
20794 C        FLA(I)=IA(I)
20795 C        FLZ(I)=IZ(I)
20796 C   2 CONTINUE
20797 C     READ (NBERTP) RHO,OMEGA
20798 C     READ (NBERTP) EXMASS
20799 C     READ (NBERTP) CAM2
20800 C     READ (NBERTP) CAM3
20801 C     READ (NBERTP) CAM4
20802 C     READ (NBERTP) CAM5
20803 C     READ (NBERTP) ((T(I,J),J=1,7),I=1,3)
20804 C     DO 3 I=1,7
20805 C        T(4,I) = ZERZER
20806 C   3 CONTINUE
20807 C     READ (NBERTP) RMASS
20808 C     READ (NBERTP) ALPH
20809 C     READ (NBERTP) BET
20810 C     READ (NBERTP) INWAPS
20811 C     READ (NBERTP) WAPS
20812 C     READ (NBERTP) T12NUC
20813 C     READ (NBERTP) JSPNUC
20814 C     READ (NBERTP) JPTNUC
20815 C     READ (NBERTP) INWISM
20816 C     READ (NBERTP) IZWISM
20817 C     READ (NBERTP) WAPISM
20818 C     READ (NBERTP) T12ISM
20819 C     READ (NBERTP) JSPISM
20820 C     READ (NBERTP) JPTISM
20821 C     READ (NBERTP) APRIME
20822 C     WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***'
20823 C     READ (NBERTP) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP
20824 C     IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR.
20825 C    &     ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN
20826 C        WRITE (LUNOUT,*)
20827 C    &         ' *** Inconsistent Nuclear Geometry data on file ***'
20828 C        STOP
20829 C     END IF
20830 C     READ (NBERTP) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB,
20831 C    &              EKATAB, PFATAB, PFRTAB
20832 C     READ (NBERTP) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE,
20833 C    &              EMNXSE, XMNXSE
20834 C     READ (NBERTP) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE,
20835 C    &              ZZPXSE, EMPXSE, XMPXSE
20836 *  Data about Fermi-breakup:
20837 C     READ (NBERTP) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF
20838 C     IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE.
20839 C    &     MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN
20840 C        WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data',
20841 C    &                   ' in the Nuclear Data file ***'
20842 C        STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA'
20843 C     END IF
20844 C     READ (NBERTP) IFRBKN
20845 C     READ (NBERTP) IFRBKZ
20846 C     READ (NBERTP) IFBKSP
20847 C     READ (NBERTP) IFBKST
20848 C     READ (NBERTP) EEXFBK
20849 C     CLOSE (UNIT=NBERTP)
20850       DO 100 JZ = 1, 130
20851          SHENUC ( JZ, 1 ) = EMVGEV * ( CAM2 (JZ) + CAM4 (JZ) )
20852   100 CONTINUE
20853       DO 200 JA = 1, 200
20854          SHENUC ( JA, 2 ) = EMVGEV * ( CAM3 (JA) + CAM5 (JA) )
20855   200 CONTINUE
20856       CALL DT_STALIN
20857       IF ( ILVMOD .LE. 0 ) THEN
20858          ILVMOD = IB0
20859       ELSE
20860          IB0 = ILVMOD
20861       END IF
20862       IF ( LLVMOD ) THEN
20863          DO 300 JZ = 1, IZCOOK
20864             CAM4 (JZ) = PZCOOK (JZ)
20865   300    CONTINUE
20866          DO 400 JN = 1, INCOOK
20867             CAM5 (JN) = PNCOOK (JZ)
20868   400    CONTINUE
20869       END IF
20870 **sr
20871       IF (LEVPRT) THEN
20872          WRITE (LUNOUT,*)
20873          IF ( ILVMOD .EQ. 1 ) THEN
20874             WRITE (LUNOUT,*)
20875      &   ' **** Standard EVAP T=0 level density used ****'
20876          ELSE IF ( ILVMOD .EQ. 2 ) THEN
20877             WRITE (LUNOUT,*)
20878      &   ' **** Gilbert & Cameron T=0 N,Z-dep. level density used ****'
20879          ELSE IF ( ILVMOD .EQ. 3 ) THEN
20880             WRITE (LUNOUT,*)
20881      &      ' **** Julich A-dependent level density used ****'
20882          ELSE IF ( ILVMOD .EQ. 4 ) THEN
20883             WRITE (LUNOUT,*)
20884      &   ' **** Brancazio & Cameron T=0 N,Z-dep. level density used',
20885      &                                                          ' ****'
20886          ELSE
20887             WRITE (LUNOUT,*)
20888      &   ' **** Unknown T=0 level density option requested ****'
20889             STOP 'BERTTP-ILVMOD'
20890          END IF
20891          IF ( JLVMOD .LE. 0 ) THEN
20892             GAMIGN = ZERZER
20893             WRITE (LUNOUT,*)
20894      &   ' **** No Excitation en. dependence for level densities ****'
20895          ELSE IF ( JLVMOD .EQ. 1 ) THEN
20896             WRITE (LUNOUT,*)
20897      &   ' **** Ignyatuk (1975, 1st) level density en. dep. used ****'
20898             WRITE (LUNOUT,*)
20899      &   ' **** with Ignyatuk (1975, 1st) set of parameters for T=oo',
20900      &                                                        ' ****'
20901             GAMIGN = 0.054D+00
20902             BETIGN = -6.3 D-05
20903             ALPIGN = 0.154D+00
20904             POWIGN = ZERZER
20905          ELSE IF ( JLVMOD .EQ. 2 ) THEN
20906             WRITE (LUNOUT,*)
20907      &   ' ****   Ignyatuk (1975, 1st) level density en. dep. used ****'
20908             WRITE (LUNOUT,*)
20909      &   ' **** with UNKNOWN set of parameters for T=oo ****'
20910             STOP 'BERTTP-JLVMOD'
20911          ELSE IF ( JLVMOD .EQ. 3 ) THEN
20912             WRITE (LUNOUT,*)
20913      &   ' ****   Ignyatuk (1975, 1st) level density en. dep. used ****'
20914             WRITE (LUNOUT,*)
20915      &   ' **** with UNKNOWN set of parameters for T=oo ****'
20916             STOP 'BERTTP-JLVMOD'
20917          ELSE IF ( JLVMOD .EQ. 4 ) THEN
20918             WRITE (LUNOUT,*)
20919      &   ' ****   Ignyatuk (1975, 2nd) level density en. dep. used ****'
20920             WRITE (LUNOUT,*)
20921      &   ' **** with Ignyatuk (1975, 2nd) set of parameters for T=oo',
20922      &                                                        ' ****'
20923             GAMIGN = 0.054D+00
20924             BETIGN = 0.162D+00
20925             ALPIGN = 0.114D+00
20926             POWIGN = -ONETHI
20927          ELSE IF ( JLVMOD .EQ. 5 ) THEN
20928             WRITE (LUNOUT,*)
20929      &   ' ****  Ignyatuk (1975, 2nd) level density en. dep. used  ****'
20930             WRITE (LUNOUT,*)
20931      &   ' **** with Iljinov & Mebel 1st set of parameters for T=oo****'
20932             GAMIGN = 0.051D+00
20933             BETIGN = 0.098D+00
20934             ALPIGN = 0.114D+00
20935             POWIGN = -ONETHI
20936          ELSE IF ( JLVMOD .EQ. 6 ) THEN
20937             WRITE (LUNOUT,*)
20938      &   ' ****   Ignyatuk (1975, 2nd) level density en. dep. used ****'
20939             WRITE (LUNOUT,*)
20940      &   ' **** with Iljinov & Mebel 2nd set of parameters for T=oo****'
20941             GAMIGN = -0.46D+00
20942             BETIGN = 0.107D+00
20943             ALPIGN = 0.111D+00
20944             POWIGN = -ONETHI
20945          ELSE IF ( JLVMOD .EQ. 7 ) THEN
20946             WRITE (LUNOUT,*)
20947      &   ' ****   Ignyatuk (1975, 2nd) level density en. dep. used ****'
20948             WRITE (LUNOUT,*)
20949      &   ' **** with Iljinov & Mebel 3rd set of parameters for T=oo****'
20950             GAMIGN = 0.059D+00
20951             BETIGN = 0.257D+00
20952             ALPIGN = 0.072D+00
20953             POWIGN = -ONETHI
20954          ELSE IF ( JLVMOD .EQ. 8 ) THEN
20955             WRITE (LUNOUT,*)
20956      &   ' ****   Ignyatuk (1975, 2nd) level density en. dep. used ****'
20957             WRITE (LUNOUT,*)
20958      &   ' **** with Iljinov & Mebel 4th set of parameters for T=oo****'
20959             GAMIGN = -0.37D+00
20960             BETIGN = 0.229D+00
20961             ALPIGN = 0.077D+00
20962             POWIGN = -ONETHI
20963          ELSE
20964             WRITE (LUNOUT,*)
20965      &   ' **** Unknown T=oo level density option requested ****'
20966             STOP 'BERTTP-JLVMOD'
20967          END IF
20968          IF ( LLVMOD ) THEN
20969             WRITE (LUNOUT,*)
20970      &      ' **** Cook''s modified pairing energy used ****'
20971          ELSE
20972             WRITE (LUNOUT,*)
20973      &      ' **** Original Gilbert/Cameron pairing energy used ****'
20974          END IF
20975       ENDIF
20976 **
20977
20978       ILVMOD = IB0
20979       DO 500 JZ = 1, 130
20980          PAENUC ( JZ, 1 ) = EMVGEV * CAM4 (JZ)
20981   500 CONTINUE
20982       DO 600 JA = 1, 200
20983          PAENUC ( JA, 2 ) = EMVGEV * CAM5 (JA)
20984   600 CONTINUE
20985       RETURN
20986       END
20987
20988 *$ CREATE DT_EVEVAP.FOR
20989 *COPY DT_EVEVAP
20990 *
20991 *====evevap============================================================*
20992 *
20993       SUBROUTINE DT_EVEVAP(WE)
20994
20995       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20996       SAVE
20997       PARAMETER ( LINP = 10 ,
20998      &            LOUT = 6 ,
20999      &            LDAT = 9 )
21000
21001 * flags for input different options
21002       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
21003       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
21004      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
21005
21006       LEVAPO = .FALSE.
21007
21008       RETURN
21009       END
21010
21011 *$ CREATE DT_FRBKIN.FOR
21012 *COPY DT_FRBKIN
21013 *
21014 *====frbkin============================================================*
21015 *
21016       SUBROUTINE DT_FRBKIN(LDUM1,LDUM2)
21017
21018       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21019       SAVE
21020       PARAMETER ( LINP = 10 ,
21021      &            LOUT = 6 ,
21022      &            LDAT = 9 )
21023
21024       LOGICAL LDUM1,LDUM2
21025
21026       RETURN
21027       END
21028
21029 *$ CREATE DT_EXPLOD.FOR
21030 *COPY DT_EXPLOD
21031 *
21032 *=== explod ===========================================================*
21033 *
21034       SUBROUTINE DT_EXPLOD( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
21035      &                    PYEXPL, PZEXPL )
21036
21037       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21038       SAVE
21039
21040       DIMENSION PXEXPL (NPEXPL), PYEXPL (NPEXPL), PZEXPL (NPEXPL),
21041      &          ETEXPL (NPEXPL), AMEXPL (NPEXPL)
21042
21043       RETURN
21044       END
21045
21046 ************************************************************************
21047 *                                                                      *
21048 *  DPMJET 3.0:   cross section routines                                *
21049 *                                                                      *
21050 ************************************************************************
21051 *
21052 *
21053 *     SUBROUTINE DT_SHNDIF
21054 *         diffractive cross sections (all energies)
21055 *     SUBROUTINE DT_PHOXS
21056 *         total and inel. cross sections from PHOJET interpol. tables
21057 *     SUBROUTINE DT_XSHN
21058 *         total and el. cross sections for all energies
21059 *     SUBROUTINE DT_SIHNAB
21060 *         pion 2-nucleon absorption cross sections
21061 *     SUBROUTINE DT_SIGEMU
21062 *         cross section for target "compounds"
21063 *     SUBROUTINE DT_SIGGA
21064 *         photon nucleus cross sections
21065 *     SUBROUTINE DT_SIGGAT
21066 *         photon nucleus cross sections from tables
21067 *     SUBROUTINE DT_SANO
21068 *         anomalous hard photon-nucleon cross sections from tables
21069 *     SUBROUTINE DT_SIGGP
21070 *         photon nucleon cross sections
21071 *     SUBROUTINE DT_SIGVEL
21072 *         quasi-elastic vector meson prod. cross sections
21073 *     DOUBLE PRECISION FUNCTION DT_SIGVP
21074 *         sigma_VN(tilde)
21075 *     DOUBLE PRECISION FUNCTION DT_RRM2
21076 *     DOUBLE PRECISION FUNCTION DT_RM2
21077 *     DOUBLE PRECISION FUNCTION DT_SAM2
21078 *     SUBROUTINE DT_CKMT
21079 *     SUBROUTINE DT_CKMTX
21080 *     SUBROUTINE DT_PDF0
21081 *     SUBROUTINE DT_CKMTQ0
21082 *     SUBROUTINE DT_CKMTDE
21083 *     SUBROUTINE DT_CKMTPR
21084 *     FUNCTION DT_CKMTFF
21085 *
21086 *     SUBROUTINE DT_FLUINI
21087 *         total nucleon cross section fluctuation treatment
21088 *
21089 *     SUBROUTINE DT_SIGTBL
21090 *         pre-tabulation of low-energy elastic x-sec. using SIHNEL
21091 *     SUBROUTINE DT_XSTABL
21092 *         service routines
21093 *
21094 *
21095 *$ CREATE DT_SHNDIF.FOR
21096 *COPY DT_SHNDIF
21097 *
21098 *===shndif===============================================================*
21099 *
21100       SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
21101
21102 **********************************************************************
21103 *   Single diffractive hadron-nucleon cross sections                 *
21104 *                                              S.Roesler 14/1/93     *
21105 *                                                                    *
21106 *   The cross sections are calculated from extrapolated single       *
21107 *   diffractive antiproton-proton cross sections (DTUJET92) using    *
21108 *   scaling relations between total and single diffractive cross     *
21109 *   sections.                                                        *
21110 **********************************************************************
21111
21112       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21113       SAVE
21114       PARAMETER (ZERO=0.0D0)
21115
21116 * particle properties (BAMJET index convention)
21117       CHARACTER*8  ANAME
21118       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21119      &                IICH(210),IIBAR(210),K1(210),K2(210)
21120 *
21121       CSD1   =   4.201483727D0
21122       CSD4   = -0.4763103556D-02
21123       CSD5   =  0.4324148297D0
21124 *
21125       CHMSD1 =  0.8519297242D0
21126       CHMSD4 = -0.1443076599D-01
21127       CHMSD5 =  0.4014954567D0
21128 *
21129       EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
21130       PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
21131 *
21132       SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
21133       SHMSD  = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
21134       FRAC   = SHMSD/SDIAPP
21135 *
21136       GOTO( 10, 20,999,999,999,999,999, 10, 20,999,
21137      &     999, 20, 20, 20, 20, 20, 10, 20, 20, 10,
21138      &      10, 10, 20, 20, 20) KPROJ
21139 *
21140    10 CONTINUE
21141 *---------------------------- p - p , n - p , sigma0+- - p ,
21142 *                             Lambda - p
21143       CSD1   =  6.004476070D0
21144       CSD4   = -0.1257784606D-03
21145       CSD5   =  0.2447335720D0
21146       SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
21147       SIGDIH = FRAC*SIGDIF
21148       RETURN
21149 *
21150    20 CONTINUE
21151 *
21152       KPSCAL = 2
21153       KTSCAL = 1
21154 C     F      = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
21155       DUMZER = ZERO
21156       CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
21157       F      = SDIAPP/SIGTO
21158       KT     = 1
21159 C     SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
21160       CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
21161       SIGDIF = SIGTO*F
21162       SIGDIH = FRAC*SIGDIF
21163       RETURN
21164 *
21165   999 CONTINUE
21166 *-------------------------- leptons..
21167       SIGDIF = 1.D-10
21168       SIGDIH = 1.D-10
21169       RETURN
21170       END
21171
21172 *$ CREATE DT_PHOXS.FOR
21173 *COPY DT_PHOXS
21174 *
21175 *===phoxs================================================================*
21176 *
21177       SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
21178
21179 ************************************************************************
21180 * Total/inelastic proton-nucleon cross sections taken from PHOJET-     *
21181 * interpolation tables.                                                *
21182 * This version dated 05.11.97 is written by S. Roesler                 *
21183 ************************************************************************
21184
21185       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21186       SAVE
21187
21188       PARAMETER ( LINP = 10 ,
21189      &            LOUT = 6 ,
21190      &            LDAT = 9 )
21191       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21192       PARAMETER (TWOPI  = 6.283185307179586454D+00,
21193      &           PI     = TWOPI/TWO,
21194      &           GEV2MB = 0.38938D0)
21195
21196       LOGICAL LFIRST
21197       DATA LFIRST /.TRUE./
21198
21199 * nucleon-nucleon event-generator
21200       CHARACTER*8 CMODEL
21201       LOGICAL LPHOIN
21202       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21203 * particle properties (BAMJET index convention)
21204       CHARACTER*8  ANAME
21205       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21206      &                IICH(210),IIBAR(210),K1(210),K2(210)
21207
21208 **PHOJET105a
21209 C     PARAMETER (IEETAB=10)
21210 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21211 **PHOJET110
21212 C  energy-interpolation table
21213       INTEGER IEETA2
21214       PARAMETER ( IEETA2 = 20 )
21215       INTEGER ISIMAX
21216       DOUBLE PRECISION SIGTAB,SIGECM
21217       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21218 **
21219
21220       IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
21221          WRITE(LOUT,*) MCGENE
21222  1000    FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
21223          STOP
21224       ENDIF
21225
21226       IF (ECM.LE.ZERO) THEN
21227          EPN = SQRT(AAM(KPROJ)**2+PLAB**2)
21228          ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG))
21229       ENDIF
21230
21231       IF (MODE.EQ.1) THEN
21232 * DL
21233          DELDL = 0.0808D0
21234          EPSDL = -0.4525D0
21235          S     = ECM*ECM
21236          STOT  = 21.7D0*S**DELDL+56.08D0*S**EPSDL
21237          ALPHAP= 0.25D0
21238          BEL   = 8.5D0+2.D0*ALPHAP*LOG(S)
21239          SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
21240          SINE  = STOT-SIGEL
21241          SDIF1 = ZERO
21242       ELSE
21243 * Phojet
21244          IP = 1
21245          IF(ECM.LE.SIGECM(IP,1)) THEN
21246            I1 = 1
21247            I2 = 1
21248          ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
21249            DO 1 I=2,ISIMAX
21250               IF (ECM.LE.SIGECM(IP,I)) GOTO 2
21251     1      CONTINUE
21252     2      CONTINUE
21253            I1 = I-1
21254            I2 = I
21255          ELSE
21256            IF (LFIRST) THEN
21257               WRITE(LOUT,'(/1X,A,2E12.3)')
21258      &          'PHOXS: warning! energy above initialization limit (',
21259      &          ECM,SIGECM(IP,ISIMAX)
21260              LFIRST = .FALSE.
21261            ENDIF
21262            I1 = ISIMAX
21263            I2 = ISIMAX
21264          ENDIF
21265          FAC2 = ZERO
21266          IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
21267      &                       /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
21268          FAC1  = ONE-FAC2
21269          STOT  = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
21270          SINE  = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
21271          SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+
21272      &           FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1))
21273          BEL   = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
21274       ENDIF
21275
21276       RETURN
21277       END
21278
21279 *$ CREATE DT_XSHN.FOR
21280 *COPY DT_XSHN
21281 *
21282 *===xshn===============================================================*
21283 *
21284       SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
21285
21286 ************************************************************************
21287 * Total and elastic hadron-nucleon cross section.                      *
21288 * Below 500GeV cross sections are based on the '98 data compilation    *
21289 * of the PDG. At higher energies PHOJET results are used (patched to   *
21290 * the low energy data at 500GeV).                                      *
21291 *     IP      projectile index (BAMJET numbering scheme)               *
21292 *             (should be in the range 1..25)                           *
21293 *     IT      target index (BAMJET numbering scheme)                   *
21294 *             (1 = proton, 8 = neutron)                                *
21295 *     PL      laboratory momentum                                      *
21296 *     ECM     cm. energy (ignored if PL>0)                             *
21297 *     STOT    total cross section                                      *
21298 *     SELA    elastic cross section                                    *
21299 * Last change: 24.4.99 by S. Roesler                                   *
21300 ************************************************************************
21301
21302       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21303       SAVE
21304
21305       PARAMETER ( LINP = 10 ,
21306      &            LOUT = 6 ,
21307      &            LDAT = 9 )
21308       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
21309
21310       PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
21311      &           PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
21312       PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
21313
21314       LOGICAL LFIRST
21315 * particle properties (BAMJET index convention)
21316       CHARACTER*8  ANAME
21317       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21318      &                IICH(210),IIBAR(210),K1(210),K2(210)
21319 * nucleon-nucleon event-generator
21320       CHARACTER*8 CMODEL
21321       LOGICAL LPHOIN
21322       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21323 **PHOJET105a
21324 C     PARAMETER (IEETAB=10)
21325 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21326 **PHOJET110
21327 C  energy-interpolation table
21328       INTEGER IEETA2
21329       PARAMETER ( IEETA2 = 20 )
21330       INTEGER ISIMAX
21331       DOUBLE PRECISION SIGTAB,SIGECM
21332       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21333
21334       DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
21335       DIMENSION IDXDAT(25,2)
21336 *
21337       DATA APL /
21338      &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748,
21339      &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465,
21340      &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182,
21341      &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101,
21342      & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384,
21343      & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668,
21344      & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/
21345 *
21346 * total cross sections:
21347 * p p
21348       DATA (ASIGTO(1,K),K=1,NPOINT) /
21349      & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21350      & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21351      & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352,
21352      & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596,
21353      & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664,
21354      & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617,
21355      & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/
21356 * pbar p
21357       DATA (ASIGTO(2,K),K=1,NPOINT) /
21358      & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598,
21359      & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329,
21360      & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151,
21361      & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024,
21362      & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921,
21363      & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802,
21364      & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/
21365 * n p
21366       DATA (ASIGTO(3,K),K=1,NPOINT) /
21367      & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21368      & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21369      & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21370      & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566,
21371      & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21372      & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21373      & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21374 * pi+ p
21375       DATA (ASIGTO(4,K),K=1,NPOINT) /
21376      & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21377      & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21378      & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195,
21379      & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473,
21380      & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492,
21381      & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428,
21382      & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/
21383 * pi- p
21384       DATA (ASIGTO(5,K),K=1,NPOINT) /
21385      & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226,
21386      & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679,
21387      & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547,
21388      & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543,
21389      & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535,
21390      & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468,
21391      & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/
21392 * K+ p
21393       DATA (ASIGTO(6,K),K=1,NPOINT) /
21394      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21395      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21396      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095,
21397      & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268,
21398      & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244,
21399      & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236,
21400      & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/
21401 * K- p
21402       DATA (ASIGTO(7,K),K=1,NPOINT) /
21403      & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997,
21404      & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847,
21405      & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543,
21406      & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508,
21407      & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463,
21408      & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396,
21409      & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/
21410 * K+ n
21411       DATA (ASIGTO(8,K),K=1,NPOINT) /
21412      & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21413      & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21414      & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147,
21415      & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301,
21416      & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261,
21417      & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240,
21418      & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/
21419 * K- n
21420       DATA (ASIGTO(9,K),K=1,NPOINT) /
21421      & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778,
21422      & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773,
21423      & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437,
21424      & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454,
21425      & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343,
21426      & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330,
21427      & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/
21428 * Lambda p
21429       DATA (ASIGTO(10,K),K=1,NPOINT) /
21430      & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21431      & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629,
21432      & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499,
21433      & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567,
21434      & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21435      & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21436      & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21437 *
21438 * elastic cross sections:
21439 * p p
21440       DATA (ASIGEL(1,K),K=1,NPOINT) /
21441      & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21442      & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21443      & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350,
21444      & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397,
21445      & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275,
21446      & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115,
21447      & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/
21448 * pbar p
21449       DATA (ASIGEL(2,K),K=1,NPOINT) /
21450      & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963,
21451      & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875,
21452      & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720,
21453      & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636,
21454      & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457,
21455      & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228,
21456      & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/
21457 * n p
21458       DATA (ASIGEL(3,K),K=1,NPOINT) /
21459      & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21460      & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21461      & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21462      & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454,
21463      & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21464      & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21465      & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21466 * pi+ p
21467       DATA (ASIGEL(4,K),K=1,NPOINT) /
21468      & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21469      & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21470      & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166,
21471      & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235,
21472      & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904,
21473      & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776,
21474      & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/
21475 * pi- p
21476       DATA (ASIGEL(5,K),K=1,NPOINT) /
21477      & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727,
21478      & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217,
21479      & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209,
21480      & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140,
21481      & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895,
21482      & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800,
21483      & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/
21484 * K+ p
21485       DATA (ASIGEL(6,K),K=1,NPOINT) /
21486      & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066,
21487      & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070,
21488      & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093,
21489      & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012,
21490      & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759,
21491      & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584,
21492      & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/
21493 * K- p
21494       DATA (ASIGEL(7,K),K=1,NPOINT) /
21495      & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878,
21496      & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561,
21497      & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188,
21498      & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077,
21499      & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800,
21500      & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618,
21501      & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/
21502 * K+ n
21503       DATA (ASIGEL(8,K),K=1,NPOINT) /
21504      & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21505      & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21506      & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148,
21507      & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111,
21508      & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785,
21509      & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635,
21510      & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/
21511 * K- n
21512       DATA (ASIGEL(9,K),K=1,NPOINT) /
21513      & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613,
21514      & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606,
21515      & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914,
21516      & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979,
21517      & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559,
21518      & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489,
21519      & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/
21520 * Lambda p
21521       DATA (ASIGEL(10,K),K=1,NPOINT) /
21522      & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21523      & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630,
21524      & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502,
21525      & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454,
21526      & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21527      & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21528      & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21529
21530       DATA (IDXDAT(K,1),K=1,25) /
21531      &  1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3,
21532      &  1, 3,45, 8, 9/
21533       DATA (IDXDAT(K,2),K=1,25) /
21534      &  3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1,
21535      &  3, 1,45, 6, 7/
21536
21537       DATA LFIRST /.TRUE./
21538
21539       IF (LFIRST) THEN
21540          APLABL = LOG10(PLABLO)
21541          APLABH = LOG10(PLABHI)
21542          APTHRE = LOG10(PTHRE)
21543          ADP1   = (APTHRE-APLABL)/DBLE(NPOIN1)
21544          ADP2   = (APLABH-APTHRE)/DBLE(NPOIN2)
21545          DUM0   = ZERO
21546          PHOPLA = PLABHI
21547          PHOELA = SQRT(AAM(1)**2+PHOPLA**2)
21548          ECMS   = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA)
21549          IF (MCGENE.EQ.2) THEN
21550             IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN
21551                CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0)
21552             ELSE
21553                CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21554             ENDIF
21555          ELSE
21556             CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21557          ENDIF
21558          PHOSEL = PHOSTO-PHOSIN
21559          APHOST = LOG10(PHOSTO)
21560          APHOSE = LOG10(PHOSEL)
21561          LFIRST = .FALSE.
21562       ENDIF
21563       STOT = ZERO
21564       SELA = ZERO
21565       PLAB = PL
21566       ECMS = ECM
21567       IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN
21568          WRITE(LOUT,1000) IP,IT
21569  1000    FORMAT(1X,'DT_XSHN: cross sections not implemented for ',
21570      &          'proj/target',2I4)
21571          STOP
21572       ENDIF
21573
21574       IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN
21575          ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT))
21576          PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP)))
21577       ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN
21578          WRITE(LOUT,1001) PLAB,ECMS
21579  1001    FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5)
21580          STOP
21581       ENDIF
21582
21583 * index of spectrum
21584       IDXP = IP
21585       IF (IP.GT.25) THEN
21586          IF (AAM(IP).GT.ZERO) THEN
21587             IF (ABS(IIBAR(IP)).GT.0) THEN
21588                IDXP = 1
21589             ELSE
21590                IDXP = 13
21591             ENDIF
21592          ELSE
21593             IDXP = 7
21594          ENDIF
21595       ENDIF
21596       IDXT = 1
21597       IF (IT.EQ.8) IDXT = 2
21598       IDXS = IDXDAT(IDXP,IDXT)
21599       IF (IDXS.EQ.0) RETURN
21600
21601 * compute momentum bin indices
21602       IF (PLAB.LT.PLABLO) THEN
21603          IDX0 = 1
21604          IDX1 = 1
21605       ELSEIF (PLAB.GE.PLABHI) THEN
21606          IDX0 = NPOINT
21607          IDX1 = NPOINT
21608       ELSE
21609          APLAB = LOG10(PLAB)
21610          IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN
21611             IDX0 = INT((APLAB-APLABL)/ADP1)+1
21612          ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN
21613             IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1
21614          ENDIF
21615          IDX1 = IDX0+1
21616       ENDIF
21617
21618 * interpolate cross section
21619       IF (IDXS.GT.10) THEN
21620          IDXS1 = IDXS/10
21621          IDXS2 = IDXS-10*IDXS1
21622          IF (IDX0.EQ.IDX1) THEN
21623             IF (IDX0.EQ.1) THEN
21624                ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0))
21625                ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0))
21626             ELSE
21627                DUM0   = ZERO
21628                CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21629                PHOSEL = PHOSTO-PHOSIN
21630                ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO)
21631                ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL)
21632                ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO)
21633                ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL)
21634                ASTOT  = 0.5D0*(ASTOT1+ASTOT2)
21635                ASELA  = 0.5D0*(ASELA1+ASELA2)
21636             ENDIF
21637          ELSE
21638             FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21639             ASTOT1 = ASIGTO(IDXS1,IDX0)+
21640      &               FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0))
21641             ASTOT2 = ASIGTO(IDXS2,IDX0)+
21642      &               FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0))
21643             ASTOT  = 0.5D0*(ASTOT1+ASTOT2)
21644             ASELA1 = ASIGEL(IDXS1,IDX0)+
21645      &               FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0))
21646             ASELA2 = ASIGEL(IDXS2,IDX0)+
21647      &               FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0))
21648             ASELA  = 0.5D0*(ASELA1+ASELA2)
21649          ENDIF
21650       ELSE
21651          IF (IDX0.EQ.IDX1) THEN
21652             IF (IDX0.EQ.1) THEN
21653                ASTOT = ASIGTO(IDXS,IDX0)
21654                ASELA = ASIGEL(IDXS,IDX0)
21655             ELSE
21656                DUM0   = ZERO
21657                CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21658                PHOSEL = PHOSTO-PHOSIN
21659                ASTOT  = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO)
21660                ASELA  = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL)
21661             ENDIF
21662          ELSE
21663             FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21664             ASTOT = ASIGTO(IDXS,IDX0)+
21665      &              FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0))
21666             ASELA = ASIGEL(IDXS,IDX0)+
21667      &              FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0))
21668          ENDIF
21669       ENDIF
21670       STOT = 10.0D0**ASTOT
21671       SELA = 10.0D0**ASELA
21672
21673       RETURN
21674       END
21675
21676 *$ CREATE DT_SIHNAB.FOR
21677 *COPY DT_SIHNAB
21678 *
21679 *===sihnab===============================================================*
21680 *
21681       SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
21682
21683 **********************************************************************
21684 * Pion 2-nucleon absorption cross sections.                          *
21685 * (sigma_tot for pi+ d --> p p, pi- d --> n n                        *
21686 *  taken from Ritchie PRC 28 (1983) 926 )                            *
21687 * This version dated 18.05.96 is written by S. Roesler               *
21688 **********************************************************************
21689
21690       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21691       SAVE
21692       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
21693       PARAMETER (AMPR = 938.0D0,
21694      &           AMPI = 140.0D0,
21695      &           AMDE = TWO*AMPR,
21696      &           A    = -1.2D0,
21697      &           B    = 3.5D0,
21698      &           C    = 7.4D0,
21699      &           D    = 5600.0D0,
21700      &           ER   = 2136.0D0)
21701
21702       SIGABS = ZERO
21703       IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
21704      &                   .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
21705       PTOT = PLAB*1.0D3
21706       EKIN = SQRT(AMPI**2+PTOT**2)-AMPI
21707       IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN
21708       ECM  = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE )
21709       SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D)
21710 * approximate 3N-abs., I=1-abs. etc.
21711       SIGABS = SIGABS/0.40D0
21712 * pi0-absorption (rough approximation!!)
21713       IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS
21714
21715       RETURN
21716       END
21717
21718 *$ CREATE DT_SIGEMU.FOR
21719 *COPY DT_SIGEMU
21720 *
21721 *===sigemu=============================================================*
21722 *
21723       SUBROUTINE DT_SIGEMU
21724
21725 ************************************************************************
21726 * Combined cross section for target compounds.                         *
21727 * This version dated 6.4.98   is written by S. Roesler                 *
21728 ************************************************************************
21729
21730       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21731       SAVE
21732       PARAMETER ( LINP = 10 ,
21733      &            LOUT = 6 ,
21734      &            LDAT = 9 )
21735       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21736      &           OHALF=0.5D0,ONE=1.0D0)
21737
21738       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21739 * Glauber formalism: cross sections
21740       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21741      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21742      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21743      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21744      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21745      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21746      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21747      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21748      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21749      &                BSLOPE,NEBINI,NQBINI
21750 * emulsion treatment
21751       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
21752      &                NCOMPO,IEMUL
21753 * nucleon-nucleon event-generator
21754       CHARACTER*8 CMODEL
21755       LOGICAL LPHOIN
21756       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21757
21758       IF (MCGENE.NE.4) THEN
21759          WRITE(LOUT,'(A)') ' DT_SIGEMU:    Combined cross sections'
21760          WRITE(LOUT,'(15X,A)') '-----------------------'
21761       ENDIF
21762       DO 1 IE=1,NEBINI
21763          DO 2 IQ=1,NQBINI
21764             SIGTOT = ZERO
21765             SIGELA = ZERO
21766             SIGQEP = ZERO
21767             SIGQET = ZERO
21768             SIGQE2 = ZERO
21769             SIGPRO = ZERO
21770             SIGDEL = ZERO
21771             SIGDQE = ZERO
21772             ERRTOT = ZERO
21773             ERRELA = ZERO
21774             ERRQEP = ZERO
21775             ERRQET = ZERO
21776             ERRQE2 = ZERO
21777             ERRPRO = ZERO
21778             ERRDEL = ZERO
21779             ERRDQE = ZERO
21780             IF (NCOMPO.GT.0) THEN
21781                DO 3 IC=1,NCOMPO
21782                   SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC)
21783                   SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC)
21784                   SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC)
21785                   SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC)
21786                   SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC)
21787                   SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC)
21788                   SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC)
21789                   SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC)
21790                   ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2
21791                   ERRELA = ERRELA+XEELA(IE,IQ,IC)**2
21792                   ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2
21793                   ERRQET = ERRQET+XEQET(IE,IQ,IC)**2
21794                   ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2
21795                   ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2
21796                   ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2
21797                   ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2
21798     3          CONTINUE
21799                ERRTOT = SQRT(ERRTOT)
21800                ERRELA = SQRT(ERRELA)
21801                ERRQEP = SQRT(ERRQEP)
21802                ERRQET = SQRT(ERRQET)
21803                ERRQE2 = SQRT(ERRQE2)
21804                ERRPRO = SQRT(ERRPRO)
21805                ERRDEL = SQRT(ERRDEL)
21806                ERRDQE = SQRT(ERRDQE)
21807             ELSE
21808                SIGTOT = XSTOT(IE,IQ,1)
21809                SIGELA = XSELA(IE,IQ,1)
21810                SIGQEP = XSQEP(IE,IQ,1)
21811                SIGQET = XSQET(IE,IQ,1)
21812                SIGQE2 = XSQE2(IE,IQ,1)
21813                SIGPRO = XSPRO(IE,IQ,1)
21814                SIGDEL = XSDEL(IE,IQ,1)
21815                SIGDQE = XSDQE(IE,IQ,1)
21816                ERRTOT = XETOT(IE,IQ,1)
21817                ERRELA = XEELA(IE,IQ,1)
21818                ERRQEP = XEQEP(IE,IQ,1)
21819                ERRQET = XEQET(IE,IQ,1)
21820                ERRQE2 = XEQE2(IE,IQ,1)
21821                ERRPRO = XEPRO(IE,IQ,1)
21822                ERRDEL = XEDEL(IE,IQ,1)
21823                ERRDQE = XEDQE(IE,IQ,1)
21824             ENDIF
21825             IF (MCGENE.NE.4) THEN
21826                WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ)
21827  1000         FORMAT(/,1X,'E_cm =',F9.1,' GeV  Q^2 =',F6.1,' GeV^2 :',/)
21828                WRITE(LOUT,1001) SIGTOT,ERRTOT
21829  1001          FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb')
21830                WRITE(LOUT,1002) SIGELA,ERRELA
21831  1002          FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb')
21832                WRITE(LOUT,1003) SIGQEP,ERRQEP
21833  1003          FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-',
21834      &                F11.5,' mb')
21835                WRITE(LOUT,1004) SIGQET,ERRQET
21836  1004          FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
21837      &                F11.5,' mb')
21838                WRITE(LOUT,1005) SIGQE2,ERRQE2
21839  1005          FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4,
21840      &                ' +-',F11.5,' mb')
21841                WRITE(LOUT,1006) SIGPRO,ERRPRO
21842  1006          FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb')
21843                WRITE(LOUT,1007) SIGDEL,ERRDEL
21844  1007          FORMAT(1X,'diff-el   ',27X,F10.4,' +-',F11.5,' mb')
21845                WRITE(LOUT,1008) SIGDQE,ERRDQE
21846  1008          FORMAT(1X,'diff-qel  ',27X,F10.4,' +-',F11.5,' mb')
21847             ENDIF
21848
21849     2    CONTINUE
21850     1 CONTINUE
21851
21852       RETURN
21853       END
21854
21855 *$ CREATE DT_SIGGA.FOR
21856 *COPY DT_SIGGA
21857 *
21858 *===sigga==============================================================*
21859 *
21860       SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
21861
21862 ************************************************************************
21863 * Total/inelastic photon-nucleus cross sections.                       *
21864 *     !!!! Overwrites SHMAKI-initialization. Do not use it during      *
21865 *          production runs !!!!                                        *
21866 * This version dated 27.03.96 is written by S. Roesler                 *
21867 ************************************************************************
21868
21869       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21870       SAVE
21871       PARAMETER ( LINP = 10 ,
21872      &            LOUT = 6 ,
21873      &            LDAT = 9 )
21874       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21875      &           OHALF=0.5D0,ONE=1.0D0)
21876       PARAMETER (AMPROT = 0.938D0)
21877
21878       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21879 * Glauber formalism: cross sections
21880       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21881      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21882      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21883      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21884      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21885      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21886      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21887      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21888      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21889      &                BSLOPE,NEBINI,NQBINI
21890
21891       NT  = NTI
21892       X   = XI
21893       Q2  = Q2I
21894       ECM = ECMI
21895       XNU = XNUI
21896       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21897      &   ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT)
21898       CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1)
21899       STOT  = XSTOT(1,1,1)
21900       ETOT  = XETOT(1,1,1)
21901       SIN   = XSPRO(1,1,1)
21902       EIN   = XEPRO(1,1,1)
21903
21904       RETURN
21905       END
21906
21907 *$ CREATE DT_SIGGAT.FOR
21908 *COPY DT_SIGGAT
21909 *
21910 *===siggat=============================================================*
21911 *
21912       SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
21913
21914 ************************************************************************
21915 * Total/inelastic photon-nucleus cross sections.                       *
21916 * Uses pre-tabulated cross section.                                    *
21917 * This version dated 29.07.96 is written by S. Roesler                 *
21918 ************************************************************************
21919
21920       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21921       SAVE
21922       PARAMETER ( LINP = 10 ,
21923      &            LOUT = 6 ,
21924      &            LDAT = 9 )
21925       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21926      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21927
21928       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21929 * Glauber formalism: cross sections
21930       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21931      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21932      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21933      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21934      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21935      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21936      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21937      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21938      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21939      &                BSLOPE,NEBINI,NQBINI
21940
21941       NTARG = ABS(NT)
21942       I1   = 1
21943       I2   = 1
21944       RATE = ONE
21945       IF (NEBINI.GT.1) THEN
21946          IF (ECMI.GE.ECMNN(NEBINI)) THEN
21947             I1   = NEBINI
21948             I2   = NEBINI
21949             RATE = ONE
21950          ELSEIF (ECMI.GT.ECMNN(1)) THEN
21951             DO 1 I=2,NEBINI
21952                IF (ECMI.LT.ECMNN(I)) THEN
21953                   I1   = I-1
21954                   I2   = I
21955                   RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
21956                   GOTO 2
21957                ENDIF
21958     1       CONTINUE
21959     2       CONTINUE
21960          ENDIF
21961       ENDIF
21962       J1   = 1
21963       J2   = 1
21964       RATQ = ONE
21965       IF (NQBINI.GT.1) THEN
21966          IF (Q2I.GE.Q2G(NQBINI)) THEN
21967             J1   = NQBINI
21968             J2   = NQBINI
21969             RATQ = ONE
21970          ELSEIF (Q2I.GT.Q2G(1)) THEN
21971             DO 3 I=2,NQBINI
21972                IF (Q2I.LT.Q2G(I)) THEN
21973                   J1   = I-1
21974                   J2   = I
21975                   RATQ = LOG10(    Q2I/MAX(Q2G(J1),TINY14))/
21976      &                   LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
21977 C                 RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
21978                   GOTO 4
21979                ENDIF
21980     3       CONTINUE
21981     4       CONTINUE
21982          ENDIF
21983       ENDIF
21984
21985       STOT = XSTOT(I1,J1,NTARG)+
21986      &   RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+
21987      &   RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+
21988      &   RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+
21989      &              XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG))
21990
21991       RETURN
21992       END
21993
21994 *$ CREATE DT_SANO.FOR
21995 *COPY DT_SANO
21996 *
21997 *===sigano=============================================================*
21998 *
21999       DOUBLE PRECISION FUNCTION DT_SANO(ECM)
22000
22001 ************************************************************************
22002 * This version dated 31.07.96 is written by S. Roesler                 *
22003 ************************************************************************
22004
22005       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22006       SAVE
22007       PARAMETER ( LINP = 10 ,
22008      &            LOUT = 6 ,
22009      &            LDAT = 9 )
22010       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
22011      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
22012       PARAMETER (NE = 8)
22013
22014 * VDM parameter for photon-nucleus interactions
22015       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22016 * properties of interacting particles
22017       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
22018
22019       DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
22020       DATA ECMANO /
22021      &             0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03,
22022      &             0.100D+04,0.200D+04,0.500D+04
22023      &            /
22024 * fixed cut (3 GeV/c)
22025       DATA FRAANO /
22026      &             0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00,
22027      &             0.062D+00,0.054D+00,0.042D+00
22028      &            /
22029       DATA SIGHRD /
22030      &           4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01,
22031      &           3.3086D-01,7.6255D-01,2.1319D+00
22032      &            /
22033 * running cut (based on obsolete Phojet-caluclations, bugs..)
22034 C     DATA FRAANO /
22035 C    &             0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
22036 C    &             0.167E+00,0.150E+00,0.131E+00
22037 C    &            /
22038 C     DATA SIGHRD /
22039 C    &           6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
22040 C    &           2.5736E-01,4.5593E-01,8.2550E-01
22041 C    &            /
22042
22043       DT_SANO = ZERO
22044       IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
22045       J1   = 0
22046       J2   = 0
22047       RATE = ONE
22048       IF (ECM.GE.ECMANO(NE)) THEN
22049          J1 = NE
22050          J2 = NE
22051       ELSEIF (ECM.GT.ECMANO(1)) THEN
22052          DO 1 IE=2,NE
22053             IF (ECM.LT.ECMANO(IE)) THEN
22054                J1   = IE-1
22055                J2   = IE
22056                RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
22057                GOTO 2
22058             ENDIF
22059     1    CONTINUE
22060     2    CONTINUE
22061       ENDIF
22062       IF ((J1.GT.0).AND.(J2.GT.0)) THEN
22063          AFRA1  = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14))
22064          AFRA2  = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14))
22065          DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1))
22066       ENDIF
22067
22068       RETURN
22069       END
22070
22071 *$ CREATE DT_SIGGP.FOR
22072 *COPY DT_SIGGP
22073 *
22074 *===siggp==============================================================*
22075 *
22076       SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
22077
22078 ************************************************************************
22079 * Total/inelastic photon-nucleon cross sections.                       *
22080 * This version dated 30.04.96 is written by S. Roesler                 *
22081 ************************************************************************
22082
22083       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22084       SAVE
22085       PARAMETER ( LINP = 10 ,
22086      &            LOUT = 6 ,
22087      &            LDAT = 9 )
22088       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22089       PARAMETER (TWOPI  = 6.283185307179586476925286766559D+00,
22090      &           PI     = TWOPI/TWO,
22091      &           GEV2MB = 0.38938D0,
22092      &           ALPHEM = ONE/137.0D0)
22093
22094 * particle properties (BAMJET index convention)
22095       CHARACTER*8  ANAME
22096       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22097      &                IICH(210),IIBAR(210),K1(210),K2(210)
22098 * VDM parameter for photon-nucleus interactions
22099       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22100
22101 **PHOJET105a
22102 C     CHARACTER*8 MDLNA
22103 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
22104 C     PARAMETER (IEETAB=10)
22105 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
22106 **PHOJET110
22107 C  model switches and parameters
22108       CHARACTER*8 MDLNA
22109       INTEGER ISWMDL,IPAMDL
22110       DOUBLE PRECISION PARMDL
22111       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
22112 C  energy-interpolation table
22113       INTEGER IEETA2
22114       PARAMETER ( IEETA2 = 20 )
22115       INTEGER ISIMAX
22116       DOUBLE PRECISION SIGTAB,SIGECM
22117       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
22118 **
22119
22120 C     PARAMETER (NPOINT=80)
22121       PARAMETER (NPOINT=16)
22122       DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22123
22124       STOT = ZERO
22125       SINE = ZERO
22126       SDIR = ZERO
22127
22128       W2 = ECMI**2
22129       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
22130      &   W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
22131       Q2 = Q2I
22132       X  = XI
22133 * photoprod.
22134       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22135          Q2 = 0.0001D0
22136          X  = Q2/(W2+Q2-AAM(1)**2)
22137 * DIS
22138       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
22139          X  = Q2/(W2+Q2-AAM(1)**2)
22140       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22141          Q2 = (W2-AAM(1)**2)*X/(ONE-X)
22142       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
22143          W2 = Q2*(ONE-X)/X+AAM(1)**2
22144       ELSE
22145          WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
22146          STOP
22147       ENDIF
22148       ECM = SQRT(W2)
22149
22150       IF (MODEGA.EQ.1) THEN
22151          SCALE = SQRT(Q2)
22152          CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
22153      &                                                       IDPDF)
22154 C        W = SQRT(W2)
22155 C        ALLMF2 = PHO_ALLM97(Q2,W)
22156 C        write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22157          STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22158          SINE = ZERO
22159          SDIR = ZERO
22160       ELSEIF (MODEGA.EQ.2) THEN
22161          IF (INTRGE(1).EQ.1) THEN
22162             AMLO2 = (3.0D0*AAM(13))**2
22163          ELSEIF (INTRGE(1).EQ.2) THEN
22164             AMLO2 = AAM(33)**2
22165          ELSE
22166             AMLO2 = AAM(96)**2
22167          ENDIF
22168          IF (INTRGE(2).EQ.1) THEN
22169             AMHI2 = W2/TWO
22170          ELSEIF (INTRGE(2).EQ.2) THEN
22171             AMHI2 = W2/4.0D0
22172          ELSE
22173             AMHI2 = W2
22174          ENDIF
22175          AMHI20 = (ECM-AAM(1))**2
22176          IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22177          XAMLO  = LOG( AMLO2+Q2 )
22178          XAMHI  = LOG( AMHI2+Q2 )
22179 **PHOJET105a
22180 C        CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
22181 **PHOJET112
22182          CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
22183 **
22184          SUM  = ZERO
22185          DO 1 J=1,NPOINT
22186             AM2 = EXP(ABSZX(J))-Q2
22187             IF (AM2.LT.16.0D0) THEN
22188                R = TWO
22189             ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
22190                R = 10.0D0/3.0D0
22191             ELSE
22192                R = 11.0D0/3.0D0
22193             ENDIF
22194 C           FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
22195             FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
22196      &            * (ONE+EPSPOL*Q2/AM2)
22197             SUM = SUM+WEIGHT(J)*FAC
22198     1    CONTINUE
22199          SINE = SUM
22200          SDIR = DT_SIGVP(X,Q2)
22201          STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
22202          SDIR = SDIR/(0.588D0+RL2+Q2)
22203 C        STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2)
22204       ELSEIF (MODEGA.EQ.3) THEN
22205          CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM)
22206       ELSEIF (MODEGA.EQ.4) THEN
22207 *  load cross sections from PHOJET interpolation table
22208          IP = 1
22209          IF(ECM.LE.SIGECM(IP,1)) THEN
22210            I1 = 1
22211            I2 = 1
22212          ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
22213            DO 2 I=2,ISIMAX
22214               IF (ECM.LE.SIGECM(IP,I)) GOTO 3
22215     2      CONTINUE
22216     3      CONTINUE
22217            I1 = I-1
22218            I2 = I
22219          ELSE
22220            WRITE(LOUT,'(/1X,A,2E12.3)')
22221      &       'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
22222            I1 = ISIMAX
22223            I2 = ISIMAX
22224          ENDIF
22225          FAC2 = ZERO
22226          IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
22227      &                       /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
22228          FAC1 = ONE-FAC2
22229 *  cross section dependence on photon virtuality
22230          FSUP1 = ZERO
22231          DO 4 I=1,3
22232             FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
22233      &                                /(1.D0+Q2/PARMDL(30+I))**2
22234     4    CONTINUE
22235          FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
22236          FAC1  = FAC1*FSUP1
22237          FAC2  = FAC2*FSUP1
22238          FSUP2 = 1.0D0
22239          STOT  = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
22240          SINE  = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
22241          SDIR  = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
22242 **re:
22243          STOT  = STOT-SDIR
22244 **
22245          SDIR  = SDIR/(FSUP1*FSUP2)
22246 **re:
22247          STOT  = STOT+SDIR
22248 **
22249       ENDIF
22250
22251       RETURN
22252       END
22253
22254 *$ CREATE DT_SIGVEL.FOR
22255 *COPY DT_SIGVEL
22256 *
22257 *===sigvel=============================================================*
22258 *
22259       SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
22260
22261 ************************************************************************
22262 * Cross section for elastic vector meson production                    *
22263 * This version dated 10.05.96 is written by S. Roesler                 *
22264 ************************************************************************
22265
22266       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22267       SAVE
22268       PARAMETER ( LINP = 10 ,
22269      &            LOUT = 6 ,
22270      &            LDAT = 9 )
22271       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22272       PARAMETER (TWOPI  = 6.283185307179586476925286766559D+00,
22273      &           PI     = TWOPI/TWO,
22274      &           GEV2MB = 0.38938D0,
22275      &           ALPHEM = ONE/137.0D0)
22276
22277 * particle properties (BAMJET index convention)
22278       CHARACTER*8  ANAME
22279       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22280      &                IICH(210),IIBAR(210),K1(210),K2(210)
22281 * VDM parameter for photon-nucleus interactions
22282       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22283
22284       W2 = ECMI**2
22285       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
22286      &   W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
22287       Q2 = Q2I
22288       X  = XI
22289 * photoprod.
22290       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22291          Q2 = 0.0001D0
22292          X  = Q2/(W2+Q2-AAM(1)**2)
22293 * DIS
22294       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
22295          X  = Q2/(W2+Q2-AAM(1)**2)
22296       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22297          Q2 = (W2-AAM(1)**2)*X/(ONE-X)
22298       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
22299          W2 = Q2*(ONE-X)/X+AAM(1)**2
22300       ELSE
22301          WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
22302          STOP
22303       ENDIF
22304       ECM = SQRT(W2)
22305
22306       AMV  = AAM(IDXV)
22307       AMV2 = AMV**2
22308
22309       BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
22310      &        +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
22311       ROSH   = 0.1D0
22312       STOVP  = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
22313       SELVP  = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
22314
22315       IF (IDXV.EQ.33) THEN
22316          COUPL = 0.00365D0
22317       ELSE
22318          STOP
22319       ENDIF
22320       SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
22321       SIG2 = SELVP
22322       SVEL  = COUPL * (AMV2/(AMV2+Q2))**2
22323      &              * (ONE+EPSPOL*Q2/AMV2) * SELVP
22324
22325       RETURN
22326       END
22327
22328 *$ CREATE DT_SIGVP.FOR
22329 *COPY DT_SIGVP
22330 *
22331 *===sigvp==============================================================*
22332 *
22333       DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
22334
22335 ************************************************************************
22336 * sigma_Vp                                                             *
22337 ************************************************************************
22338
22339       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22340       SAVE
22341
22342       PARAMETER ( LINP = 10 ,
22343      &            LOUT = 6 ,
22344      &            LDAT = 9 )
22345       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22346       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22347      &           PI    = TWOPI/TWO,
22348      &           GEV2MB = 0.38938D0,
22349      &           AMPROT = 0.938D0,
22350      &           ALPHEM = ONE/137.0D0)
22351 * VDM parameter for photon-nucleus interactions
22352       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22353
22354       X  = XI
22355       Q2 = Q2I
22356       IF (XI.LE.ZERO)  X  = 0.0001D0
22357       IF (Q2I.LE.ZERO) Q2 = 0.0001D0
22358
22359       ECM    = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
22360
22361       SCALE = SQRT(Q2)
22362       IF (MODEGA.EQ.1) THEN
22363          CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
22364      &                                                       IDPDF)
22365 C        W = ECM
22366 C        ALLMF2 = PHO_ALLM97(Q2,W)
22367 C        write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22368 C        STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22369 C        DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
22370          DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB
22371       ELSEIF (MODEGA.EQ.4) THEN
22372          CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3)
22373 C        F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
22374          DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
22375       ELSE
22376          STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
22377       ENDIF
22378
22379       RETURN
22380
22381       END
22382
22383 *$ CREATE DT_RRM2.FOR
22384 *COPY DT_RRM2
22385 *
22386 *===RRM2===============================================================*
22387 *
22388       DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
22389
22390       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22391       SAVE
22392       PARAMETER ( LINP = 10 ,
22393      &            LOUT = 6 ,
22394      &            LDAT = 9 )
22395       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22396       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22397      &           PI    = TWOPI/TWO,
22398      &           GEV2MB = 0.38938D0)
22399
22400 * particle properties (BAMJET index convention)
22401       CHARACTER*8  ANAME
22402       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22403      &                IICH(210),IIBAR(210),K1(210),K2(210)
22404 * VDM parameter for photon-nucleus interactions
22405       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22406
22407       S   = Q2*(ONE-X)/X+AAM(1)**2
22408       ECM = SQRT(S)
22409
22410       IF (INTRGE(1).EQ.1) THEN
22411          AMLO2 = (3.0D0*AAM(13))**2
22412       ELSEIF (INTRGE(1).EQ.2) THEN
22413          AMLO2 = AAM(33)**2
22414       ELSE
22415          AMLO2 = AAM(96)**2
22416       ENDIF
22417       IF (INTRGE(2).EQ.1) THEN
22418          AMHI2 = S/TWO
22419       ELSEIF (INTRGE(2).EQ.2) THEN
22420          AMHI2 = S/4.0D0
22421       ELSE
22422          AMHI2 = S
22423       ENDIF
22424       AMHI20 = (ECM-AAM(1))**2
22425       IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22426
22427       AM1C2 = 16.0D0
22428       AM2C2 = 121.0D0
22429       IF (AMHI2.LE.AM1C2) THEN
22430          DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2)
22431       ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22432          DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22433      &          10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2)
22434       ELSE
22435          DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22436      &          10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+
22437      &          11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2)
22438       ENDIF
22439
22440       RETURN
22441       END
22442
22443 *$ CREATE DT_RM2.FOR
22444 *COPY DT_RM2
22445 *
22446 *===RM2================================================================*
22447 *
22448       DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
22449
22450       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22451       SAVE
22452       PARAMETER ( LINP = 10 ,
22453      &            LOUT = 6 ,
22454      &            LDAT = 9 )
22455       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22456       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22457      &           PI    = TWOPI/TWO,
22458      &           GEV2MB = 0.38938D0)
22459 * VDM parameter for photon-nucleus interactions
22460       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22461
22462       IF (RL2.LE.ZERO) THEN
22463          DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) -
22464      &        (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2))
22465      &         +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2))
22466       ELSE
22467          TMPMLO = LOG(ONE+RL2/(AMLO2+Q2))
22468          TMPMHI = LOG(ONE+RL2/(AMHI2+Q2))
22469          DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI
22470      &       -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO)
22471      &       +EPSPOL*(
22472      &         -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
22473      &       -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
22474       ENDIF
22475
22476       RETURN
22477       END
22478
22479 *$ CREATE DT_SAM2.FOR
22480 *COPY DT_SAM2
22481 *
22482 *===SAM2===============================================================*
22483 *
22484       DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
22485
22486       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22487       SAVE
22488       PARAMETER ( LINP = 10 ,
22489      &            LOUT = 6 ,
22490      &            LDAT = 9 )
22491       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
22492      &           TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0)
22493       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22494      &           PI    = TWOPI/TWO,
22495      &           GEV2MB = 0.38938D0)
22496
22497 * particle properties (BAMJET index convention)
22498       CHARACTER*8  ANAME
22499       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22500      &                IICH(210),IIBAR(210),K1(210),K2(210)
22501 * VDM parameter for photon-nucleus interactions
22502       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22503
22504       S = ECM**2
22505       IF (INTRGE(1).EQ.1) THEN
22506          AMLO2 = (3.0D0*AAM(13))**2
22507       ELSEIF (INTRGE(1).EQ.2) THEN
22508          AMLO2 = AAM(33)**2
22509       ELSE
22510          AMLO2 = AAM(96)**2
22511       ENDIF
22512       IF (INTRGE(2).EQ.1) THEN
22513          AMHI2 = S/TWO
22514       ELSEIF (INTRGE(2).EQ.2) THEN
22515          AMHI2 = S/4.0D0
22516       ELSE
22517          AMHI2 = S
22518       ENDIF
22519       AMHI20 = (ECM-AAM(1))**2
22520       IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22521
22522       AM1C2 = 16.0D0
22523       AM2C2 = 121.0D0
22524       YLO   = LOG(AMLO2+Q2)
22525       YC1   = LOG(AM1C2+Q2)
22526       YC2   = LOG(AM2C2+Q2)
22527       YHI   = LOG(AMHI2+Q2)
22528       IF (AMHI2.LE.AM1C2) THEN
22529          FACHI = TWO
22530       ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22531          FACHI = TENTRD
22532       ELSE
22533          FACHI = ELVTRD
22534       ENDIF
22535
22536     1 CONTINUE
22537       YSAM2  = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
22538       IF (YSAM2.LE.YC1) THEN
22539          FAC = TWO
22540       ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
22541          FAC = TENTRD
22542       ELSE
22543          FAC = ELVTRD
22544       ENDIF
22545       WEIGMX = FACHI*(ONE-Q2*EXP(  -YHI))
22546       XSAM2  = FAC  *(ONE-Q2*EXP(-YSAM2))
22547       IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
22548
22549       DT_SAM2   = EXP(YSAM2)-Q2
22550
22551       RETURN
22552       END
22553
22554 *$ CREATE DT_CKMT.FOR
22555 *COPY DT_CKMT
22556 *
22557 *===ckmt===============================================================*
22558 *
22559       SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
22560      &                F2,IPAR)
22561
22562 ************************************************************************
22563 * This version dated 31.01.96 is written by S. Roesler                 *
22564 ************************************************************************
22565
22566       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22567       SAVE
22568       PARAMETER ( LINP = 10 ,
22569      &            LOUT = 6 ,
22570      &            LDAT = 9 )
22571       PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
22572
22573       PARAMETER (Q02 = 2.0D0,
22574      &           DQ2 = 10.05D0,
22575      &           Q12 = Q02+DQ2)
22576
22577       DIMENSION PD(-6:6),SEA(3),VAL(2)
22578
22579       CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR)
22580       CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR)
22581       ADQ2 = LOG10(Q12)-LOG10(Q02)
22582       F2P  = (F2Q1-F2Q0)/ADQ2
22583       CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0)
22584       CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1)
22585       F2PP = (F2PQ1-F2PQ0)/ADQ2
22586       FX   = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02
22587
22588       Q2     = MAX(SCALE**2.0D0,TINY10)
22589       SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2
22590       IF (Q2.LT.Q02) THEN
22591          CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22592          UPV  = VAL(1)
22593          DNV  = VAL(2)
22594          USEA = SEA(1)
22595          DSEA = SEA(2)
22596          STR  = SEA(3)
22597          CHM  = 0.0D0
22598          BOT  = 0.0D0
22599          TOP  = 0.0D0
22600          GL   = GLU
22601       ELSE
22602          CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
22603          F2 = F2*SMOOTH
22604          UPV  = PD(2)-PD(3)
22605          DNV  = PD(1)-PD(3)
22606          USEA = PD(3)
22607          DSEA = PD(3)
22608          STR  = PD(3)
22609          CHM  = PD(4)
22610          BOT  = PD(5)
22611          TOP  = PD(6)
22612          GL   = PD(0)
22613 C        UPV  = UPV*SMOOTH
22614 C        DNV  = DNV*SMOOTH
22615 C        USEA = USEA*SMOOTH
22616 C        DSEA = DSEA*SMOOTH
22617 C        STR  = STR*SMOOTH
22618 C        CHM  = CHM*SMOOTH
22619 C        GL   = GL*SMOOTH
22620       ENDIF
22621
22622       RETURN
22623       END
22624 C
22625
22626 *$ CREATE DT_CKMTX.FOR
22627 *COPY DT_CKMTX
22628       SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
22629 C**********************************************************************
22630 C
22631 C     PDF based on Regge theory, evolved with .... by ....
22632 C
22633 C     input: IPAR     2212   proton (not installed)
22634 C                       45   Pomeron
22635 C                      100   Deuteron
22636 C
22637 C     output: PD(-6:6) x*f(x)  parton distribution functions
22638 C            (PDFLIB convention: d = PD(1), u = PD(2) )
22639 C
22640 C**********************************************************************
22641
22642       SAVE
22643       DOUBLE PRECISION  X,SCALE2,PD(-6:6),CDN,CUP,F2
22644       PARAMETER ( LINP = 10 ,
22645      &            LOUT = 6 ,
22646      &            LDAT = 9 )
22647       DIMENSION QQ(7)
22648 C
22649       Q2=SNGL(SCALE2)
22650       Q1S=Q2
22651       XX=SNGL(X)
22652 C  QCD lambda for evolution
22653       OWLAM = 0.23D0
22654       OWLAM2=OWLAM**2
22655 C  Q0**2 for evolution
22656       Q02 = 2.D0
22657 C
22658 C
22659 C  the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
22660 C                        q(6)=x*charm, q(7)=x*gluon
22661 C
22662       SB=0.
22663       IF(Q2-Q02) 1,1,2
22664     2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
22665     1 CONTINUE
22666       IF(IPAR.EQ.2212) THEN
22667         CALL DT_CKMTPR(1,0,XX,SB,QQ(1))
22668         CALL DT_CKMTPR(2,0,XX,SB,QQ(2))
22669         CALL DT_CKMTPR(3,0,XX,SB,QQ(3))
22670         CALL DT_CKMTPR(4,0,XX,SB,QQ(4))
22671         CALL DT_CKMTPR(5,0,XX,SB,QQ(5))
22672         CALL DT_CKMTPR(8,0,XX,SB,QQ(6))
22673         CALL DT_CKMTPR(7,0,XX,SB,QQ(7))
22674 C     ELSEIF (IPAR.EQ.45) THEN
22675 C       CALL CKMTPO(1,0,XX,SB,QQ(1))
22676 C       CALL CKMTPO(2,0,XX,SB,QQ(2))
22677 C       CALL CKMTPO(3,0,XX,SB,QQ(3))
22678 C       CALL CKMTPO(4,0,XX,SB,QQ(4))
22679 C       CALL CKMTPO(5,0,XX,SB,QQ(5))
22680 C       CALL CKMTPO(8,0,XX,SB,QQ(6))
22681 C       CALL CKMTPO(7,0,XX,SB,QQ(7))
22682       ELSEIF (IPAR.EQ.100) THEN
22683         CALL DT_CKMTDE(1,0,XX,SB,QQ(1))
22684         CALL DT_CKMTDE(2,0,XX,SB,QQ(2))
22685         CALL DT_CKMTDE(3,0,XX,SB,QQ(3))
22686         CALL DT_CKMTDE(4,0,XX,SB,QQ(4))
22687         CALL DT_CKMTDE(5,0,XX,SB,QQ(5))
22688         CALL DT_CKMTDE(8,0,XX,SB,QQ(6))
22689         CALL DT_CKMTDE(7,0,XX,SB,QQ(7))
22690       ELSE
22691         WRITE(LOUT,'(1X,A,I4,A)')
22692      &     'CKMTX:   IPAR =',IPAR,' not implemented!'
22693         STOP
22694       ENDIF
22695 C
22696       PD(-6) = 0.D0
22697       PD(-5) = 0.D0
22698       PD(-4) = DBLE(QQ(6))
22699       PD(-3) = DBLE(QQ(3))
22700       PD(-2) = DBLE(QQ(4))
22701       PD(-1) = DBLE(QQ(5))
22702       PD(0)  = DBLE(QQ(7))
22703       PD(1)  = DBLE(QQ(2))
22704       PD(2)  = DBLE(QQ(1))
22705       PD(3)  = DBLE(QQ(3))
22706       PD(4)  = DBLE(QQ(6))
22707       PD(5)  = 0.D0
22708       PD(6)  = 0.D0
22709       IF(IPAR.EQ.45) THEN
22710         CDN = (PD(1)-PD(-1))/2.D0
22711         CUP = (PD(2)-PD(-2))/2.D0
22712         PD(-1) = PD(-1) + CDN
22713         PD(-2) = PD(-2) + CUP
22714         PD(1) = PD(-1)
22715         PD(2) = PD(-2)
22716       ENDIF
22717       F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+
22718      &     1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+
22719      &     1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4))
22720       END
22721 C
22722
22723 *$ CREATE DT_PDF0.FOR
22724 *COPY DT_PDF0
22725 *
22726 *===pdf0===============================================================*
22727 *
22728       SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22729
22730 ************************************************************************
22731 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2       *
22732 * an F_2-ansatz given in Capella et al. PLB 337(1994)358.              *
22733 *                   IPAR  = 2212   proton                              *
22734 *                         =  100   deuteron                            *
22735 * This version dated 31.01.96 is written by S. Roesler                 *
22736 ************************************************************************
22737
22738       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22739       SAVE
22740       PARAMETER ( LINP = 10 ,
22741      &            LOUT = 6 ,
22742      &            LDAT = 9 )
22743       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22744
22745       PARAMETER (
22746      &              AA     = 0.1502D0,
22747      &              BBDEU  = 1.2D0,
22748      &              BUD    = 0.754D0,
22749      &              BDD    = 0.4495D0,
22750      &              BUP    = 1.2064D0,
22751      &              BDP    = 0.1798D0,
22752      &              DELTA0 = 0.07684D0,
22753      &              D      = 1.117D0,
22754      &              C      = 3.5489D0,
22755      &              A      = 0.2631D0,
22756      &              B      = 0.6452D0,
22757      &              ALPHAR = 0.415D0,
22758      &              E      = 0.1D0
22759      &          )
22760
22761       PARAMETER (NPOINT=16)
22762 C     DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22763       DIMENSION SEA(3),VAL(2)
22764
22765       DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22766       AN    = 1.5D0*(1.0D0+Q2/(Q2+C))
22767 * proton, deuteron
22768       IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22769          CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22770          SEA(1) = 0.75D0*SEA0
22771          SEA(2) = SEA(1)
22772          SEA(3) = SEA(1)
22773          VAL(1) = 9.0D0/4.0D0*VALU0
22774          VAL(2) = 9.0D0*VALD0
22775          GLU0   = SEA(1)/(1.0D0-X)
22776          F2     = SEA0+VALU0+VALD0
22777          F2PDF  = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+
22778      &            1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+
22779      &            1.0D0/9.0D0*(2.0D0*SEA(3))
22780          IF (ABS(F2-F2PDF).GT.TINY9) THEN
22781             WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF
22782             STOP
22783          ENDIF
22784 **PHOJET105a
22785 C        CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22786 **PHOJET112
22787 C        CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22788 **
22789 C        SUMQ = ZERO
22790 C        SUMG = ZERO
22791 C        DO 1 J=1,NPOINT
22792 C           CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
22793 C           VALU0 = 9.0D0/4.0D0*VALU0
22794 C           VALD0 = 9.0D0*VALD0
22795 C           SEA0  = 0.75D0*SEA0
22796 C           SUMQ  = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
22797 C           SUMG  = SUMG+ (SEA0/(1.0D0-ABSZX(J)))  *WEIGHT(J)
22798 C   1    CONTINUE
22799 C        GLU = GLU0*(1.0D0-SUMQ)/SUMG
22800       ELSE
22801          WRITE(LOUT,'(1X,A,I4,A)')
22802      &      'PDF0:   IPAR =',IPAR,' not implemented!'
22803          STOP
22804       ENDIF
22805
22806       RETURN
22807       END
22808
22809 *$ CREATE DT_CKMTQ0.FOR
22810 *COPY DT_CKMTQ0
22811 *
22812 *===ckmtq0=============================================================*
22813 *
22814       SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22815
22816 ************************************************************************
22817 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2       *
22818 * an F_2-ansatz given in Capella et al. PLB 337(1994)358.              *
22819 *                   IPAR  = 2212   proton                              *
22820 *                         =  100   deuteron                            *
22821 * This version dated 31.01.96 is written by S. Roesler                 *
22822 ************************************************************************
22823
22824       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22825       SAVE
22826       PARAMETER ( LINP = 10 ,
22827      &            LOUT = 6 ,
22828      &            LDAT = 9 )
22829       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22830
22831       PARAMETER (
22832      &              AA     = 0.1502D0,
22833      &              BBDEU  = 1.2D0,
22834      &              BUD    = 0.754D0,
22835      &              BDD    = 0.4495D0,
22836      &              BUP    = 1.2064D0,
22837      &              BDP    = 0.1798D0,
22838      &              DELTA0 = 0.07684D0,
22839      &              D      = 1.117D0,
22840      &              C      = 3.5489D0,
22841      &              A      = 0.2631D0,
22842      &              B      = 0.6452D0,
22843      &              ALPHAR = 0.415D0,
22844      &              E      = 0.1D0
22845      &          )
22846
22847       DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22848       AN    = 1.5D0*(1.0D0+Q2/(Q2+C))
22849 * proton, deuteron
22850       IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22851          IF (IPAR.EQ.2212) THEN
22852             BU = BUP
22853             BD = BDP
22854          ELSE
22855             BU = BUD
22856             BD = BDD
22857          ENDIF
22858          SEA0  = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)*
22859      &          (Q2/(Q2+A))**(1.0D0+DELTA)
22860          VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN*
22861      &           (Q2/(Q2+B))**(ALPHAR)
22862          VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)*
22863      &           (Q2/(Q2+B))**(ALPHAR)
22864       ELSE
22865          WRITE(LOUT,'(1X,A,I4,A)')
22866      &      'CKMTQ0: IPAR =',IPAR,' not implemented!'
22867          STOP
22868       ENDIF
22869       RETURN
22870       END
22871 C
22872 C
22873
22874 *$ CREATE DT_CKMTDE.FOR
22875 *COPY DT_CKMTDE
22876       SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
22877 C
22878 C**********************************************************************
22879 C    Deuteron - PDFs
22880 C    I   = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
22881 C    ANS = PDF(I)
22882 C    This version by S. Roesler, 30.01.96
22883 C**********************************************************************
22884
22885       SAVE
22886       DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
22887       EQUIVALENCE (GF(1,1,1),DL(1))
22888       DATA DELTA/.13/
22889 C
22890       DATA (DL(K),K=    1,   85) /
22891      &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00,
22892      &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00,
22893      &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01,
22894      &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00,
22895      &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00,
22896      &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00,
22897      &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00,
22898      &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00,
22899      &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00,
22900      &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00,
22901      &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02,
22902      &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01,
22903      &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01,
22904      &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01,
22905      &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01,
22906      &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01,
22907      &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/
22908       DATA (DL(K),K=   86,  170) /
22909      &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01,
22910      &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02,
22911      &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01,
22912      &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01,
22913      &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01,
22914      &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01,
22915      &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01,
22916      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22917      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22918      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22919      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22920      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22921      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22922      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22923      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22924      &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00,
22925      &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/
22926       DATA (DL(K),K=  171,  255) /
22927      &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01,
22928      &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00,
22929      &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00,
22930      &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00,
22931      &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00,
22932      &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00,
22933      &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00,
22934      &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00,
22935      &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02,
22936      &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00,
22937      &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00,
22938      &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00,
22939      &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00,
22940      &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00,
22941      &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01,
22942      &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01,
22943      &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/
22944       DATA (DL(K),K=  256,  340) /
22945      &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01,
22946      &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01,
22947      &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01,
22948      &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01,
22949      &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01,
22950      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22951      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22952      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22953      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22954      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22955      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22956      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22957      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22958      &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00,
22959      &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00,
22960      &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01,
22961      &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/
22962       DATA (DL(K),K=  341,  425) /
22963      &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00,
22964      &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00,
22965      &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00,
22966      &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00,
22967      &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00,
22968      &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00,
22969      &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02,
22970      &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00,
22971      &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00,
22972      &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00,
22973      &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00,
22974      &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00,
22975      &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00,
22976      &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01,
22977      &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02,
22978      &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00,
22979      &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/
22980       DATA (DL(K),K=  426,  510) /
22981      &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00,
22982      &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01,
22983      &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00,
22984      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22985      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22986      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22987      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22988      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22989      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22990      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22991      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22992      &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00,
22993      &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00,
22994      &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01,
22995      &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00,
22996      &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00,
22997      &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/
22998       DATA (DL(K),K=  511,  595) /
22999      &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00,
23000      &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00,
23001      &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00,
23002      &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00,
23003      &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01,
23004      &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00,
23005      &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00,
23006      &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00,
23007      &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00,
23008      &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00,
23009      &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00,
23010      &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00,
23011      &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01,
23012      &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00,
23013      &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00,
23014      &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00,
23015      &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/
23016       DATA (DL(K),K=  596,  680) /
23017      &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00,
23018      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23019      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23020      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23021      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23022      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23023      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23024      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23025      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23026      &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23027      &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00,
23028      &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01,
23029      &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00,
23030      &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00,
23031      &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00,
23032      &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00,
23033      &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/
23034       DATA (DL(K),K=  681,  765) /
23035      &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00,
23036      &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00,
23037      &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01,
23038      &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00,
23039      &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00,
23040      &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00,
23041      &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00,
23042      &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00,
23043      &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00,
23044      &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00,
23045      &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01,
23046      &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00,
23047      &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00,
23048      &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00,
23049      &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00,
23050      &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00,
23051      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23052       DATA (DL(K),K=  766,  850) /
23053      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23054      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23055      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23056      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23057      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23058      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23059      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23060      &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23061      &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00,
23062      &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01,
23063      &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00,
23064      &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00,
23065      &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00,
23066      &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00,
23067      &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01,
23068      &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00,
23069      &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/
23070       DATA (DL(K),K=  851,  935) /
23071      &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01,
23072      &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00,
23073      &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00,
23074      &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00,
23075      &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00,
23076      &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00,
23077      &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00,
23078      &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00,
23079      &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01,
23080      &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00,
23081      &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00,
23082      &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00,
23083      &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00,
23084      &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00,
23085      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23086      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23087      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23088       DATA (DL(K),K=  936, 1020) /
23089      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23090      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23091      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23092      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23093      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23094      &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23095      &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00,
23096      &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01,
23097      &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00,
23098      &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00,
23099      &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00,
23100      &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00,
23101      &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01,
23102      &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00,
23103      &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00,
23104      &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01,
23105      &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/
23106       DATA (DL(K),K= 1021, 1105) /
23107      &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00,
23108      &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00,
23109      &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00,
23110      &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01,
23111      &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00,
23112      &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00,
23113      &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01,
23114      &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00,
23115      &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00,
23116      &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00,
23117      &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00,
23118      &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01,
23119      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23120      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23121      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23122      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23123      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23124       DATA (DL(K),K= 1106, 1190) /
23125      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23126      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23127      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23128      &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01,
23129      &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00,
23130      &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01,
23131      &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01,
23132      &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00,
23133      &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01,
23134      &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01,
23135      &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01,
23136      &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01,
23137      &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00,
23138      &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01,
23139      &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01,
23140      &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00,
23141      &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/
23142       DATA (DL(K),K= 1191, 1275) /
23143      &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01,
23144      &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01,
23145      &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01,
23146      &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00,
23147      &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00,
23148      &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01,
23149      &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00,
23150      &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01,
23151      &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01,
23152      &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01,
23153      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23154      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23155      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23156      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23157      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23158      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23159      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23160       DATA (DL(K),K= 1276, 1360) /
23161      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23162      &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01,
23163      &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00,
23164      &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00,
23165      &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01,
23166      &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00,
23167      &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01,
23168      &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01,
23169      &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02,
23170      &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01,
23171      &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00,
23172      &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00,
23173      &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01,
23174      &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00,
23175      &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01,
23176      &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01,
23177      &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/
23178       DATA (DL(K),K= 1361, 1445) /
23179      &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01,
23180      &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00,
23181      &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00,
23182      &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01,
23183      &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00,
23184      &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01,
23185      &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01,
23186      &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01,
23187      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23188      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23189      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23190      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23191      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23192      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23193      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23194      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23195      &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/
23196       DATA (DL(K),K= 1446, 1530) /
23197      &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00,
23198      &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00,
23199      &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01,
23200      &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00,
23201      &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01,
23202      &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01,
23203      &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02,
23204      &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01,
23205      &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00,
23206      &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00,
23207      &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01,
23208      &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00,
23209      &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01,
23210      &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01,
23211      &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02,
23212      &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01,
23213      &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/
23214       DATA (DL(K),K= 1531, 1615) /
23215      &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00,
23216      &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01,
23217      &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00,
23218      &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01,
23219      &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01,
23220      &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02,
23221      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23222      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23223      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23224      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23225      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23226      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23227      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23228      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23229      &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01,
23230      &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00,
23231      &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/
23232       DATA (DL(K),K= 1616, 1700) /
23233      &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01,
23234      &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00,
23235      &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01,
23236      &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01,
23237      &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02,
23238      &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01,
23239      &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00,
23240      &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00,
23241      &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01,
23242      &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00,
23243      &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01,
23244      &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01,
23245      &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02,
23246      &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01,
23247      &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00,
23248      &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00,
23249      &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/
23250       DATA (DL(K),K= 1701, 1785) /
23251      &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00,
23252      &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02,
23253      &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02,
23254      &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02,
23255      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23256      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23257      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23258      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23259      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23260      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23261      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23262      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23263      &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01,
23264      &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00,
23265      &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00,
23266      &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01,
23267      &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/
23268       DATA (DL(K),K= 1786, 1870) /
23269      &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01,
23270      &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01,
23271      &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02,
23272      &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02,
23273      &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00,
23274      &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00,
23275      &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02,
23276      &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00,
23277      &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02,
23278      &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02,
23279      &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02,
23280      &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02,
23281      &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00,
23282      &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01,
23283      &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02,
23284      &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00,
23285      &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/
23286       DATA (DL(K),K= 1871, 1955) /
23287      &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02,
23288      &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02,
23289      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23290      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23291      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23292      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23293      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23294      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23295      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23296      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23297      &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02,
23298      &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00,
23299      &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00,
23300      &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02,
23301      &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00,
23302      &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02,
23303      &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/
23304       DATA (DL(K),K= 1956, 2040) /
23305      &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03,
23306      &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02,
23307      &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00,
23308      &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01,
23309      &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02,
23310      &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00,
23311      &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02,
23312      &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02,
23313      &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03,
23314      &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02,
23315      &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00,
23316      &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01,
23317      &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02,
23318      &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00,
23319      &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02,
23320      &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02,
23321      &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/
23322       DATA (DL(K),K= 2041, 2125) /
23323      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23324      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23325      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23326      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23327      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23328      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23329      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23330      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23331      &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02,
23332      &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00,
23333      &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00,
23334      &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02,
23335      &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00,
23336      &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02,
23337      &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02,
23338      &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03,
23339      &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/
23340       DATA (DL(K),K= 2126, 2210) /
23341      &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00,
23342      &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01,
23343      &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02,
23344      &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00,
23345      &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02,
23346      &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02,
23347      &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03,
23348      &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02,
23349      &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00,
23350      &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01,
23351      &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02,
23352      &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00,
23353      &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02,
23354      &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02,
23355      &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03,
23356      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23357      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23358       DATA (DL(K),K= 2211, 2295) /
23359      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23360      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23361      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23362      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23363      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23364      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23365      &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23366      &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00,
23367      &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01,
23368      &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02,
23369      &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00,
23370      &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02,
23371      &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02,
23372      &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03,
23373      &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02,
23374      &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00,
23375      &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/
23376       DATA (DL(K),K= 2296, 2380) /
23377      &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02,
23378      &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00,
23379      &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02,
23380      &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02,
23381      &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03,
23382      &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03,
23383      &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00,
23384      &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01,
23385      &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03,
23386      &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01,
23387      &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03,
23388      &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03,
23389      &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03,
23390      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23391      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23392      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23393      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23394       DATA (DL(K),K= 2381, 2465) /
23395      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23396      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23397      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23398      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23399      &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23400      &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00,
23401      &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01,
23402      &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02,
23403      &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00,
23404      &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02,
23405      &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02,
23406      &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04,
23407      &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03,
23408      &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00,
23409      &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01,
23410      &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03,
23411      &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/
23412       DATA (DL(K),K= 2466, 2550) /
23413      &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03,
23414      &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03,
23415      &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03,
23416      &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03,
23417      &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01,
23418      &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02,
23419      &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03,
23420      &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01,
23421      &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03,
23422      &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03,
23423      &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04,
23424      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23425      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23426      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23427      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23428      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23429      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23430       DATA (DL(K),K= 2551, 2635) /
23431      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23432      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23433      &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03,
23434      &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00,
23435      &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01,
23436      &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03,
23437      &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00,
23438      &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03,
23439      &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03,
23440      &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04,
23441      &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03,
23442      &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00,
23443      &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01,
23444      &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03,
23445      &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01,
23446      &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03,
23447      &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/
23448       DATA (DL(K),K= 2636, 2720) /
23449      &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04,
23450      &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03,
23451      &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01,
23452      &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02,
23453      &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03,
23454      &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01,
23455      &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03,
23456      &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03,
23457      &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04,
23458      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23459      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23460      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23461      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23462      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23463      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23464      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23465      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23466       DATA (DL(K),K= 2721, 2805) /
23467      &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03,
23468      &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00,
23469      &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01,
23470      &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03,
23471      &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00,
23472      &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03,
23473      &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03,
23474      &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04,
23475      &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03,
23476      &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01,
23477      &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02,
23478      &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03,
23479      &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01,
23480      &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03,
23481      &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03,
23482      &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04,
23483      &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/
23484       DATA (DL(K),K= 2806, 2890) /
23485      &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01,
23486      &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02,
23487      &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04,
23488      &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01,
23489      &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04,
23490      &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04,
23491      &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04,
23492      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23493      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23494      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23495      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23496      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23497      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23498      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23499      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23500      &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03,
23501      &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/
23502       DATA (DL(K),K= 2891, 2975) /
23503      &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02,
23504      &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03,
23505      &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01,
23506      &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03,
23507      &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04,
23508      &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05,
23509      &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04,
23510      &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01,
23511      &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02,
23512      &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04,
23513      &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01,
23514      &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04,
23515      &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04,
23516      &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05,
23517      &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04,
23518      &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01,
23519      &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/
23520       DATA (DL(K),K= 2976, 3060) /
23521      &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04,
23522      &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01,
23523      &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04,
23524      &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04,
23525      &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05,
23526      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23527      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23528      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23529      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23530      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23531      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23532      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23533      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23534      &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04,
23535      &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01,
23536      &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02,
23537      &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/
23538       DATA (DL(K),K= 3061, 3145) /
23539      &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01,
23540      &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04,
23541      &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04,
23542      &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06,
23543      &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04,
23544      &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01,
23545      &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02,
23546      &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04,
23547      &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01,
23548      &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04,
23549      &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04,
23550      &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05,
23551      &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04,
23552      &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01,
23553      &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03,
23554      &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04,
23555      &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/
23556       DATA (DL(K),K= 3146, 3230) /
23557      &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05,
23558      &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05,
23559      &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05,
23560      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23561      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23562      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23563      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23564      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23565      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23566      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23567      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23568      &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04,
23569      &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01,
23570      &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02,
23571      &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04,
23572      &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01,
23573      &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/
23574       DATA (DL(K),K= 3231, 3315) /
23575      &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05,
23576      &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06,
23577      &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05,
23578      &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01,
23579      &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03,
23580      &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05,
23581      &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01,
23582      &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05,
23583      &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05,
23584      &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06,
23585      &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05,
23586      &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02,
23587      &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03,
23588      &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05,
23589      &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02,
23590      &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05,
23591      &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/
23592       DATA (DL(K),K= 3316, 3400) /
23593      &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07,
23594      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23595      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23596      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23597      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23598      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23599      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23600      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23601      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23602      &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05,
23603      &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01,
23604      &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03,
23605      &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05,
23606      &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01,
23607      &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05,
23608      &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05,
23609      &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/
23610       DATA (DL(K),K= 3401, 3485) /
23611      &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05,
23612      &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02,
23613      &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03,
23614      &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05,
23615      &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01,
23616      &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06,
23617      &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06,
23618      &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06,
23619      &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06,
23620      &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02,
23621      &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04,
23622      &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05,
23623      &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02,
23624      &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07,
23625      &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07,
23626      &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06,
23627      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23628       DATA (DL(K),K= 3486, 3570) /
23629      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23630      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23631      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23632      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23633      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23634      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23635      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23636      &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05,
23637      &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02,
23638      &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03,
23639      &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05,
23640      &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01,
23641      &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07,
23642      &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07,
23643      &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06,
23644      &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07,
23645      &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/
23646       DATA (DL(K),K= 3571, 3655) /
23647      &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04,
23648      &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05,
23649      &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02,
23650      &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07,
23651      &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07,
23652      &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06,
23653      &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07,
23654      &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03,
23655      &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04,
23656      &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06,
23657      &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02,
23658      &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07,
23659      &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07,
23660      &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07,
23661      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23662      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23663      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23664       DATA (DL(K),K= 3656, 3740) /
23665      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23666      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23667      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23668      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23669      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23670      &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07,
23671      &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02,
23672      &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04,
23673      &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06,
23674      &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02,
23675      &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06,
23676      &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06,
23677      &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06,
23678      &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06,
23679      &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03,
23680      &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04,
23681      &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/
23682       DATA (DL(K),K= 3741, 3825) /
23683      &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02,
23684      &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07,
23685      &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07,
23686      &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07,
23687      &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07,
23688      &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03,
23689      &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05,
23690      &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07,
23691      &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03,
23692      &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07,
23693      &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08,
23694      &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08,
23695      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23696      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23697      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23698      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23699      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23700       DATA (DL(K),K= 3826, 3910) /
23701      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23702      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23703      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23704      &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08,
23705      &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03,
23706      &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05,
23707      &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06,
23708      &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02,
23709      &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06,
23710      &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06,
23711      &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06,
23712      &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06,
23713      &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04,
23714      &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05,
23715      &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06,
23716      &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03,
23717      &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/
23718       DATA (DL(K),K= 3911, 3995) /
23719      &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07,
23720      &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07,
23721      &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07,
23722      &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04,
23723      &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06,
23724      &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06,
23725      &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04,
23726      &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07,
23727      &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07,
23728      &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07,
23729      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23730      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23731      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23732      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23733      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23734      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23735      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23736       DATA (DL(K),K= 3996, 4000) /
23737      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23738 C
23739       ANS = 0.
23740       IF (X.GT.0.9985) RETURN
23741       IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
23742 C
23743       IS  = S/DELTA+1
23744       IS1 = IS+1
23745       DO 1 L=1,25
23746          KL    = L+NDRV*25
23747          F1(L) = GF(I,IS,KL)
23748          F2(L) = GF(I,IS1,KL)
23749     1 CONTINUE
23750       A1 = DT_CKMTFF(X,F1)
23751       A2 = DT_CKMTFF(X,F2)
23752 C      A1=ALOG(A1)
23753 C      A2=ALOG(A2)
23754       S1  = (IS-1)*DELTA
23755       S2  = S1+DELTA
23756       ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
23757 C      ANS=EXP(ANS)
23758       RETURN
23759       END
23760 C
23761 C
23762
23763 *$ CREATE DT_CKMTPR.FOR
23764 *COPY DT_CKMTPR
23765       SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
23766 C
23767 C**********************************************************************
23768 C    Proton   - PDFs
23769 C    I   = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
23770 C    ANS = PDF(I)
23771 C    This version by S. Roesler, 31.01.96
23772 C**********************************************************************
23773
23774       SAVE
23775       DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
23776       EQUIVALENCE (GF(1,1,1),DL(1))
23777       DATA DELTA/.10/
23778 C
23779       DATA (DL(K),K=    1,   85) /
23780      &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00,
23781      &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00,
23782      &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01,
23783      &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00,
23784      &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00,
23785      &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00,
23786      &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00,
23787      &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00,
23788      &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00,
23789      &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00,
23790      &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02,
23791      &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00,
23792      &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01,
23793      &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00,
23794      &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01,
23795      &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00,
23796      &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/
23797       DATA (DL(K),K=   86,  170) /
23798      &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01,
23799      &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02,
23800      &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01,
23801      &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01,
23802      &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01,
23803      &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01,
23804      &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01,
23805      &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01,
23806      &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01,
23807      &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02,
23808      &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01,
23809      &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01,
23810      &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01,
23811      &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23812      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23813      &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00,
23814      &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/
23815       DATA (DL(K),K=  171,  255) /
23816      &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01,
23817      &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00,
23818      &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00,
23819      &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00,
23820      &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00,
23821      &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00,
23822      &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00,
23823      &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00,
23824      &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02,
23825      &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00,
23826      &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00,
23827      &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00,
23828      &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00,
23829      &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00,
23830      &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00,
23831      &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01,
23832      &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/
23833       DATA (DL(K),K=  256,  340) /
23834      &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01,
23835      &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01,
23836      &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01,
23837      &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01,
23838      &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01,
23839      &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01,
23840      &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01,
23841      &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02,
23842      &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01,
23843      &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01,
23844      &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01,
23845      &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23846      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23847      &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00,
23848      &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00,
23849      &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01,
23850      &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/
23851       DATA (DL(K),K=  341,  425) /
23852      &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00,
23853      &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00,
23854      &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00,
23855      &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00,
23856      &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00,
23857      &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00,
23858      &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01,
23859      &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00,
23860      &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00,
23861      &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00,
23862      &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00,
23863      &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00,
23864      &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00,
23865      &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00,
23866      &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02,
23867      &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00,
23868      &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/
23869       DATA (DL(K),K=  426,  510) /
23870      &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00,
23871      &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00,
23872      &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00,
23873      &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00,
23874      &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01,
23875      &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02,
23876      &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01,
23877      &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01,
23878      &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01,
23879      &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23880      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23881      &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00,
23882      &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00,
23883      &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01,
23884      &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00,
23885      &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00,
23886      &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/
23887       DATA (DL(K),K=  511,  595) /
23888      &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00,
23889      &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00,
23890      &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00,
23891      &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00,
23892      &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01,
23893      &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00,
23894      &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00,
23895      &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00,
23896      &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00,
23897      &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00,
23898      &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00,
23899      &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00,
23900      &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01,
23901      &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00,
23902      &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00,
23903      &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00,
23904      &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/
23905       DATA (DL(K),K=  596,  680) /
23906      &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00,
23907      &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00,
23908      &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00,
23909      &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02,
23910      &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00,
23911      &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00,
23912      &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00,
23913      &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23914      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23915      &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23916      &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00,
23917      &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01,
23918      &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00,
23919      &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00,
23920      &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00,
23921      &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00,
23922      &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/
23923       DATA (DL(K),K=  681,  765) /
23924      &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00,
23925      &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00,
23926      &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01,
23927      &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00,
23928      &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00,
23929      &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00,
23930      &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00,
23931      &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00,
23932      &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00,
23933      &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00,
23934      &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01,
23935      &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00,
23936      &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00,
23937      &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00,
23938      &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00,
23939      &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00,
23940      &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/
23941       DATA (DL(K),K=  766,  850) /
23942      &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00,
23943      &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01,
23944      &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00,
23945      &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00,
23946      &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00,
23947      &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23948      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23949      &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23950      &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00,
23951      &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01,
23952      &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00,
23953      &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00,
23954      &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00,
23955      &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00,
23956      &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01,
23957      &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00,
23958      &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/
23959       DATA (DL(K),K=  851,  935) /
23960      &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01,
23961      &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00,
23962      &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00,
23963      &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00,
23964      &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00,
23965      &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00,
23966      &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00,
23967      &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00,
23968      &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01,
23969      &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00,
23970      &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00,
23971      &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00,
23972      &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00,
23973      &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00,
23974      &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00,
23975      &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00,
23976      &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/
23977       DATA (DL(K),K=  936, 1020) /
23978      &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00,
23979      &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00,
23980      &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00,
23981      &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23982      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23983      &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23984      &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00,
23985      &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01,
23986      &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00,
23987      &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00,
23988      &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00,
23989      &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00,
23990      &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01,
23991      &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00,
23992      &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00,
23993      &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01,
23994      &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/
23995       DATA (DL(K),K= 1021, 1105) /
23996      &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00,
23997      &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00,
23998      &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00,
23999      &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01,
24000      &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00,
24001      &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00,
24002      &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01,
24003      &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00,
24004      &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00,
24005      &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00,
24006      &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00,
24007      &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01,
24008      &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00,
24009      &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00,
24010      &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01,
24011      &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00,
24012      &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/
24013       DATA (DL(K),K= 1106, 1190) /
24014      &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00,
24015      &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00,
24016      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24017      &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01,
24018      &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00,
24019      &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01,
24020      &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01,
24021      &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00,
24022      &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01,
24023      &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01,
24024      &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01,
24025      &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01,
24026      &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00,
24027      &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01,
24028      &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01,
24029      &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00,
24030      &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/
24031       DATA (DL(K),K= 1191, 1275) /
24032      &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01,
24033      &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01,
24034      &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01,
24035      &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00,
24036      &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00,
24037      &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01,
24038      &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00,
24039      &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01,
24040      &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01,
24041      &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01,
24042      &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01,
24043      &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00,
24044      &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00,
24045      &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01,
24046      &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00,
24047      &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01,
24048      &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/
24049       DATA (DL(K),K= 1276, 1360) /
24050      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24051      &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01,
24052      &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00,
24053      &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00,
24054      &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01,
24055      &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00,
24056      &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01,
24057      &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01,
24058      &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02,
24059      &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01,
24060      &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00,
24061      &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00,
24062      &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01,
24063      &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00,
24064      &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01,
24065      &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01,
24066      &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/
24067       DATA (DL(K),K= 1361, 1445) /
24068      &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01,
24069      &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00,
24070      &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00,
24071      &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01,
24072      &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00,
24073      &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01,
24074      &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01,
24075      &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01,
24076      &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01,
24077      &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00,
24078      &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00,
24079      &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01,
24080      &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00,
24081      &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01,
24082      &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00,
24083      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24084      &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/
24085       DATA (DL(K),K= 1446, 1530) /
24086      &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00,
24087      &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00,
24088      &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01,
24089      &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00,
24090      &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01,
24091      &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01,
24092      &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02,
24093      &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01,
24094      &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00,
24095      &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00,
24096      &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01,
24097      &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00,
24098      &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01,
24099      &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01,
24100      &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02,
24101      &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01,
24102      &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/
24103       DATA (DL(K),K= 1531, 1615) /
24104      &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00,
24105      &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01,
24106      &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00,
24107      &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01,
24108      &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01,
24109      &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02,
24110      &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01,
24111      &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00,
24112      &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00,
24113      &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01,
24114      &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00,
24115      &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01,
24116      &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24117      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24118      &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01,
24119      &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00,
24120      &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/
24121       DATA (DL(K),K= 1616, 1700) /
24122      &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01,
24123      &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00,
24124      &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01,
24125      &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01,
24126      &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02,
24127      &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01,
24128      &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00,
24129      &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00,
24130      &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01,
24131      &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00,
24132      &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01,
24133      &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01,
24134      &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02,
24135      &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01,
24136      &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00,
24137      &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00,
24138      &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/
24139       DATA (DL(K),K= 1701, 1785) /
24140      &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00,
24141      &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01,
24142      &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01,
24143      &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02,
24144      &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01,
24145      &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00,
24146      &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00,
24147      &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02,
24148      &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00,
24149      &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02,
24150      &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24151      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24152      &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01,
24153      &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00,
24154      &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00,
24155      &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01,
24156      &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/
24157       DATA (DL(K),K= 1786, 1870) /
24158      &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01,
24159      &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01,
24160      &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02,
24161      &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01,
24162      &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00,
24163      &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00,
24164      &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02,
24165      &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00,
24166      &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02,
24167      &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02,
24168      &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02,
24169      &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02,
24170      &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00,
24171      &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00,
24172      &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02,
24173      &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00,
24174      &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/
24175       DATA (DL(K),K= 1871, 1955) /
24176      &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02,
24177      &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02,
24178      &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02,
24179      &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00,
24180      &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01,
24181      &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02,
24182      &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00,
24183      &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02,
24184      &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24185      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24186      &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02,
24187      &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00,
24188      &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00,
24189      &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02,
24190      &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00,
24191      &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02,
24192      &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/
24193       DATA (DL(K),K= 1956, 2040) /
24194      &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03,
24195      &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02,
24196      &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00,
24197      &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00,
24198      &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02,
24199      &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00,
24200      &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02,
24201      &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02,
24202      &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03,
24203      &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02,
24204      &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00,
24205      &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01,
24206      &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02,
24207      &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00,
24208      &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02,
24209      &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02,
24210      &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/
24211       DATA (DL(K),K= 2041, 2125) /
24212      &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02,
24213      &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01,
24214      &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01,
24215      &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02,
24216      &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00,
24217      &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02,
24218      &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24219      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24220      &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02,
24221      &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00,
24222      &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00,
24223      &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02,
24224      &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00,
24225      &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02,
24226      &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02,
24227      &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03,
24228      &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/
24229       DATA (DL(K),K= 2126, 2210) /
24230      &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00,
24231      &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01,
24232      &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02,
24233      &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00,
24234      &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02,
24235      &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02,
24236      &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03,
24237      &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02,
24238      &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01,
24239      &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01,
24240      &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02,
24241      &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00,
24242      &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02,
24243      &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02,
24244      &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03,
24245      &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02,
24246      &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/
24247       DATA (DL(K),K= 2211, 2295) /
24248      &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01,
24249      &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02,
24250      &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00,
24251      &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02,
24252      &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24253      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24254      &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02,
24255      &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00,
24256      &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01,
24257      &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02,
24258      &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00,
24259      &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02,
24260      &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02,
24261      &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03,
24262      &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02,
24263      &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01,
24264      &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/
24265       DATA (DL(K),K= 2296, 2380) /
24266      &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02,
24267      &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00,
24268      &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02,
24269      &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02,
24270      &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03,
24271      &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02,
24272      &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01,
24273      &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01,
24274      &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02,
24275      &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00,
24276      &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03,
24277      &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03,
24278      &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03,
24279      &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03,
24280      &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01,
24281      &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01,
24282      &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/
24283       DATA (DL(K),K= 2381, 2465) /
24284      &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00,
24285      &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03,
24286      &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24287      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24288      &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02,
24289      &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00,
24290      &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01,
24291      &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02,
24292      &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00,
24293      &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02,
24294      &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02,
24295      &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04,
24296      &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02,
24297      &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01,
24298      &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01,
24299      &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03,
24300      &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/
24301       DATA (DL(K),K= 2466, 2550) /
24302      &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03,
24303      &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03,
24304      &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03,
24305      &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03,
24306      &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01,
24307      &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01,
24308      &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03,
24309      &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00,
24310      &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03,
24311      &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03,
24312      &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03,
24313      &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03,
24314      &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01,
24315      &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02,
24316      &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03,
24317      &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00,
24318      &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/
24319       DATA (DL(K),K= 2551, 2635) /
24320      &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24321      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24322      &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03,
24323      &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01,
24324      &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01,
24325      &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03,
24326      &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00,
24327      &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03,
24328      &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03,
24329      &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04,
24330      &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03,
24331      &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01,
24332      &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01,
24333      &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03,
24334      &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00,
24335      &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03,
24336      &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/
24337       DATA (DL(K),K= 2636, 2720) /
24338      &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04,
24339      &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03,
24340      &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01,
24341      &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02,
24342      &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03,
24343      &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00,
24344      &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03,
24345      &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03,
24346      &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04,
24347      &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03,
24348      &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01,
24349      &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02,
24350      &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03,
24351      &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01,
24352      &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03,
24353      &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24354      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24355       DATA (DL(K),K= 2721, 2805) /
24356      &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03,
24357      &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01,
24358      &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01,
24359      &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03,
24360      &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00,
24361      &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03,
24362      &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03,
24363      &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04,
24364      &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03,
24365      &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01,
24366      &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02,
24367      &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03,
24368      &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00,
24369      &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03,
24370      &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03,
24371      &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04,
24372      &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/
24373       DATA (DL(K),K= 2806, 2890) /
24374      &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01,
24375      &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02,
24376      &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03,
24377      &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01,
24378      &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04,
24379      &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04,
24380      &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04,
24381      &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04,
24382      &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01,
24383      &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02,
24384      &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04,
24385      &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01,
24386      &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04,
24387      &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24388      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24389      &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03,
24390      &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/
24391       DATA (DL(K),K= 2891, 2975) /
24392      &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02,
24393      &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03,
24394      &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00,
24395      &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03,
24396      &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03,
24397      &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05,
24398      &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04,
24399      &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01,
24400      &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02,
24401      &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04,
24402      &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00,
24403      &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04,
24404      &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04,
24405      &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05,
24406      &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04,
24407      &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01,
24408      &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/
24409       DATA (DL(K),K= 2976, 3060) /
24410      &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04,
24411      &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01,
24412      &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04,
24413      &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04,
24414      &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05,
24415      &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04,
24416      &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02,
24417      &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02,
24418      &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04,
24419      &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01,
24420      &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04,
24421      &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24422      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24423      &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04,
24424      &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01,
24425      &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02,
24426      &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/
24427       DATA (DL(K),K= 3061, 3145) /
24428      &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00,
24429      &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04,
24430      &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04,
24431      &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05,
24432      &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04,
24433      &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01,
24434      &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02,
24435      &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04,
24436      &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01,
24437      &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04,
24438      &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04,
24439      &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05,
24440      &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04,
24441      &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02,
24442      &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02,
24443      &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04,
24444      &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/
24445       DATA (DL(K),K= 3146, 3230) /
24446      &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04,
24447      &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04,
24448      &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05,
24449      &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05,
24450      &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02,
24451      &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03,
24452      &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05,
24453      &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01,
24454      &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05,
24455      &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24456      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24457      &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04,
24458      &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01,
24459      &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02,
24460      &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04,
24461      &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01,
24462      &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/
24463       DATA (DL(K),K= 3231, 3315) /
24464      &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04,
24465      &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06,
24466      &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04,
24467      &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02,
24468      &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03,
24469      &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05,
24470      &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01,
24471      &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05,
24472      &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05,
24473      &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06,
24474      &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05,
24475      &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02,
24476      &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03,
24477      &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05,
24478      &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01,
24479      &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05,
24480      &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/
24481       DATA (DL(K),K= 3316, 3400) /
24482      &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06,
24483      &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05,
24484      &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02,
24485      &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03,
24486      &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05,
24487      &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01,
24488      &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05,
24489      &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24490      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24491      &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05,
24492      &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02,
24493      &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03,
24494      &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05,
24495      &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01,
24496      &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05,
24497      &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05,
24498      &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/
24499       DATA (DL(K),K= 3401, 3485) /
24500      &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05,
24501      &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02,
24502      &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03,
24503      &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05,
24504      &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01,
24505      &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05,
24506      &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05,
24507      &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07,
24508      &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05,
24509      &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02,
24510      &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03,
24511      &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05,
24512      &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01,
24513      &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06,
24514      &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06,
24515      &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06,
24516      &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/
24517       DATA (DL(K),K= 3486, 3570) /
24518      &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03,
24519      &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04,
24520      &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06,
24521      &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02,
24522      &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06,
24523      &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24524      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24525      &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05,
24526      &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02,
24527      &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03,
24528      &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06,
24529      &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01,
24530      &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06,
24531      &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06,
24532      &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07,
24533      &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06,
24534      &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/
24535       DATA (DL(K),K= 3571, 3655) /
24536      &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03,
24537      &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06,
24538      &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01,
24539      &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06,
24540      &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06,
24541      &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07,
24542      &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06,
24543      &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03,
24544      &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04,
24545      &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06,
24546      &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02,
24547      &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07,
24548      &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07,
24549      &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07,
24550      &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07,
24551      &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03,
24552      &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/
24553       DATA (DL(K),K= 3656, 3740) /
24554      &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06,
24555      &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02,
24556      &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07,
24557      &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00,
24558      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24559      &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07,
24560      &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02,
24561      &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04,
24562      &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07,
24563      &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01,
24564      &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07,
24565      &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07,
24566      &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07,
24567      &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07,
24568      &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03,
24569      &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04,
24570      &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/
24571       DATA (DL(K),K= 3741, 3825) /
24572      &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02,
24573      &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07,
24574      &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07,
24575      &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07,
24576      &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07,
24577      &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03,
24578      &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04,
24579      &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07,
24580      &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02,
24581      &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07,
24582      &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07,
24583      &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08,
24584      &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07,
24585      &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04,
24586      &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05,
24587      &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09,
24588      &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/
24589       DATA (DL(K),K= 3826, 3910) /
24590      &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08,
24591      &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00,
24592      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24593      &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08,
24594      &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03,
24595      &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05,
24596      &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06,
24597      &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02,
24598      &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07,
24599      &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07,
24600      &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07,
24601      &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07,
24602      &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04,
24603      &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05,
24604      &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06,
24605      &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03,
24606      &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/
24607       DATA (DL(K),K= 3911, 3995) /
24608      &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07,
24609      &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07,
24610      &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07,
24611      &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04,
24612      &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06,
24613      &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07,
24614      &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03,
24615      &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07,
24616      &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07,
24617      &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07,
24618      &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07,
24619      &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05,
24620      &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06,
24621      &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07,
24622      &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04,
24623      &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08,
24624      &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/
24625       DATA (DL(K),K= 3996, 4000) /
24626      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24627 C
24628       ANS = 0.
24629       IF (X.GT.0.9985) RETURN
24630       IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
24631 C
24632       IS  = S/DELTA+1
24633       IS1 = IS+1
24634       DO 1 L=1,25
24635          KL    = L+NDRV*25
24636          F1(L) = GF(I,IS,KL)
24637          F2(L) = GF(I,IS1,KL)
24638     1 CONTINUE
24639       A1 = DT_CKMTFF(X,F1)
24640       A2 = DT_CKMTFF(X,F2)
24641 C      A1=ALOG(A1)
24642 C      A2=ALOG(A2)
24643       S1  = (IS-1)*DELTA
24644       S2  = S1+DELTA
24645       ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
24646 C      ANS=EXP(ANS)
24647       RETURN
24648       END
24649 C
24650
24651 *$ CREATE DT_CKMTFF.FOR
24652 *COPY DT_CKMTFF
24653       FUNCTION DT_CKMTFF(X,FVL)
24654 C**********************************************************************
24655 C
24656 C     LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
24657 C     FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
24658 C     NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
24659 C     IN MAIN ROUTINE.
24660 C
24661 C**********************************************************************
24662
24663       SAVE
24664       DIMENSION FVL(25),XGRID(25)
24665       DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
24666      *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
24667 C
24668       DT_CKMTFF=0.
24669       DO 1 I=1,NX
24670       IF(X.LT.XGRID(I)) GO TO 2
24671     1 CONTINUE
24672     2 I=I-1
24673       IF(I.EQ.0) THEN
24674          I=I+1
24675       ELSE IF(I.GT.23) THEN
24676          I=23
24677       ENDIF
24678       J=I+1
24679       K=J+1
24680       AXI=LOG(XGRID(I))
24681       BXI=LOG(1.-XGRID(I))
24682       AXJ=LOG(XGRID(J))
24683       BXJ=LOG(1.-XGRID(J))
24684       AXK=LOG(XGRID(K))
24685       BXK=LOG(1.-XGRID(K))
24686       FI=LOG(ABS(FVL(I)) +1.E-15)
24687       FJ=LOG(ABS(FVL(J)) +1.E-16)
24688       FK=LOG(ABS(FVL(K)) +1.E-17)
24689       DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
24690       ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
24691      $ BXI))/DET
24692       ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
24693       BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
24694       IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
24695      1RETURN
24696 C      IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
24697 C         WRITE(6,2001) X,FVL
24698 C 2001    FORMAT(8E12.4)
24699 C         WRITE(6,2001) ALPHA,BETA,ALOGA,DET
24700 C      ENDIF
24701       DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
24702       RETURN
24703       END
24704
24705 *$ CREATE DT_FLUINI.FOR
24706 *COPY DT_FLUINI
24707 *
24708 *===fluini=============================================================*
24709 *
24710       SUBROUTINE DT_FLUINI
24711
24712 ************************************************************************
24713 * Initialisation of the nucleon-nucleon cross section fluctuation      *
24714 * treatment. The original version by J. Ranft.                         *
24715 * This version dated 21.04.95 is revised by S. Roesler.                *
24716 ************************************************************************
24717
24718       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24719       SAVE
24720       PARAMETER ( LINP = 10 ,
24721      &            LOUT = 6 ,
24722      &            LDAT = 9 )
24723       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
24724
24725       PARAMETER ( A     = 0.1D0,
24726      &            B     = 0.893D0,
24727      &            OM    = 1.1D0,
24728      &            N     = 6,
24729      &            DX    = 0.003D0)
24730
24731 * n-n cross section fluctuations
24732       PARAMETER (NBINS = 1000)
24733       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
24734       DIMENSION FLUSI(NBINS),FLUIX(NBINS)
24735
24736       WRITE(LOUT,1000)
24737  1000 FORMAT(/,1X,'FLUINI:  hadronic cross section fluctuations ',
24738      &       'treated')
24739
24740       FLUSU  = ZERO
24741       FLUSUU = ZERO
24742
24743       DO 1 I=1,NBINS
24744          X        = DBLE(I)*DX
24745          FLUIX(I) = X
24746          FLUS     = ((X-B)/(OM*B))**N
24747          IF (FLUS.LE.20.0D0) THEN
24748             FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
24749          ELSE
24750             FLUSI(I) = ZERO
24751          ENDIF
24752          FLUSU = FLUSU+FLUSI(I)
24753     1 CONTINUE
24754       DO 2 I=1,NBINS
24755          FLUSUU   = FLUSUU+FLUSI(I)/FLUSU
24756          FLUSI(I) = FLUSUU
24757     2 CONTINUE
24758
24759 C     WRITE(LOUT,1001)
24760 C1001 FORMAT(1X,'FLUCTUATIONS')
24761 C     CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
24762
24763       DO 3 I=1,NBINS
24764          AF = DBLE(I)*0.001D0
24765          DO 4 J=1,NBINS
24766             IF (AF.LE.FLUSI(J)) THEN
24767                FLUIXX(I) = FLUIX(J)
24768                GOTO 5
24769             ENDIF
24770     4    CONTINUE
24771     5    CONTINUE
24772     3 CONTINUE
24773       FLUIXX(1)     = FLUIX(1)
24774       FLUIXX(NBINS) = FLUIX(NBINS)
24775
24776       RETURN
24777       END
24778
24779 *$ CREATE DT_SIGTBL.FOR
24780 *COPY DT_SIGTBL
24781 *
24782 *===sigtab=============================================================*
24783 *
24784       SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
24785
24786 ************************************************************************
24787 * This version dated 18.11.95 is written by S. Roesler                 *
24788 ************************************************************************
24789
24790       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24791       SAVE
24792       PARAMETER ( LINP = 10 ,
24793      &            LOUT = 6 ,
24794      &            LDAT = 9 )
24795
24796       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24797      &           OHALF=0.5D0,ONE=1.0D0)
24798       PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150)
24799
24800       LOGICAL LINIT
24801
24802 * particle properties (BAMJET index convention)
24803       CHARACTER*8  ANAME
24804       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24805      &                IICH(210),IIBAR(210),K1(210),K2(210)
24806
24807       DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23)
24808       DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0,
24809      &             0, 0, 3, 4, 0, 0, 0, 0, 0, 0,
24810      &             0, 0, 5/
24811       DATA LINIT /.FALSE./
24812
24813 * precalculation and tabulation of elastic cross sections
24814       IF (ABS(MODE).EQ.1) THEN
24815          IF (MODE.EQ.1)
24816      &      OPEN(LDAT,FILE='outdata0/sigtab.out',STATUS='UNKNOWN')
24817          PLABLX = LOG10(PLO)
24818          PLABHX = LOG10(PHI)
24819          DPLAB  = (PLABHX-PLABLX)/DBLE(NBINS)
24820          DO 1 I=1,NBINS+1
24821             PLAB = PLABLX+DBLE(I-1)*DPLAB
24822             PLAB = 10**PLAB
24823             DO 2 IPROJ=1,23
24824                IDX = IDSIG(IPROJ)
24825                IF (IDX.GT.0) THEN
24826 C                 CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
24827 C                 CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
24828                   DUMZER = ZERO
24829                   CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
24830                   CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
24831                ENDIF
24832     2       CONTINUE
24833             IF (MODE.EQ.1) THEN
24834                WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5),
24835      &                                (SIGEN(IDX,I),IDX=1,5)
24836  1000          FORMAT(F5.1,10F7.2)
24837             ENDIF
24838     1    CONTINUE
24839          IF (MODE.EQ.1) CLOSE(LDAT)
24840          LINIT = .TRUE.
24841       ELSE
24842          SIGE = -ONE
24843          IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
24844      &                           .AND.(PTOT.LE.PHI) ) THEN
24845             IDX = IDSIG(JP)
24846             IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
24847                PLABX = LOG10(PTOT)
24848                IF (PLABX.LE.PLABLX) THEN
24849                   I1 = 1
24850                   I2 = 1
24851                ELSEIF (PLABX.GE.PLABHX) THEN
24852                   I1 = NBINS+1
24853                   I2 = NBINS+1
24854                ELSE
24855                   I1 = INT((PLABX-PLABLX)/DPLAB)+1
24856                   I2 = I1+1
24857                ENDIF
24858                PLAB1X = PLABLX+DBLE(I1-1)*DPLAB
24859                PLAB2X = PLABLX+DBLE(I2-1)*DPLAB
24860                PBIN   = PLAB2X-PLAB1X
24861                IF (PBIN.GT.TINY10) THEN
24862                   RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X)
24863                ELSE
24864                   RATX = ZERO
24865                ENDIF
24866                IF (JT.EQ.1) THEN
24867                   SIG1 = SIGEP(IDX,I1)
24868                   SIG2 = SIGEP(IDX,I2)
24869                ELSE
24870                   SIG1 = SIGEN(IDX,I1)
24871                   SIG2 = SIGEN(IDX,I2)
24872                ENDIF
24873                SIGE = SIG1+RATX*(SIG2-SIG1)
24874             ENDIF
24875          ENDIF
24876       ENDIF
24877
24878       RETURN
24879       END
24880
24881 *$ CREATE DT_XSTABL.FOR
24882 *COPY DT_XSTABL
24883 *
24884 *===xstabl=============================================================*
24885 *
24886       SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
24887
24888       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24889       SAVE
24890       PARAMETER ( LINP = 10 ,
24891      &            LOUT = 6 ,
24892      &            LDAT = 9 )
24893       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24894      &           OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
24895       LOGICAL LLAB,LELOG,LQLOG
24896
24897 * particle properties (BAMJET index convention)
24898       CHARACTER*8  ANAME
24899       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24900      &                IICH(210),IIBAR(210),K1(210),K2(210)
24901 * properties of interacting particles
24902       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
24903       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
24904 * Glauber formalism: cross sections
24905       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
24906      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
24907      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
24908      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
24909      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
24910      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
24911      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
24912      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
24913      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
24914      &                BSLOPE,NEBINI,NQBINI
24915 * emulsion treatment
24916       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
24917      &                NCOMPO,IEMUL
24918
24919       DIMENSION WHAT(6)
24920
24921       LLAB   = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
24922       ELO    = ABS(WHAT(1))
24923       EHI    = ABS(WHAT(2))
24924       IF (ELO.GT.EHI) ELO = EHI
24925       LELOG  = WHAT(3).LT.ZERO
24926       NEBINS = MAX(INT(ABS(WHAT(3))),1)
24927       DEBINS = (EHI-ELO)/DBLE(NEBINS)
24928       IF (LELOG) THEN
24929          AELO   = LOG10(ELO)
24930          AEHI   = LOG10(EHI)
24931          ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
24932       ENDIF
24933       Q2LO   = WHAT(4)
24934       Q2HI   = WHAT(5)
24935       IF (Q2LO.GT.Q2HI) Q2LO = Q2HI
24936       LQLOG  = WHAT(6).LT.ZERO
24937       NQBINS = MAX(INT(ABS(WHAT(6))),1)
24938       DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS)
24939       IF (LQLOG) THEN
24940          AQ2LO  = LOG10(Q2LO)
24941          AQ2HI  = LOG10(Q2HI)
24942          ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
24943       ENDIF
24944
24945       IF ( ELO.EQ. EHI) NEBINS = 0
24946       IF (Q2LO.EQ.Q2HI) NQBINS = 0
24947
24948       WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT
24949  1000 FORMAT(/,1X,'XSTABL:  E_lo  =',E10.3,' GeV  E_hi  =',E10.3,
24950      &       ' GeV     Lab = ',L1,'  qel: ',I2,/,10X,'Q2_lo =',F10.5,
24951      &       ' GeV^2  Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2,
24952      &       '   A_p = ',I3,'   A_t = ',I3,/)
24953
24954 C     IF (IJPROJ.NE.7) THEN
24955          WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)'
24956 * normalize fractions of emulsion components
24957          IF (NCOMPO.GT.0) THEN
24958             SUMFRA = ZERO
24959             DO 10 I=1,NCOMPO
24960                SUMFRA = SUMFRA+EMUFRA(I)
24961    10       CONTINUE
24962             IF (SUMFRA.GT.ZERO) THEN
24963                DO 11 I=1,NCOMPO
24964                   EMUFRA(I) = EMUFRA(I)/SUMFRA
24965    11          CONTINUE
24966             ENDIF
24967          ENDIF
24968 C     ELSE
24969 C        WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
24970 C     ENDIF
24971       DO 1 I=1,NEBINS+1
24972          IF (LELOG) THEN
24973             E = 10**(AELO+DBLE(I-1)*ADEBIN)
24974          ELSE
24975             E = ELO+DBLE(I-1)*DEBINS
24976          ENDIF
24977          DO 2 J=1,NQBINS+1
24978             IF (LQLOG) THEN
24979                Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
24980             ELSE
24981                Q2 = Q2LO+DBLE(J-1)*DQBINS
24982             ENDIF
24983 c            IF (IJPROJ.NE.7) THEN
24984                IF (LLAB) THEN
24985                   PLAB = ZERO
24986                   ECM  = ZERO
24987                   CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
24988                ELSE
24989                   ECM = E
24990                ENDIF
24991                XI  = ZERO
24992                Q2I = ZERO
24993                IF (IJPROJ.EQ.7) Q2I = Q2
24994                IF (NCOMPO.GT.0) THEN
24995                   DO 20 IC=1,NCOMPO
24996                      IIT = IEMUMA(IC)
24997                      CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
24998    20             CONTINUE
24999                ELSE
25000                   CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
25001 C                 CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
25002                ENDIF
25003                IF (NCOMPO.GT.0) THEN
25004                   XTOT = ZERO
25005                   ETOT = ZERO
25006                   XELA = ZERO
25007                   EELA = ZERO
25008                   XQEP = ZERO
25009                   EQEP = ZERO
25010                   XQET = ZERO
25011                   EQET = ZERO
25012                   XQE2 = ZERO
25013                   EQE2 = ZERO
25014                   XPRO = ZERO
25015                   EPRO = ZERO
25016                   XPRO1= ZERO
25017                   XDEL = ZERO
25018                   EDEL = ZERO
25019                   XDQE = ZERO
25020                   EDQE = ZERO
25021                   DO 21 IC=1,NCOMPO
25022                      XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC)
25023                      ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2
25024                      XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC)
25025                      EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2
25026                      XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC)
25027                      EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2
25028                      XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC)
25029                      EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2
25030                      XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC)
25031                      EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2
25032                      XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC)
25033                      EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2
25034                      XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC)
25035                      EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2
25036                      XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC)
25037                      EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2
25038                      YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC)
25039      &                     -XSQEP(1,1,IC)-XSQET(1,1,IC)
25040      &                     -XSQE2(1,1,IC)
25041                      XPRO1= XPRO1+EMUFRA(IC)*YPRO
25042    21             CONTINUE
25043                   ETOT = SQRT(ETOT)
25044                   EELA = SQRT(EELA)
25045                   EQEP = SQRT(EQEP)
25046                   EQET = SQRT(EQET)
25047                   EQE2 = SQRT(EQE2)
25048                   EPRO = SQRT(EPRO)
25049                   EDEL = SQRT(EDEL)
25050                   EDQE = SQRT(EDQE)
25051                   WRITE(LOUT,'(8E9.3)')
25052      &               E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
25053 C                 WRITE(LOUT,'(4E9.3)')
25054 C    &               E,XDEL,XDQE,XDEL+XDQE
25055                ELSE
25056                   WRITE(LOUT,'(11E10.3)')
25057      &              E,
25058      &              XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1),
25059      &              XSQE2(1,1,1),XSPRO(1,1,1),
25060      &              XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1)
25061      &             -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1),
25062      &              XSDEL(1,1,1)+XSDQE(1,1,1)
25063 C                 WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
25064 C    &                                    XSDEL(1,1,1)+XSDQE(1,1,1)
25065                ENDIF
25066 c            ELSE
25067 c               IF (LLAB) THEN
25068 c                  IF (IT.GT.1) THEN
25069 c                     IF (IXSQEL.EQ.0) THEN
25070 cC                       CALL DT_SIGGA(IT,  Q2, E,ZERO,ZERO,
25071 cC                       CALL DT_SIGGA(IT,   E,Q2,ZERO,ZERO,
25072 c                        CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
25073 c     &                             STOT,ETOT,SIN,EIN,STOT0)
25074 c                        IF (IRATIO.EQ.1) THEN
25075 c                           CALL DT_SIGGP(  Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
25076 cC                          CALL DT_SIGGP(   E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
25077 cC                          CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
25078 c*!! save cross sections
25079 c                           STOTA = STOT
25080 c                           ETOTA = ETOT
25081 c                           STOTP = STGP
25082 c*!!
25083 c                           STOT  = STOT/(DBLE(IT)*STGP)
25084 c                           SIN   =  SIN/(DBLE(IT)*SIGP)
25085 c                           STOT0 = STGP
25086 c                           ETOT  = ZERO
25087 c                           EIN   = ZERO
25088 c                        ENDIF
25089 c                     ELSE
25090 c                        WRITE(LOUT,*)
25091 c     &                  ' XSTABL:  qel. xs. not implemented for nuclei'
25092 c                        STOP
25093 c                     ENDIF
25094 c                  ELSE
25095 c                     ETOT = ZERO
25096 c                     EIN  = ZERO
25097 c                     STOT0= ZERO
25098 c                     IF (IXSQEL.EQ.0) THEN
25099 c                        CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
25100 c                     ELSE
25101 c                       SIN = ZERO
25102 c                       CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
25103 c                     ENDIF
25104 c                  ENDIF
25105 c               ELSE
25106 c                  IF (IT.GT.1) THEN
25107 c                     IF (IXSQEL.EQ.0) THEN
25108 c                        CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
25109 c     &                             STOT,ETOT,SIN,EIN,STOT0)
25110 c                        IF (IRATIO.EQ.1) THEN
25111 c                           CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
25112 c*!! save cross sections
25113 c                           STOTA = STOT
25114 c                           ETOTA = ETOT
25115 c                           STOTP = STGP
25116 c*!!
25117 c                           STOT  = STOT/(DBLE(IT)*STGP)
25118 c                           SIN   =  SIN/(DBLE(IT)*SIGP)
25119 c                           STOT0 = STGP
25120 c                           ETOT  = ZERO
25121 c                           EIN   = ZERO
25122 c                        ENDIF
25123 c                     ELSE
25124 c                        WRITE(LOUT,*)
25125 c     &                  ' XSTABL:  qel. xs. not implemented for nuclei'
25126 c                        STOP
25127 c                     ENDIF
25128 c                  ELSE
25129 c                     ETOT = ZERO
25130 c                     EIN  = ZERO
25131 c                     STOT0= ZERO
25132 c                     IF (IXSQEL.EQ.0) THEN
25133 c                        CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
25134 c                     ELSE
25135 c                       SIN = ZERO
25136 c                       CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
25137 c                     ENDIF
25138 c                  ENDIF
25139 c               ENDIF
25140 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
25141 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
25142 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
25143 c               WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
25144 c            ENDIF
25145     2    CONTINUE
25146     1 CONTINUE
25147
25148       RETURN
25149       END
25150
25151 *$ CREATE DT_TESTXS.FOR
25152 *COPY DT_TESTXS
25153 *
25154 *===testxs=============================================================*
25155 *
25156       SUBROUTINE DT_TESTXS
25157
25158       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25159       SAVE
25160
25161       DIMENSION XSTOT(26,2),XSELA(26,2)
25162
25163       OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN')
25164       OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN')
25165       OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN')
25166       OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN')
25167       DUMECM = 0.0D0
25168       PLABL = 0.01D0
25169       PLABH = 10000.0D0
25170       NBINS = 120
25171       APLABL = LOG10(PLABL)
25172       APLABH = LOG10(PLABH)
25173       ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
25174       DO 1 I=1,NBINS+1
25175          ADP = APLABL+DBLE(I-1)*ADPLAB
25176          P = 10.0D0**ADP
25177          DO 2 J=1,26
25178             CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1))
25179             CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2))
25180     2    CONTINUE
25181          WRITE(10,1000) P,(XSTOT(K,1),K=1,26)
25182          WRITE(11,1000) P,(XSELA(K,1),K=1,26)
25183          WRITE(12,1000) P,(XSTOT(K,2),K=1,26)
25184          WRITE(13,1000) P,(XSELA(K,2),K=1,26)
25185     1 CONTINUE
25186  1000 FORMAT(F8.3,26F9.3)
25187
25188       RETURN
25189       END
25190
25191 ************************************************************************
25192 *                                                                      *
25193 *  DTUNUC 2.0:   library routines                                      *
25194 *                                   processed by S. Roesler, 6.5.95    *
25195 *                                                                      *
25196 ************************************************************************
25197 *
25198 *     1) Handling of parton momenta
25199 *          SUBROUTINE MASHEL
25200 *          SUBROUTINE DFERMI
25201 *
25202 *     2) Handling of parton flavors and particle indices
25203 *          INTEGER FUNCTION IPDG2B
25204 *          INTEGER FUNCTION IB2PDG
25205 *          INTEGER FUNCTION IQUARK
25206 *          INTEGER FUNCTION IBJQUA
25207 *          INTEGER FUNCTION ICIHAD
25208 *          INTEGER FUNCTION IPDGHA
25209 *          INTEGER FUNCTION MCHAD
25210 *          SUBROUTINE FLAHAD
25211 *
25212 *     3) Energy-momentum and quantum number conservation check routines
25213 *          SUBROUTINE EMC1
25214 *          SUBROUTINE EMC2
25215 *          SUBROUTINE EVTEMC
25216 *          SUBROUTINE EVTFLC
25217 *          SUBROUTINE EVTCHG
25218 *
25219 *     4) Transformations
25220 *          SUBROUTINE LTINI
25221 *          SUBROUTINE LTRANS
25222 *          SUBROUTINE LTNUC
25223 *          SUBROUTINE DALTRA
25224 *          SUBROUTINE DTRAFO
25225 *          SUBROUTINE STTRAN
25226 *          SUBROUTINE MYTRAN
25227 *          SUBROUTINE LT2LAO
25228 *          SUBROUTINE LT2LAB
25229 *
25230 *     5) Sampling from distributions
25231 *          INTEGER FUNCTION NPOISS
25232 *          DOUBLE PRECISION FUNCTION SAMPXB
25233 *          DOUBLE PRECISION FUNCTION SAMPEX
25234 *          DOUBLE PRECISION FUNCTION SAMSQX
25235 *          DOUBLE PRECISION FUNCTION BETREJ
25236 *          DOUBLE PRECISION FUNCTION DGAMRN
25237 *          DOUBLE PRECISION FUNCTION DBETAR
25238 *          SUBROUTINE RANNOR
25239 *          SUBROUTINE DPOLI
25240 *          SUBROUTINE DSFECF
25241 *          SUBROUTINE RACO
25242 *
25243 *     6) Special functions, algorithms and service routines
25244 *          DOUBLE PRECISION FUNCTION YLAMB
25245 *          SUBROUTINE SORT
25246 *          SUBROUTINE SORT1
25247 *          SUBROUTINE DT_XTIME
25248 *
25249 *     7) Random number generator package
25250 *          DOUBLE PRECISION FUNCTION DT_RNDM
25251 *          SUBROUTINE DT_RNDMST
25252 *          SUBROUTINE DT_RNDMIN
25253 *          SUBROUTINE DT_RNDMOU
25254 *          SUBROUTINE DT_RNDMTE
25255 *
25256 ************************************************************************
25257 *                                                                      *
25258 *                 1) Handling of parton momenta                        *
25259 *                                                                      *
25260 ************************************************************************
25261 *$ CREATE DT_MASHEL.FOR
25262 *COPY DT_MASHEL
25263 *
25264 *===mashel=============================================================*
25265 *
25266       SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
25267
25268 ************************************************************************
25269 *                                                                      *
25270 *    rescaling of momenta of two partons to put both                   *
25271 *                                       on mass shell                  *
25272 *                                                                      *
25273 *    input:       PA1,PA2   input momentum vectors                     *
25274 *                 XM1,2     desired masses of particles afterwards     *
25275 *                 P1,P2     changed momentum vectors                   *
25276 *                                                                      *
25277 * The original version is written by R. Engel.                         *
25278 * This version dated 12.12.94 is modified by S. Roesler.               *
25279 ************************************************************************
25280
25281       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25282       SAVE
25283       PARAMETER ( LINP = 10 ,
25284      &            LOUT = 6 ,
25285      &            LDAT = 9 )
25286       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
25287
25288       DIMENSION PA1(4),PA2(4),P1(4),P2(4)
25289
25290       IREJ = 0
25291
25292 * Lorentz transformation into system CMS
25293       PX  = PA1(1)+PA2(1)
25294       PY  = PA1(2)+PA2(2)
25295       PZ  = PA1(3)+PA2(3)
25296       EE  = PA1(4)+PA2(4)
25297       XPTOT = SQRT(PX**2+PY**2+PZ**2)
25298       XMS   = (EE-XPTOT)*(EE+XPTOT)
25299       IF(XMS.LT.(XM1+XM2)**2) THEN
25300 C        WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
25301          GOTO 9999
25302       ENDIF
25303       XMS = SQRT(XMS)
25304       BGX = PX/XMS
25305       BGY = PY/XMS
25306       BGZ = PZ/XMS
25307       GAM = EE/XMS
25308       CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
25309      &           PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
25310 * rotation angles
25311       COD = P1(3)/PTOT1
25312 C     SID = SQRT((ONE-COD)*(ONE+COD))
25313       PPT = SQRT(P1(1)**2+P1(2)**2)
25314       SID = PPT/PTOT1
25315       COF = ONE
25316       SIF = ZERO
25317       IF(PTOT1*SID.GT.TINY10) THEN
25318          COF   = P1(1)/(SID*PTOT1)
25319          SIF   = P1(2)/(SID*PTOT1)
25320          ANORF = SQRT(COF*COF+SIF*SIF)
25321          COF   = COF/ANORF
25322          SIF   = SIF/ANORF
25323       ENDIF
25324 * new CM momentum and energies (for masses XM1,XM2)
25325       XM12 = SIGN(XM1**2,XM1)
25326       XM22 = SIGN(XM2**2,XM2)
25327       SS   = XMS**2
25328       PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
25329       EE1  = SQRT(XM12+PCMP**2)
25330       EE2  = XMS-EE1
25331 * back rotation
25332       MODE = 1
25333       CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
25334       CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
25335      &            PTOT1,P1(1),P1(2),P1(3),P1(4))
25336       CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
25337      &            PTOT2,P2(1),P2(2),P2(3),P2(4))
25338 * check consistency
25339       DEL = XMS*0.0001D0
25340       IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
25341         IDEV = 1
25342       ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
25343         IDEV = 2
25344       ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
25345         IDEV = 3
25346       ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
25347         IDEV = 4
25348       ELSE
25349         IDEV = 0
25350       ENDIF
25351       IF (IDEV.NE.0) THEN
25352          WRITE(LOUT,'(/1X,A,I3)')
25353      &      'MASHEL: inconsistent transformation',IDEV
25354          WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:'
25355          WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1
25356          WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2
25357          WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:'
25358          WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4)
25359          WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4)
25360       ENDIF
25361       RETURN
25362
25363  9999 CONTINUE
25364       IREJ = 1
25365       RETURN
25366       END
25367
25368 *$ CREATE DT_DFERMI.FOR
25369 *COPY DT_DFERMI
25370 *
25371 *===dfermi=============================================================*
25372 *
25373       SUBROUTINE DT_DFERMI(GPART)
25374
25375 ************************************************************************
25376 * Find largest of three random numbers.                                *
25377 ************************************************************************
25378
25379       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25380       SAVE
25381
25382       DIMENSION G(3)
25383
25384       DO 10 I=1,3
25385         G(I)=DT_RNDM(GPART)
25386    10 CONTINUE
25387       IF (G(3).LT.G(2)) GOTO 40
25388       IF (G(3).LT.G(1)) GOTO 30
25389       GPART = G(3)
25390    20 RETURN
25391    30 GPART = G(1)
25392       GOTO 20
25393    40 IF (G(2).LT.G(1)) GOTO 30
25394       GPART = G(2)
25395       GOTO 20
25396
25397       END
25398
25399 ************************************************************************
25400 *                                                                      *
25401 *         2) Handling of parton flavors and particle indices           *
25402 *                                                                      *
25403 ************************************************************************
25404 *$ CREATE IDT_IPDG2B.FOR
25405 *COPY IDT_IPDG2B
25406 *
25407 *===ipdg2b=============================================================*
25408 *
25409       INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
25410
25411 ************************************************************************
25412 *                                                                      *
25413 *     conversion of quark numbering scheme                             *
25414 *                                                                      *
25415 *     input:   PDG parton numbering                                    *
25416 *              for diquarks:  NN number of the constituent quark       *
25417 *                             (e.g. ID=2301,NN=1 -> ICONV2=1)          *
25418 *                                                                      *
25419 *     output:  BAMJET particle codes                                   *
25420 *              1 u     7 a-u   (MODE=1)  -1 a-u   (MODE=2)             *
25421 *              2 d     8 a-d             -2 a-d                        *
25422 *              3 s     9 a-s             -3 a-s                        *
25423 *              4 c    10 a-c             -4 a-c                        *
25424 *                                                                      *
25425 * This is a modified version of ICONV2 written by R. Engel.            *
25426 * This version dated 13.12.94 is written by S. Roesler.                *
25427 ************************************************************************
25428
25429       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25430       SAVE
25431       PARAMETER ( LINP = 10 ,
25432      &            LOUT = 6 ,
25433      &            LDAT = 9 )
25434
25435       IDA = ABS(ID)
25436 * diquarks
25437       IF (IDA.GT.6) THEN
25438         KF  = 3
25439         IF (IDA.GE.1000) KF = 4
25440         IDA = IDA/(10**(KF-NN))
25441         IDA = MOD(IDA,10)
25442       ENDIF
25443 * exchange up and dn quarks
25444       IF (IDA.EQ.1) THEN
25445         IDA = 2
25446       ELSEIF (IDA.EQ.2) THEN
25447         IDA = 1
25448       ENDIF
25449 * antiquarks
25450       IF (ID.LT.0) THEN
25451          IF (MODE.EQ.1) THEN
25452             IDA = IDA+6
25453          ELSE
25454             IDA = -IDA
25455          ENDIF
25456       ENDIF
25457       IDT_IPDG2B = IDA
25458
25459       RETURN
25460       END
25461
25462 *$ CREATE IDT_IB2PDG.FOR
25463 *COPY IDT_IB2PDG
25464 *
25465 *===ib2pdg=============================================================*
25466 *
25467       INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
25468
25469 ************************************************************************
25470 *                                                                      *
25471 *     conversion of quark numbering scheme                             *
25472 *                                                                      *
25473 *     input:   BAMJET particle codes                                   *
25474 *              1 u     7 a-u   (MODE=1)  -1 a-u   (MODE=2)             *
25475 *              2 d     8 a-d             -2 a-d                        *
25476 *              3 s     9 a-s             -3 a-s                        *
25477 *              4 c    10 a-c             -4 a-c                        *
25478 *                                                                      *
25479 *     output:  PDG parton numbering                                    *
25480 *                                                                      *
25481 * This version dated 13.12.94 is written by S. Roesler.                *
25482 ************************************************************************
25483
25484       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25485       SAVE
25486       PARAMETER ( LINP = 10 ,
25487      &            LOUT = 6 ,
25488      &            LDAT = 9 )
25489
25490       DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
25491       DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
25492       DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
25493      &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
25494      &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
25495
25496       IDA = ID1
25497       IDB = ID2
25498       IF (MODE.EQ.1) THEN
25499          IF (ID1.GT.6) IDA = -(ID1-6)
25500          IF (ID2.GT.6) IDB = -(ID2-6)
25501       ENDIF
25502       IF (ID2.EQ.0) THEN
25503          IDT_IB2PDG = IHKKQ(IDA)
25504       ELSE
25505          IDT_IB2PDG = IHKKQQ(IDA,IDB)
25506       ENDIF
25507
25508       RETURN
25509       END
25510
25511 *$ CREATE IDT_IQUARK.FOR
25512 *COPY IDT_IQUARK
25513 *
25514 *===ipdgqu=============================================================*
25515 *
25516       INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
25517
25518 ************************************************************************
25519 *                                                                      *
25520 *     quark contents according to PDG conventions                      *
25521 *     (random selection in case of quark mixing)                       *
25522 *                                                                      *
25523 *     input:   IDBAMJ BAMJET particle code                             *
25524 *              K      1..3   quark number                              *
25525 *                                                                      *
25526 *     output:  1   d  (anti --> neg.)                                  *
25527 *              2   u                                                   *
25528 *              3   s                                                   *
25529 *              4   c                                                   *
25530 *                                                                      *
25531 * This version written by R. Engel.                                    *
25532 ************************************************************************
25533
25534       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25535       SAVE
25536
25537       IQ = IDT_IBJQUA(K,IDBAMJ)
25538 * quark-antiquark
25539       IF (IQ.GT.6) THEN
25540          IQ = 6-IQ
25541       ENDIF
25542 * exchange of up and down
25543       IF (ABS(IQ).EQ.1) THEN
25544          IQ = SIGN(2,IQ)
25545       ELSEIF (ABS(IQ).EQ.2) THEN
25546          IQ = SIGN(1,IQ)
25547       ENDIF
25548       IDT_IQUARK = IQ
25549
25550       RETURN
25551       END
25552
25553 *$ CREATE IDT_IBJQUA.FOR
25554 *COPY IDT_IBJQUA
25555 *
25556 *===ibamq==============================================================*
25557 *
25558       INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
25559
25560 ************************************************************************
25561 *                                                                      *
25562 *     quark contents according to BAMJET conventions                   *
25563 *     (random selection in case of quark mixing)                       *
25564 *                                                                      *
25565 *     input:   IDBAMJ BAMJET particle code                             *
25566 *              K      1..3   quark number                              *
25567 *                                                                      *
25568 *     output:  1   u      7   u bar                                    *
25569 *              2   d      8   d bar                                    *
25570 *              3   s      9   s bar                                    *
25571 *              4   c     10   c bar                                    *
25572 *                                                                      *
25573 * This version written by R. Engel.                                    *
25574 ************************************************************************
25575
25576       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25577       SAVE
25578
25579       DIMENSION ITAB(3,210)
25580       DATA ((ITAB(I,K),I=1,3),K=1,30) /
25581      &    1,  1,  2,   7,  7,  8,   0,  0,  0,
25582      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25583      &    0,  0,  0,   1,  2,  2,   7,  8,  8,
25584 *sr 10.1.94
25585 C    &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25586      &    0,  0,  0,   0,  0,  0,   3,  8,  0,
25587 *
25588      &    1,  8,  0,   2,  7,  0,   1,  9,  0,
25589 *sr 10.1.94
25590 C    &    3,  7,  0,   0,  0,  0,   0,  0,  0,
25591      &    3,  7,  0,   3,  1,  2,   9,  7,  8,
25592 *sr 10.1.94
25593 C    &    0,  0,  0,   2,  2,  3,   1,  1,  3,
25594      &    2,  9,  0,   2,  2,  3,   1,  1,  3,
25595 *
25596      &    1,  2,  3, 201,202,  0,   2,  9,  0,
25597      &    3,  8,  0,   0,  0,  0,   0,  0,  0,
25598      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25599       DATA ((ITAB(I,K),I=1,3),K=31,60) /
25600      &    3,  9,  0,   1,  8,  0, 203,204,  0,
25601      &    2,  7,  0,   0,  0,  0,   1,  9,  0,
25602      &    2,  9,  0,   3,  7,  0,   3,  8,  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,   1,  1,  1,   1,  1,  2,
25608      &    1,  2,  2,   2,  2,  2,   0,  0,  0,
25609      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25610       DATA ((ITAB(I,K),I=1,3),K=61,90) /
25611      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25612      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25613      &    7,  7,  7,   7,  7,  8,   7,  8,  8,
25614      &    8,  8,  8,   0,  0,  0,   0,  0,  0,
25615      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25616      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25617      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25618      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25619      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25620      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25621       DATA ((ITAB(I,K),I=1,3),K=91,120) /
25622      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25623      &    0,  0,  0,   0,  0,  0,   3,  9,  0,
25624      &    1,  3,  3,   2,  3,  3,   7,  7,  9,
25625      &    7,  8,  9,   8,  8,  9,   7,  9,  9,
25626      &    8,  9,  9,   1,  1,  3,   1,  2,  3,
25627      &    2,  2,  3,   1,  3,  3,   2,  3,  3,
25628      &    3,  3,  3,   7,  7,  9,   7,  8,  9,
25629      &    8,  8,  9,   7,  9,  9,   8,  9,  9,
25630      &    9,  9,  9,   4,  7,  0,   4,  8,  0,
25631      &    2, 10,  0,   1, 10,  0,   4,  9,  0 /
25632       DATA ((ITAB(I,K),I=1,3),K=121,150) /
25633      &    3, 10,  0,   4, 10,  0,   4,  7,  0,
25634      &    4,  8,  0,   2, 10,  0,   1, 10,  0,
25635      &    4,  9,  0,   3, 10,  0,   4, 10,  0,
25636      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25637      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25638      &    0,  0,  0,   1,  2,  4,   1,  3,  4,
25639      &    2,  3,  4,   1,  1,  4,   0,  0,  0,
25640      &    2,  2,  4,   0,  0,  0,   0,  0,  0,
25641      &    3,  3,  4,   1,  4,  4,   2,  4,  4,
25642      &    3,  4,  4,   7,  8, 10,   7,  9, 10 /
25643       DATA ((ITAB(I,K),I=1,3),K=151,180) /
25644      &    8,  9, 10,   7,  7, 10,   0,  0,  0,
25645      &    8,  8, 10,   0,  0,  0,   0,  0,  0,
25646      &    9,  9, 10,   7, 10, 10,   8, 10, 10,
25647      &    9, 10, 10,   1,  1,  4,   1,  2,  4,
25648      &    2,  2,  4,   1,  3,  4,   2,  3,  4,
25649      &    3,  3,  4,   1,  4,  4,   2,  4,  4,
25650      &    3,  4,  4,   4,  4,  4,   7,  7, 10,
25651      &    7,  8, 10,   8,  8, 10,   7,  9, 10,
25652      &    8,  9, 10,   9,  9, 10,   7, 10, 10,
25653      &    8, 10, 10,   9, 10, 10,  10, 10, 10 /
25654       DATA ((ITAB(I,K),I=1,3),K=181,210) /
25655      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25656      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25657      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25658      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25659      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25660      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25661      &    0,  0,  0,   0,  0,  0,   1,  7,  0,
25662      &    2,  8,  0,   1,  7,  0,   2,  8,  0,
25663      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25664      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25665       DATA IDOLD /0/
25666
25667       ONE = 1.0D0
25668       IF (ITAB(1,IDBAMJ).LE.200) THEN
25669          ID = ITAB(K,IDBAMJ)
25670       ELSE
25671          IF(IDOLD.NE.IDBAMJ) THEN
25672             IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
25673      &           DT_RNDM(ONE)+ITAB(1,IDBAMJ))
25674         ELSE
25675            IDOLD = 0
25676         ENDIF
25677         ID = ITAB(K,IT)
25678       ENDIF
25679       IDOLD  = IDBAMJ
25680       IDT_IBJQUA = ID
25681
25682       RETURN
25683       END
25684
25685 *$ CREATE IDT_ICIHAD.FOR
25686 *COPY IDT_ICIHAD
25687 *
25688 *===icihad=============================================================*
25689 *
25690       INTEGER FUNCTION IDT_ICIHAD(MCIND)
25691
25692 ************************************************************************
25693 * Conversion of particle index PDG proposal --> BAMJET-index scheme    *
25694 * This is a completely new version dated 25.10.95.                     *
25695 * Renamed to be not in conflict with the modified PHOJET-version       *
25696 ************************************************************************
25697
25698       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25699       SAVE
25700
25701 * hadron index conversion (BAMJET <--> PDG)
25702       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25703      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25704      &                IAMCIN(210)
25705
25706       IDT_ICIHAD = 0
25707       KPDG   = ABS(MCIND)
25708       IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
25709       IF (MCIND.LT.0) THEN
25710          JSIGN = 1
25711       ELSE
25712          JSIGN = 2
25713       ENDIF
25714       IF (KPDG.GE.10000) THEN
25715          DO 1 I=1,19
25716             IDT_ICIHAD = IBAM5(JSIGN,I)
25717             IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
25718             IDT_ICIHAD = 0
25719     1    CONTINUE
25720       ELSEIF (KPDG.GE.1000) THEN
25721          DO 2 I=1,29
25722             IDT_ICIHAD = IBAM4(JSIGN,I)
25723             IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
25724             IDT_ICIHAD = 0
25725     2    CONTINUE
25726       ELSEIF (KPDG.GE.100) THEN
25727          DO 3 I=1,22
25728             IDT_ICIHAD = IBAM3(JSIGN,I)
25729             IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
25730             IDT_ICIHAD = 0
25731     3    CONTINUE
25732       ELSEIF (KPDG.GE.10) THEN
25733          DO 4 I=1,7
25734             IDT_ICIHAD = IBAM2(JSIGN,I)
25735             IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
25736             IDT_ICIHAD = 0
25737     4    CONTINUE
25738       ENDIF
25739     5 CONTINUE
25740
25741       RETURN
25742       END
25743
25744 *$ CREATE IDT_IPDGHA.FOR
25745 *COPY IDT_IPDGHA
25746 *
25747 *===ipdgha=============================================================*
25748 *
25749       INTEGER FUNCTION IDT_IPDGHA(MCIND)
25750
25751 ************************************************************************
25752 * Conversion of particle index BAMJET-index scheme --> PDG proposal    *
25753 * Adopted from the original by S. Roesler. This version dated 12.5.95  *
25754 * Renamed to be not in conflict with the modified PHOJET-version       *
25755 ************************************************************************
25756
25757       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25758       SAVE
25759
25760 * hadron index conversion (BAMJET <--> PDG)
25761       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25762      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25763      &                IAMCIN(210)
25764
25765       IDT_IPDGHA = IAMCIN(MCIND)
25766
25767       RETURN
25768       END
25769
25770 *$ CREATE DT_FLAHAD.FOR
25771 *COPY DT_FLAHAD
25772 *
25773 *===flahad=============================================================*
25774 *
25775       SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
25776
25777 ************************************************************************
25778 * sampling of FLAvor composition for HADrons/photons                   *
25779 *              ID         BAMJET-id of hadron                          *
25780 *              IF1,2,3    flavor content                               *
25781 *                         (u,d,s: 1,2,3;  au,ad,as: -1,-1,-3)          *
25782 * Note:  -  u,d numbering as in BAMJET                                 *
25783 *        -  ID .le. 30 !!                                              *
25784 * This version dated 12.03.96 is written by S. Roesler                 *
25785 ************************************************************************
25786
25787       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25788       SAVE
25789
25790 * auxiliary common for reggeon exchange (DTUNUC 1.x)
25791       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
25792      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
25793      &                IQTCHR(-6:6),MQUARK(3,39)
25794
25795       DIMENSION JSEL(3,6)
25796       DATA JSEL/ 1,2,3,  2,3,1,  3,1,2,  1,3,2,   2,1,3,   3,2,1/
25797
25798       ONE = 1.0D0
25799       IF (ID.EQ.7) THEN
25800 * photon (charge dependent flavour sampling)
25801          K = INT(DT_RNDM(ONE)*6.D0+1.D0)
25802          IF (K.LE.4) THEN
25803             IF1 = 2
25804             IF2 = -2
25805          ELSE IF(K.EQ.5) THEN
25806             IF1 = 1
25807             IF2 = -1
25808          ELSE
25809             IF1 = 3
25810             IF2 = -3
25811          ENDIF
25812          IF(DT_RNDM(ONE).LT.0.5D0) THEN
25813             K   = IF1
25814             IF1 = IF2
25815             IF2 = K
25816          ENDIF
25817          IF3 = 0
25818       ELSE
25819 * hadron
25820          IX  = INT(1.0D0+5.99999D0*DT_RNDM(ONE))
25821          IF1 = MQUARK(JSEL(1,IX),ID)
25822          IF2 = MQUARK(JSEL(2,IX),ID)
25823          IF3 = MQUARK(JSEL(3,IX),ID)
25824          IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN
25825             IF1 = IF3
25826             IF3 = 0
25827          ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
25828             IF2 = IF3
25829             IF3 = 0
25830          ENDIF
25831       ENDIF
25832
25833       RETURN
25834       END
25835
25836 *$ CREATE IDT_MCHAD.FOR
25837 *COPY IDT_MCHAD
25838 *
25839 *===mchad==============================================================*
25840 *
25841       INTEGER FUNCTION IDT_MCHAD(ITDTU)
25842
25843 ************************************************************************
25844 * Conversion of particle index BAMJET-index scheme --> HADRIN index s. *
25845 * Adopted from the original by S. Roesler. This version dated 6.5.95   *
25846 *                                                                      *
25847 * Last change 28.12.2006 by S. Roesler.                                *
25848 ************************************************************************
25849
25850       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25851       SAVE
25852
25853       DIMENSION ITRANS(210)
25854       DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14,
25855      &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13,
25856      &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8,
25857      &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2,
25858      &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1,
25859      &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9,
25860      &9, 9, 9, 85*- 1,7*-1,1,8,-1/
25861
25862       IF ( ITDTU .GT. 0 ) THEN
25863          IDT_MCHAD = ITRANS(ITDTU)
25864       ELSE
25865          IDT_MCHAD = -1
25866       END IF
25867
25868       RETURN
25869       END
25870
25871 ************************************************************************
25872 *                                                                      *
25873 *   3) Energy-momentum and quantum number conservation check routines  *
25874 *                                                                      *
25875 ************************************************************************
25876 *$ CREATE DT_EMC1.FOR
25877 *COPY DT_EMC1
25878 *
25879 *===emc1===============================================================*
25880 *
25881       SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
25882
25883 ************************************************************************
25884 * This version dated 15.12.94 is written by S. Roesler                 *
25885 ************************************************************************
25886
25887       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25888       SAVE
25889       PARAMETER ( LINP = 10 ,
25890      &            LOUT = 6 ,
25891      &            LDAT = 9 )
25892       PARAMETER (TINY10=1.0D-10)
25893
25894       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
25895
25896       IREJ = 0
25897
25898       IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
25899      &   WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
25900
25901       IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN
25902          IF (MODE.EQ.1) THEN
25903             CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM)
25904          ELSEIF (MODE.EQ.2) THEN
25905             CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM)
25906          ENDIF
25907          CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM)
25908          CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM)
25909          CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM)
25910       ELSEIF (MODE.LT.0) THEN
25911          IF (MODE.EQ.-1) THEN
25912             CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM)
25913          ELSEIF (MODE.EQ.-2) THEN
25914             CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM)
25915          ENDIF
25916          CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM)
25917          CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM)
25918          CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM)
25919       ENDIF
25920
25921       IF (ABS(MODE).EQ.3) THEN
25922          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1)
25923          IF (IREJ1.NE.0) GOTO 9999
25924       ENDIF
25925       RETURN
25926
25927  9999 CONTINUE
25928       IREJ = 1
25929       RETURN
25930       END
25931
25932 *$ CREATE DT_EMC2.FOR
25933 *COPY DT_EMC2
25934 *
25935 *===emc2===============================================================*
25936 *
25937       SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
25938      &                                                MODE,IPOS,IREJ)
25939
25940 ************************************************************************
25941 *             MODE = 1   energy-momentum cons. check                   *
25942 *                  = 2   flavor-cons. check                            *
25943 *                  = 3   energy-momentum & flavor cons. check          *
25944 *                  = 4   energy-momentum & charge cons. check          *
25945 *                  = 5   energy-momentum & flavor & charge cons. check *
25946 * This version dated 16.01.95 is written by S. Roesler                 *
25947 ************************************************************************
25948
25949       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25950       SAVE
25951       PARAMETER ( LINP = 10 ,
25952      &            LOUT = 6 ,
25953      &            LDAT = 9 )
25954       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
25955
25956 * event history
25957       PARAMETER (NMXHKK=200000)
25958       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25959      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25960      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25961 * extended event history
25962       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25963      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25964      &                IHIST(2,NMXHKK)
25965
25966       IREJ  = 0
25967       IREJ1 = 0
25968       IREJ2 = 0
25969       IREJ3 = 0
25970
25971       IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25972      &                CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM)
25973       IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25974      &                                CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM)
25975       IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM)
25976       DO 1 I=1,NHKK
25977          IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR.
25978      &       (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR.
25979      &       (ISTHKK(I).EQ.IP5))                          THEN
25980             IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25981      &                                    .OR.(MODE.EQ.5))
25982      &      CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
25983      &                                               2,IDUM,IDUM)
25984             IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25985      &         CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM)
25986             IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25987      &                            CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM)
25988          ENDIF
25989          IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR.
25990      &       (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR.
25991      &       (ISTHKK(I).EQ.IN5))                          THEN
25992             IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25993      &                                    .OR.(MODE.EQ.5))
25994      &      CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
25995      &                                                   2,IDUM,IDUM)
25996             IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25997      &         CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM)
25998             IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25999      &                            CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM)
26000          ENDIF
26001     1 CONTINUE
26002       IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
26003      &   CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1)
26004       IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
26005      &   CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2)
26006       IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3)
26007       IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999
26008
26009       RETURN
26010
26011  9999 CONTINUE
26012       IREJ = 1
26013       RETURN
26014       END
26015
26016 *$ CREATE DT_EVTEMC.FOR
26017 *COPY DT_EVTEMC
26018 *
26019 *===evtemc=============================================================*
26020 *
26021       SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
26022
26023 ************************************************************************
26024 * This version dated 13.12.94 is written by S. Roesler                 *
26025 ************************************************************************
26026
26027       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26028       SAVE
26029       PARAMETER ( LINP = 10 ,
26030      &            LOUT = 6 ,
26031      &            LDAT = 9 )
26032       PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10,
26033      &           ZERO=0.0D0)
26034
26035 * event history
26036       PARAMETER (NMXHKK=200000)
26037       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26038      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26039      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26040 * flags for input different options
26041       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
26042       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
26043      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
26044
26045       IREJ = 0
26046
26047       MODE = IMODE
26048       CHKLEV = TINY10
26049       IF (MODE.EQ.4) THEN
26050          CHKLEV = TINY2
26051          MODE   = 3
26052       ELSEIF (MODE.EQ.5) THEN
26053          CHKLEV = TINY1
26054          MODE   = 3
26055       ELSEIF (MODE.EQ.-1) THEN
26056          CHKLEV = EIO
26057          MODE   = 3
26058       ENDIF
26059
26060       IF (ABS(MODE).EQ.3) THEN
26061          PXDEV = PX
26062          PYDEV = PY
26063          PZDEV = PZ
26064          EDEV  = E
26065          IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4
26066          IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR.
26067      &       (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN
26068             IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)')
26069      &         'EVTEMC: energy-momentum cons. failure at pos. ',IPOS,
26070      &         '  event  ',NEVHKK,
26071      &         ' ! ',PXDEV,PYDEV,PZDEV,EDEV
26072             PX   = 0.0D0
26073             PY   = 0.0D0
26074             PZ   = 0.0D0
26075             E    = 0.0D0
26076             GOTO 9999
26077          ENDIF
26078          PX   = 0.0D0
26079          PY   = 0.0D0
26080          PZ   = 0.0D0
26081          E    = 0.0D0
26082          RETURN
26083       ENDIF
26084
26085       IF (MODE.EQ.1) THEN
26086          PX = 0.0D0
26087          PY = 0.0D0
26088          PZ = 0.0D0
26089          E  = 0.0D0
26090       ENDIF
26091
26092       PX = PX+PXIO
26093       PY = PY+PYIO
26094       PZ = PZ+PZIO
26095       E  = E+EIO
26096
26097       RETURN
26098
26099  9999 CONTINUE
26100       IREJ = 1
26101       RETURN
26102       END
26103
26104 *$ CREATE DT_EVTFLC.FOR
26105 *COPY DT_EVTFLC
26106 *
26107 *===evtflc=============================================================*
26108 *
26109       SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
26110
26111 ************************************************************************
26112 * Flavor conservation check.                                           *
26113 *        ID       identity of particle                                 *
26114 *        ID1 = 1  ID for q,aq,qq,aqaq in PDG-numbering scheme          *
26115 *            = 2  ID for particle/resonance in BAMJET numbering scheme *
26116 *            = 3  ID for particle/resonance in PDG    numbering scheme *
26117 *        MODE = 1 initialization and add ID                            *
26118 *             =-1 initialization and subtract ID                       *
26119 *             = 2 add ID                                               *
26120 *             =-2 subtract ID                                          *
26121 *             = 3 check flavor cons.                                   *
26122 *        IPOS     flag to give position of call of EVTFLC to output    *
26123 *                 unit in case of violation                            *
26124 * This version dated 10.01.95 is written by S. Roesler                 *
26125 ************************************************************************
26126
26127       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26128       SAVE
26129       PARAMETER ( LINP = 10 ,
26130      &            LOUT = 6 ,
26131      &            LDAT = 9 )
26132       PARAMETER (TINY10=1.0D-10)
26133
26134       IREJ = 0
26135
26136       IF (MODE.EQ.3) THEN
26137          IF (IFL.NE.0) THEN
26138             WRITE(LOUT,'(1X,A,I3,A,I3)')
26139      &         'EVTFLC: flavor-conservation failure at pos. ',IPOS,
26140      &         ' !  IFL = ',IFL
26141             IFL = 0
26142             GOTO 9999
26143          ENDIF
26144          IFL = 0
26145          RETURN
26146       ENDIF
26147
26148       IF (MODE.EQ.1) IFL = 0
26149       IF (ID.EQ.0)   RETURN
26150
26151       IF (ID1.EQ.1) THEN
26152          IDD = ABS(ID)
26153          NQ  = 1
26154          IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
26155          IF (IDD.GE.1000) NQ = 3
26156          DO 1 I=1,NQ
26157             IFBAM = IDT_IPDG2B(ID,I,2)
26158             IF (ABS(IFBAM).EQ.1) THEN
26159                IFBAM = SIGN(2,IFBAM)
26160             ELSEIF (ABS(IFBAM).EQ.2) THEN
26161                IFBAM = SIGN(1,IFBAM)
26162             ENDIF
26163             IF (MODE.GT.0) THEN
26164                IFL = IFL+IFBAM
26165             ELSE
26166                IFL = IFL-IFBAM
26167             ENDIF
26168     1    CONTINUE
26169          RETURN
26170       ENDIF
26171
26172       IDD = ID
26173       IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
26174       IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
26175          DO 2 I=1,3
26176             IF (MODE.GT.0) THEN
26177                IFL = IFL+IDT_IQUARK(I,IDD)
26178             ELSE
26179                IFL = IFL-IDT_IQUARK(I,IDD)
26180             ENDIF
26181     2    CONTINUE
26182       ENDIF
26183       RETURN
26184
26185  9999 CONTINUE
26186       IREJ = 1
26187       RETURN
26188       END
26189
26190 *$ CREATE DT_EVTCHG.FOR
26191 *COPY DT_EVTCHG
26192 *
26193 *===evtchg=============================================================*
26194 *
26195       SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
26196
26197 ************************************************************************
26198 * Charge conservation check.                                           *
26199 *        ID       identity of particle (PDG-numbering scheme)          *
26200 *        MODE = 1 initialization                                       *
26201 *             =-2 subtract ID-charge                                   *
26202 *             = 2 add ID-charge                                        *
26203 *             = 3 check charge cons.                                   *
26204 *        IPOS     flag to give position of call of EVTCHG to output    *
26205 *                 unit in case of violation                            *
26206 * This version dated 10.01.95 is written by S. Roesler                 *
26207 * Last change: s.r. 21.01.01                                           *
26208 ************************************************************************
26209
26210       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26211       SAVE
26212       PARAMETER ( LINP = 10 ,
26213      &            LOUT = 6 ,
26214      &            LDAT = 9 )
26215
26216 * event history
26217       PARAMETER (NMXHKK=200000)
26218       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26219      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26220      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26221 * particle properties (BAMJET index convention)
26222       CHARACTER*8  ANAME
26223       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26224      &                IICH(210),IIBAR(210),K1(210),K2(210)
26225
26226       IREJ = 0
26227
26228       IF (MODE.EQ.1) THEN
26229          ICH  = 0
26230          IBAR = 0
26231          RETURN
26232       ENDIF
26233
26234       IF (MODE.EQ.3) THEN
26235          IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN
26236             WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)')
26237      &         'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS,
26238      &         '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK
26239             ICH  = 0
26240             IBAR = 0
26241             GOTO 9999
26242          ENDIF
26243          ICH  = 0
26244          IBAR = 0
26245          RETURN
26246       ENDIF
26247
26248       IF (ID.EQ.0)   RETURN
26249
26250       IDD = IDT_ICIHAD(ID)
26251 * modification 21.1.01: use intrinsic phojet-functions to determine charge
26252 * and baryon number
26253 C     IF (IDD.GT.0) THEN
26254 C        IF (MODE.EQ.2) THEN
26255 C           ICH  = ICH+IICH(IDD)
26256 C           IBAR = IBAR+IIBAR(IDD)
26257 C        ELSEIF (MODE.EQ.-2) THEN
26258 C           ICH  = ICH-IICH(IDD)
26259 C           IBAR = IBAR-IIBAR(IDD)
26260 C        ENDIF
26261 C     ELSE
26262 C        WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
26263 C        CALL DT_EVTOUT(4)
26264 C        STOP
26265 C     ENDIF
26266       IF (MODE.EQ.2) THEN
26267          ICH  = ICH+IPHO_CHR3(ID,1)/3
26268          IBAR = IBAR+IPHO_BAR3(ID,1)/3
26269       ELSEIF (MODE.EQ.-2) THEN
26270          ICH  = ICH-IPHO_CHR3(ID,1)/3
26271          IBAR = IBAR-IPHO_BAR3(ID,1)/3
26272       ENDIF
26273
26274       RETURN
26275
26276  9999 CONTINUE
26277       IREJ = 1
26278       RETURN
26279       END
26280
26281 ************************************************************************
26282 *                                                                      *
26283 *                 4) Transformations                                   *
26284 *                                                                      *
26285 ************************************************************************
26286 *$ CREATE DT_LTINI.FOR
26287 *COPY DT_LTINI
26288 *
26289 *===ltini==============================================================*
26290 *
26291       SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
26292
26293 ************************************************************************
26294 * Initializations of Lorentz-transformations, calculation of Lorentz-  *
26295 * parameters.                                                          *
26296 * This version dated 13.11.95 is written by  S. Roesler.               *
26297 ************************************************************************
26298
26299       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26300       SAVE
26301       PARAMETER ( LINP = 10 ,
26302      &            LOUT = 6 ,
26303      &            LDAT = 9 )
26304       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,
26305      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
26306
26307 * Lorentz-parameters of the current interaction
26308       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26309      &                UMO,PPCM,EPROJ,PPROJ
26310 * properties of photon/lepton projectiles
26311       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
26312 * particle properties (BAMJET index convention)
26313       CHARACTER*8  ANAME
26314       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26315      &                IICH(210),IIBAR(210),K1(210),K2(210)
26316 * nucleon-nucleon event-generator
26317       CHARACTER*8 CMODEL
26318       LOGICAL LPHOIN
26319       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
26320
26321       Q2   = VIRT
26322       IDP  = IDPR
26323       IF (MCGENE.NE.3) THEN
26324 * lepton-projectiles and PHOJET: initialize real photon instead
26325          IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26326      &       (IDPR.EQ.10).OR.(IDPR.EQ.11).OR.
26327      &       (IDPR.EQ. 5).OR.(IDPR.EQ. 6))   THEN
26328             IDP = 7
26329             Q2  = ZERO
26330          ENDIF
26331       ENDIF
26332       IDT  = IDTA
26333       EPN  = EPN0
26334       PPN  = PPN0
26335       ECM  = ECM0
26336       AMP  = AAM(IDP)-SQRT(ABS(Q2))
26337       AMT  = AAM(IDT)
26338       AMP2 = SIGN(AMP**2,AMP)
26339       AMT2 = AMT**2
26340       IF (ECM0.GT.ZERO) THEN
26341          EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT)
26342          IF (AMP2.GT.ZERO) THEN
26343             PPN = SQRT((EPN+AMP)*(EPN-AMP))
26344          ELSE
26345             PPN = SQRT(EPN**2-AMP2)
26346          ENDIF
26347       ELSE
26348          IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26349             IF (IDP.EQ.7) EPN = ABS(EPN)
26350             IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP
26351             IF (AMP2.GT.ZERO) THEN
26352                PPN = SQRT((EPN+AMP)*(EPN-AMP))
26353             ELSE
26354                PPN = SQRT(EPN**2-AMP2)
26355             ENDIF
26356          ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26357             IF (AMP2.GT.ZERO) THEN
26358                EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
26359             ELSE
26360                EPN = SQRT(PPN**2+AMP2)
26361             ENDIF
26362          ENDIF
26363          ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
26364       ENDIF
26365       UMO   = ECM
26366       EPROJ = EPN
26367       PPROJ = PPN
26368       IF (AMP2.GT.ZERO) THEN
26369          ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
26370          PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
26371       ELSE
26372          ETARG = TINY10
26373          PTARG = TINY10
26374       ENDIF
26375 * photon-projectiles (get momentum in cm-frame for virtuality Q^2)
26376       IF (IDP.EQ.7) THEN
26377          PGAMM(1) = ZERO
26378          PGAMM(2) = ZERO
26379          AMGAM  = AMP
26380          AMGAM2 = AMP2
26381          IF (ECM0.GT.ZERO) THEN
26382             S = ECM0**2
26383          ELSE
26384             IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26385                S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0)
26386             ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26387                S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2)
26388             ENDIF
26389          ENDIF
26390          PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2
26391      &                     +AMGAM2**2+AMT2**2)/(4.0D0*S) )
26392          PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2)
26393          IF (MODE.EQ.1) THEN
26394             PNUCL(1) = ZERO
26395             PNUCL(2) = ZERO
26396             PNUCL(3) = -PGAMM(3)
26397             PNUCL(4) = SQRT(S)-PGAMM(4)
26398          ENDIF
26399       ENDIF
26400       IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26401      &    (IDPR.EQ.10).OR.(IDPR.EQ.11))   THEN
26402          PLEPT0(1) = ZERO
26403          PLEPT0(2) = ZERO
26404 * neglect lepton masses
26405 C        AMLPT2   = AAM(IDPR)**2
26406          AMLPT2   = ZERO
26407 *
26408          IF (ECM0.GT.ZERO) THEN
26409             S = ECM0**2
26410          ELSE
26411             IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26412                S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0)
26413             ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26414                S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2)
26415             ENDIF
26416          ENDIF
26417          PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2
26418      &                     +AMLPT2**2+AMT2**2)/(4.0D0*S) )
26419          PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2)
26420          PNUCL(1) = ZERO
26421          PNUCL(2) = ZERO
26422          PNUCL(3) = -PLEPT0(3)
26423          PNUCL(4) = SQRT(S)-PLEPT0(4)
26424       ENDIF
26425 * Lorentz-parameter for transformation Lab. - projectile rest system
26426       IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
26427          GALAB = TINY10
26428          BGLAB = TINY10
26429          BLAB  = TINY10
26430       ELSE
26431          GALAB = EPROJ/AMP
26432          BGLAB = PPROJ/AMP
26433          BLAB  = BGLAB/GALAB
26434       ENDIF
26435 * Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
26436       IF (IDP.EQ.7) THEN
26437          GACMS(1) = TINY10
26438          BGCMS(1) = TINY10
26439       ELSE
26440          GACMS(1) = (ETARG+AMP)/UMO
26441          BGCMS(1) = PTARG/UMO
26442       ENDIF
26443 * Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
26444       GACMS(2) = (EPROJ+AMT)/UMO
26445       BGCMS(2) = PPROJ/UMO
26446       PPCM     = GACMS(2)*PPROJ-BGCMS(2)*EPROJ
26447
26448       EPN0 = EPN
26449       PPN0 = PPN
26450       ECM0 = ECM
26451
26452       RETURN
26453       END
26454
26455 *$ CREATE DT_LTRANS.FOR
26456 *COPY DT_LTRANS
26457 *
26458 *===ltrans=============================================================*
26459 *
26460       SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
26461
26462 ************************************************************************
26463 * Lorentz-transformations.                                             *
26464 *   MODE = 1(-1)    projectile rest syst.   --> Lab (back)             *
26465 *        = 2(-2)    projectile rest syst.   --> nucl.-nucl.cms (back)  *
26466 *        = 3(-3)    target rest syst. (=Lab)--> nucl.-nucl.cms (back)  *
26467 * This version dated 01.11.95 is written by  S. Roesler.               *
26468 ************************************************************************
26469
26470       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26471       SAVE
26472       PARAMETER ( LINP = 10 ,
26473      &            LOUT = 6 ,
26474      &            LDAT = 9 )
26475       PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
26476
26477       PARAMETER (SQTINF=1.0D+15)
26478
26479 * particle properties (BAMJET index convention)
26480       CHARACTER*8  ANAME
26481       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26482      &                IICH(210),IIBAR(210),K1(210),K2(210)
26483
26484       PXO = PXI
26485       PYO = PYI
26486       CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
26487
26488 * check particle mass for consistency (numerical rounding errors)
26489       PO     = SQRT(PXO*PXO+PYO*PYO+PZO*PZO)
26490       AMO2   = (PEO-PO)*(PEO+PO)
26491       AMORQ2 = AAM(ID)**2
26492       AMDIF2 = ABS(AMO2-AMORQ2)
26493       IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN
26494          DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO))
26495          PEO   = PEO+DELTA
26496          PO1   = PO -DELTA
26497          PXO   = PXO*PO1/PO
26498          PYO   = PYO*PO1/PO
26499          PZO   = PZO*PO1/PO
26500 C        WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
26501       ENDIF
26502
26503       RETURN
26504       END
26505
26506 *$ CREATE DT_LTNUC.FOR
26507 *COPY DT_LTNUC
26508 *
26509 *===ltnuc==============================================================*
26510 *
26511       SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
26512
26513 ************************************************************************
26514 * Lorentz-transformations.                                             *
26515 *   PIN        longitudnal momentum       (input)                      *
26516 *   EIN        energy                     (input)                      *
26517 *   POUT       transformed long. momentum (output)                     *
26518 *   EOUT       transformed energy         (output)                     *
26519 *   MODE = 1(-1)    projectile rest syst.   --> Lab (back)             *
26520 *        = 2(-2)    projectile rest syst.   --> nucl.-nucl.cms (back)  *
26521 *        = 3(-3)    target rest syst. (=Lab)--> nucl.-nucl.cms (back)  *
26522 * This version dated 01.11.95 is written by  S. Roesler.               *
26523 ************************************************************************
26524
26525       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26526       SAVE
26527       PARAMETER ( LINP = 10 ,
26528      &            LOUT = 6 ,
26529      &            LDAT = 9 )
26530       PARAMETER (ZERO=0.0D0)
26531
26532 * Lorentz-parameters of the current interaction
26533       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26534      &                UMO,PPCM,EPROJ,PPROJ
26535
26536       BDUM1 = ZERO
26537       BDUM2 = ZERO
26538       PDUM1 = ZERO
26539       PDUM2 = ZERO
26540       IF (ABS(MODE).EQ.1) THEN
26541          BG = -SIGN(BGLAB,DBLE(MODE))
26542          CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN,
26543      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26544       ELSEIF (ABS(MODE).EQ.2) THEN
26545          BG = SIGN(BGCMS(1),DBLE(MODE))
26546          CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26547      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26548       ELSEIF (ABS(MODE).EQ.3) THEN
26549          BG = -SIGN(BGCMS(2),DBLE(MODE))
26550          CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26551      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26552       ELSE
26553          WRITE(LOUT,1000) MODE
26554  1000    FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
26555          EOUT = EIN
26556          POUT = PIN
26557       ENDIF
26558
26559       RETURN
26560       END
26561
26562 *$ CREATE DT_DALTRA.FOR
26563 *COPY DT_DALTRA
26564 *
26565 *===daltra=============================================================*
26566 *
26567       SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
26568
26569 ************************************************************************
26570 * Arbitrary Lorentz-transformation.                                    *
26571 * Adopted from the original by S. Roesler. This version dated 15.01.95 *
26572 ************************************************************************
26573
26574       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26575       SAVE
26576       PARAMETER (ONE=1.0D0)
26577
26578       EP = PCX*BGX+PCY*BGY+PCZ*BGZ
26579       PE = EP/(GA+ONE)+EC
26580       PX = PCX+BGX*PE
26581       PY = PCY+BGY*PE
26582       PZ = PCZ+BGZ*PE
26583       P  = SQRT(PX*PX+PY*PY+PZ*PZ)
26584       E  = GA*EC+EP
26585
26586       RETURN
26587       END
26588
26589 *$ CREATE DT_DTRAFO.FOR
26590 *COPY DT_DTRAFO
26591 *
26592 *====dtrafo============================================================*
26593 *
26594       SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
26595      &                                    PL,CXL,CYL,CZL,EL)
26596
26597 C     LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
26598
26599       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26600       SAVE
26601
26602       IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
26603       SID  = SQRT(1.D0-COD*COD)
26604       PLX  = P*SID*COF
26605       PLY  = P*SID*SIF
26606       PCMZ = P*COD
26607       PLZ  = GAM*PCMZ+BGAM*ECM
26608       PL   = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
26609       EL   = GAM*ECM+BGAM*PCMZ
26610 C     ROTATION INTO THE ORIGINAL DIRECTION
26611       COZ  = PLZ/PL
26612       SIZ  = SQRT(1.D0-COZ**2)
26613       CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
26614
26615       RETURN
26616       END
26617
26618 *$ CREATE DT_STTRAN.FOR
26619 *COPY DT_STTRAN
26620 *
26621 *====sttran============================================================*
26622 *
26623       SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
26624
26625       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26626       SAVE
26627       DATA ANGLSQ/1.D-30/
26628 ************************************************************************
26629 *     VERSION BY                     J. RANFT                          *
26630 *                                    LEIPZIG                           *
26631 *                                                                      *
26632 *     THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES      *
26633 *                                                                      *
26634 *     INPUT VARIABLES:                                                 *
26635 *        XO,YO,ZO = ORIGINAL DIRECTION COSINES                         *
26636 *        CDE,SDE  = COSINE AND SINE OF THE POLAR (THETA)               *
26637 *                   ANGLE OF "SCATTERING"                              *
26638 *        SDE      = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING"    *
26639 *        SFE,CFE  = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE       *
26640 *                   OF "SCATTERING"                                    *
26641 *                                                                      *
26642 *     OUTPUT VARIABLES:                                                *
26643 *        X,Y,Z     = NEW DIRECTION COSINES                             *
26644 *                                                                      *
26645 *     ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 )                  *
26646 ************************************************************************
26647 *
26648 *
26649 *  Changed by A. Ferrari
26650 *
26651 *     IF (ABS(XO)-0.0001D0) 1,1,2
26652 *   1 IF (ABS(YO)-0.0001D0) 3,3,2
26653 *   3 CONTINUE
26654       A = XO**2 + YO**2
26655       IF ( A .LT. ANGLSQ ) THEN
26656          X=SDE*CFE
26657          Y=SDE*SFE
26658          Z=CDE*ZO
26659       ELSE
26660          XI=SDE*CFE
26661          YI=SDE*SFE
26662          ZI=CDE
26663          A=SQRT(A)
26664          X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
26665          Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
26666          Z=A*YI+ZO*ZI
26667       ENDIF
26668
26669       RETURN
26670       END
26671
26672 *$ CREATE DT_MYTRAN.FOR
26673 *COPY DT_MYTRAN
26674 *
26675 *===mytran=============================================================*
26676 *
26677       SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
26678
26679 ************************************************************************
26680 * This subroutine rotates the coordinate frame                         *
26681 *    a) theta  around y                                                *
26682 *    b) phi    around z      if IMODE = 1                              *
26683 *                                                                      *
26684 *     x'          cos(ph) -sin(ph) 0      cos(th)  0  sin(th)   x      *
26685 *     y' = A B =  sin(ph) cos(ph)  0  .   0        1        0   y      *
26686 *     z'          0       0        1     -sin(th)  0  cos(th)   z      *
26687 *                                                                      *
26688 * and vice versa if IMODE = 0.                                         *
26689 * This version dated 5.4.94 is based on the original version DTRAN     *
26690 * by J. Ranft and is written by S. Roesler.                            *
26691 ************************************************************************
26692
26693       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26694       SAVE
26695       PARAMETER ( LINP = 10 ,
26696      &            LOUT = 6 ,
26697      &            LDAT = 9 )
26698
26699       IF (IMODE.EQ.1) THEN
26700          X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
26701          Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
26702          Z=-SDE    *XO       +CDE    *ZO
26703       ELSE
26704          X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
26705          Y= -SFE*XO+CFE*YO
26706          Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
26707       ENDIF
26708       RETURN
26709       END
26710
26711 *$ CREATE DT_LT2LAO.FOR
26712 *COPY DT_LT2LAO
26713 *
26714 *===lt2lab=============================================================*
26715 *
26716       SUBROUTINE DT_LT2LAO
26717
26718 ************************************************************************
26719 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1   *
26720 * for final state particles/fragments defined in nucleon-nucleon-cms   *
26721 * and transforms them back to the lab.                                 *
26722 * This version dated 16.11.95 is written by S. Roesler                 *
26723 ************************************************************************
26724
26725       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26726       SAVE
26727       PARAMETER ( LINP = 10 ,
26728      &            LOUT = 6 ,
26729      &            LDAT = 9 )
26730
26731 * event history
26732       PARAMETER (NMXHKK=200000)
26733       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26734      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26735      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26736 * extended event history
26737       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26738      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26739      &                IHIST(2,NMXHKK)
26740
26741       NEND      = NHKK
26742       NPOINT(5) = NHKK+1
26743       IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
26744       DO 1 I=NPOINT(4),NEND
26745 C     DO 1 I=1,NEND
26746          IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26747      &                                (ISTHKK(I).EQ.1001)) THEN
26748             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26749             NOB = NOBAM(I)
26750             CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I),
26751      &                            PZ,PE,IDRES(I),IDXRES(I),IDCH(I))
26752             IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN
26753                ISTHKK(I) = 3*ISTHKK(I)
26754                NOBAM(NHKK)  = NOB
26755             ELSE
26756                IF (ISTHKK(I).EQ.-1) NOBAM(NHKK)  = NOB
26757                ISTHKK(I) = SIGN(3,ISTHKK(I))
26758             ENDIF
26759             JDAHKK(1,I) = NHKK
26760          ENDIF
26761     1 CONTINUE
26762
26763       RETURN
26764       END
26765
26766 *$ CREATE DT_LT2LAB.FOR
26767 *COPY DT_LT2LAB
26768 *
26769 *===lt2lab=============================================================*
26770 *
26771       SUBROUTINE DT_LT2LAB
26772
26773 ************************************************************************
26774 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1   *
26775 * for final state particles/fragments defined in nucleon-nucleon-cms   *
26776 * and transforms them to the lab.                                      *
26777 * This version dated 07.01.96 is written by S. Roesler                 *
26778 ************************************************************************
26779
26780       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26781       SAVE
26782       PARAMETER ( LINP = 10 ,
26783      &            LOUT = 6 ,
26784      &            LDAT = 9 )
26785
26786 * event history
26787       PARAMETER (NMXHKK=200000)
26788       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26789      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26790      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26791 * extended event history
26792       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26793      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26794      &                IHIST(2,NMXHKK)
26795
26796       IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
26797       DO 1 I=NPOINT(4),NHKK
26798          IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26799      &                                (ISTHKK(I).EQ.1001)) THEN
26800
26801             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26802             PHKK(3,I) = PZ
26803             PHKK(4,I) = PE
26804          ENDIF
26805     1 CONTINUE
26806
26807       RETURN
26808       END
26809
26810 ************************************************************************
26811 *                                                                      *
26812 *                 5) Sampling from distributions                       *
26813 *                                                                      *
26814 ************************************************************************
26815 *$ CREATE IDT_NPOISS.FOR
26816 *COPY IDT_NPOISS
26817 *
26818 *===npoiss=============================================================*
26819 *
26820       INTEGER FUNCTION IDT_NPOISS(AVN)
26821
26822 ************************************************************************
26823 * Sample according to Poisson distribution with Poisson parameter AVN. *
26824 * The original version written by J. Ranft.                            *
26825 * This version dated 11.1.95 is written by S. Roesler.                 *
26826 ************************************************************************
26827
26828       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26829       SAVE
26830       PARAMETER ( LINP = 10 ,
26831      &            LOUT = 6 ,
26832      &            LDAT = 9 )
26833
26834       EXPAVN = EXP(-AVN)
26835       K = 1
26836       A = 1.0D0
26837
26838    10 CONTINUE
26839       A = DT_RNDM(A)*A
26840       IF (A.GE.EXPAVN) THEN
26841          K = K+1
26842          GOTO 10
26843       ENDIF
26844       IDT_NPOISS = K-1
26845
26846       RETURN
26847       END
26848
26849 *$ CREATE DT_SAMPXB.FOR
26850 *COPY DT_SAMPXB
26851 *
26852 *===sampxb=============================================================*
26853 *
26854       DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
26855
26856 ************************************************************************
26857 * Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2.             *
26858 * Processed by S. Roesler, 6.5.95                                      *
26859 ************************************************************************
26860
26861       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26862       SAVE
26863       PARAMETER (TWO=2.0D0)
26864
26865       A1 = LOG(X1+SQRT(X1**2+B**2))
26866       A2 = LOG(X2+SQRT(X2**2+B**2))
26867       AN = A2-A1
26868       A  = AN*DT_RNDM(A1)+A1
26869       BB = EXP(A)
26870       DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
26871
26872       RETURN
26873       END
26874
26875 *$ CREATE DT_SAMPEX.FOR
26876 *COPY DT_SAMPEX
26877 *
26878 *===sampex=============================================================*
26879 *
26880       DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
26881
26882 ************************************************************************
26883 * Sampling from f(x)=1./x between x1 and x2.                           *
26884 * Processed by S. Roesler, 6.5.95                                      *
26885 ************************************************************************
26886
26887       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26888       SAVE
26889       PARAMETER (ONE=1.0D0)
26890
26891       R   = DT_RNDM(X1)
26892       AL1 = LOG(X1)
26893       AL2 = LOG(X2)
26894       DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
26895
26896       RETURN
26897       END
26898
26899 *$ CREATE DT_SAMSQX.FOR
26900 *COPY DT_SAMSQX
26901 *
26902 *===samsqx=============================================================*
26903 *
26904       DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
26905
26906 ************************************************************************
26907 * Sampling from f(x)=1./x^0.5 between x1 and x2.                       *
26908 * Processed by S. Roesler, 6.5.95                                      *
26909 ************************************************************************
26910
26911       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26912       SAVE
26913       PARAMETER (ONE=1.0D0)
26914
26915       R = DT_RNDM(X1)
26916       DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
26917
26918       RETURN
26919       END
26920
26921 *$ CREATE DT_SAMPLW.FOR
26922 *COPY DT_SAMPLW
26923 *
26924 *===samplw=============================================================*
26925 *
26926       DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
26927
26928 ************************************************************************
26929 * Sampling from f(x)=1/x^b between x_min and x_max.                    *
26930 * S. Roesler, 18.4.98                                                  *
26931 ************************************************************************
26932
26933       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26934       SAVE
26935       PARAMETER (ONE=1.0D0)
26936
26937       R = DT_RNDM(B)
26938       IF (B.EQ.ONE) THEN
26939          DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
26940       ELSE
26941          ONEMB  = ONE-B
26942          DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
26943       ENDIF
26944
26945       RETURN
26946       END
26947
26948 *$ CREATE DT_BETREJ.FOR
26949 *COPY DT_BETREJ
26950 *
26951 *===betrej=============================================================*
26952 *
26953       DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
26954
26955       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26956       SAVE
26957
26958       PARAMETER ( LINP = 10 ,
26959      &            LOUT = 6 ,
26960      &            LDAT = 9 )
26961       PARAMETER (ONE=1.0D0)
26962
26963       IF (XMIN.GE.XMAX)THEN
26964          WRITE (LOUT,500) XMIN,XMAX
26965   500    FORMAT(1X,'DT_BETREJ:  XMIN<XMAX execution stopped ',2F10.5)
26966          STOP
26967       ENDIF
26968
26969    10 CONTINUE
26970       XX     = XMIN+(XMAX-XMIN)*DT_RNDM(ETA)
26971       BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE)
26972       YY     = BETMAX*DT_RNDM(XX)
26973       BETXX  = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE)
26974       IF (YY.GT.BETXX) GOTO 10
26975       DT_BETREJ = XX
26976
26977       RETURN
26978       END
26979
26980 *$ CREATE DT_DGAMRN.FOR
26981 *COPY DT_DGAMRN
26982 *
26983 *===dgamrn=============================================================*
26984 *
26985       DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
26986
26987 ************************************************************************
26988 * Sampling from Gamma-distribution.                                    *
26989 *       F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)            *
26990 * Processed by S. Roesler, 6.5.95                                      *
26991 ************************************************************************
26992
26993       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26994       SAVE
26995       PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
26996
26997       NCOU = 0
26998       N    = INT(ETA)
26999       F    = ETA-DBLE(N)
27000       IF (F.EQ.ZERO) GOTO 20
27001    10 R = DT_RNDM(F)
27002       NCOU = NCOU+1
27003       IF (NCOU.GE.11) GOTO 20
27004       IF (R.LT.F/(F+2.71828D0)) GOTO 30
27005       YYY = LOG(DT_RNDM(R)+TINY9)/F
27006       IF (ABS(YYY).GT.50.0D0) GOTO 20
27007       Y = EXP(YYY)
27008       IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
27009       GOTO 40
27010    20 Y = 0.0D0
27011       GOTO 50
27012    30 Y = ONE-LOG(DT_RNDM(Y)+TINY9)
27013       IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10
27014    40 IF (N.EQ.0) GOTO 70
27015    50 Z = 1.0D0
27016       DO 60 I = 1,N
27017    60 Z = Z*DT_RNDM(Z)
27018       Y = Y-LOG(Z+TINY9)
27019    70 DT_DGAMRN = Y/ALAM
27020
27021       RETURN
27022       END
27023
27024 *$ CREATE DT_DBETAR.FOR
27025 *COPY DT_DBETAR
27026 *
27027 *===dbetar=============================================================*
27028 *
27029       DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
27030
27031 ************************************************************************
27032 * Sampling from Beta -distribution between 0.0 and 1.0                 *
27033 *  F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
27034 * Processed by S. Roesler, 6.5.95                                      *
27035 ************************************************************************
27036
27037       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27038       SAVE
27039
27040       Y = DT_DGAMRN(1.0D0,GAM)
27041       Z = DT_DGAMRN(1.0D0,ETA)
27042       DT_DBETAR = Y/(Y+Z)
27043
27044       RETURN
27045       END
27046
27047 *$ CREATE DT_RANNOR.FOR
27048 *COPY DT_RANNOR
27049 *
27050 *===rannor=============================================================*
27051 *
27052       SUBROUTINE DT_RANNOR(X,Y)
27053
27054 ************************************************************************
27055 * Sampling from Gaussian distribution.                                 *
27056 * Processed by S. Roesler, 6.5.95                                      *
27057 ************************************************************************
27058
27059       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27060       SAVE
27061       PARAMETER (TINY10=1.0D-10)
27062
27063       CALL DT_DSFECF(SFE,CFE)
27064       V = MAX(TINY10,DT_RNDM(X))
27065       A = SQRT(-2.D0*LOG(V))
27066       X = A*SFE
27067       Y = A*CFE
27068
27069       RETURN
27070       END
27071
27072 *$ CREATE DT_DPOLI.FOR
27073 *COPY DT_DPOLI
27074 *
27075 *===dpoli==============================================================*
27076 *
27077       SUBROUTINE DT_DPOLI(CS,SI)
27078
27079       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27080       SAVE
27081
27082       U  = DT_RNDM(CS)
27083       CS = DT_RNDM(U)
27084       IF (U.LT.0.5D0) CS=-CS
27085       SI = SQRT(1.0D0-CS*CS+1.0D-10)
27086
27087       RETURN
27088       END
27089
27090 *$ CREATE DT_DSFECF.FOR
27091 *COPY DT_DSFECF
27092 *
27093 *===dsfecf=============================================================*
27094 *
27095       SUBROUTINE DT_DSFECF(SFE,CFE)
27096
27097       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27098       SAVE
27099       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
27100
27101     1 CONTINUE
27102       X  = DT_RNDM(SFE)
27103       Y  = DT_RNDM(X)
27104       XX = X*X
27105       YY = Y*Y
27106       XY = XX+YY
27107       IF (XY.GT.ONE) GOTO 1
27108       CFE = (XX-YY)/XY
27109       SFE = TWO*X*Y/XY
27110       IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
27111       RETURN
27112       END
27113
27114 *$ CREATE DT_RACO.FOR
27115 *COPY DT_RACO
27116 *
27117 *===raco===============================================================*
27118 *
27119       SUBROUTINE DT_RACO(WX,WY,WZ)
27120
27121 ************************************************************************
27122 * Direction cosines of random uniform (isotropic) direction in three   *
27123 * dimensional space                                                    *
27124 * Processed by S. Roesler, 20.11.95                                    *
27125 ************************************************************************
27126
27127       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27128       SAVE
27129       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
27130
27131   10  CONTINUE
27132       X  = TWO*DT_RNDM(WX)-ONE
27133       Y  = DT_RNDM(X)
27134       X2 = X*X
27135       Y2 = Y*Y
27136       IF (X2+Y2.GT.ONE) GOTO 10
27137
27138       CFE = (X2-Y2)/(X2+Y2)
27139       SFE = TWO*X*Y/(X2+Y2)
27140 * z = 1/2 [ 1 + cos (theta) ]
27141       Z   = DT_RNDM(X)
27142 * 1/2 sin (theta)
27143       WZ = SQRT(Z*(ONE-Z))
27144       WX = TWO*WZ*CFE
27145       WY = TWO*WZ*SFE
27146       WZ = TWO*Z-ONE
27147
27148       RETURN
27149       END
27150
27151 ************************************************************************
27152 *                                                                      *
27153 *           6) Special functions, algorithms and service routines      *
27154 *                                                                      *
27155 ************************************************************************
27156 *$ CREATE DT_YLAMB.FOR
27157 *COPY DT_YLAMB
27158 *
27159 *===ylamb==============================================================*
27160 *
27161       DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
27162
27163 ************************************************************************
27164 *                                                                      *
27165 *     auxiliary function for three particle decay mode                 *
27166 *     (standard LAMBDA**(1/2) function)                                *
27167 *                                                                      *
27168 * Adopted from an original version written by R. Engel.                *
27169 * This version dated 12.12.94 is written by S. Roesler.                *
27170 ************************************************************************
27171
27172       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27173       SAVE
27174
27175       YZ   = Y-Z
27176       XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ
27177       IF (XLAM.LE.0.D0) XLAM = ABS(XLAM)
27178       DT_YLAMB = SQRT(XLAM)
27179
27180       RETURN
27181       END
27182
27183 *$ CREATE DT_SORT.FOR
27184 *COPY DT_SORT
27185 *
27186 *===sort1==============================================================*
27187 *
27188       SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
27189
27190 ************************************************************************
27191 * This subroutine sorts entries in A in increasing/decreasing order    *
27192 * of A(3,i).                                                           *
27193 *              MODE  = 1     increasing in A(3,i=1..N)                 *
27194 *                    = 2     decreasing in A(3,i=1..N)                 *
27195 * This version dated 21.04.95 is revised by S. Roesler                 *
27196 ************************************************************************
27197
27198       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27199       SAVE
27200
27201       DIMENSION A(3,N)
27202
27203       M = I1
27204    10 CONTINUE
27205       M = I1-1
27206       IF (M.LE.0) RETURN
27207       L = 0
27208       DO 20 I=I0,M
27209          J = I+1
27210          IF (MODE.EQ.1) THEN
27211             IF (A(3,I).LE.A(3,J)) GOTO 20
27212          ELSE
27213             IF (A(3,I).GE.A(3,J)) GOTO 20
27214          ENDIF
27215          B = A(3,I)
27216          C = A(1,I)
27217          D = A(2,I)
27218          A(3,I) = A(3,J)
27219          A(2,I) = A(2,J)
27220          A(1,I) = A(1,J)
27221          A(3,J) = B
27222          A(1,J) = C
27223          A(2,J) = D
27224          L = 1
27225    20 CONTINUE
27226       IF (L.EQ.1) GOTO 10
27227
27228       RETURN
27229       END
27230
27231 *$ CREATE DT_SORT1.FOR
27232 *COPY DT_SORT1
27233 *
27234 *===sort1==============================================================*
27235 *
27236       SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
27237
27238 ************************************************************************
27239 * This subroutine sorts entries in A in increasing/decreasing order    *
27240 * of A(i).                                                             *
27241 *              MODE  = 1     increasing in A(i=1..N)                   *
27242 *                    = 2     decreasing in A(i=1..N)                   *
27243 * This version dated 21.04.95 is revised by S. Roesler                 *
27244 ************************************************************************
27245
27246       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27247       SAVE
27248
27249       DIMENSION A(N),IDX(N)
27250
27251       M = I1
27252    10 CONTINUE
27253       M = I1-1
27254       IF (M.LE.0) RETURN
27255       L = 0
27256       DO 20 I=I0,M
27257          J = I+1
27258          IF (MODE.EQ.1) THEN
27259             IF (A(I).LE.A(J)) GOTO 20
27260          ELSE
27261             IF (A(I).GE.A(J)) GOTO 20
27262          ENDIF
27263          B    = A(I)
27264          A(I) = A(J)
27265          A(J) = B
27266          IX     = IDX(I)
27267          IDX(I) = IDX(J)
27268          IDX(J) = IX
27269          L = 1
27270    20 CONTINUE
27271       IF (L.EQ.1) GOTO 10
27272
27273       RETURN
27274       END
27275
27276 *$ CREATE DT_XTIME.FOR
27277 *COPY DT_XTIME
27278 *
27279 *===xtime==============================================================*
27280 *
27281       SUBROUTINE DT_XTIME
27282
27283       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27284       SAVE
27285       PARAMETER ( LINP = 10 ,
27286      &            LOUT = 6 ,
27287      &            LDAT = 9 )
27288
27289       CHARACTER DAT*9,TIM*11
27290
27291       DAT = '         '
27292       TIM = '           '
27293 C     CALL GETDAT(IYEAR,IMONTH,IDAY)
27294 C     CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
27295
27296 C     CALL DATE(DAT)
27297 C     CALL TIME(TIM)
27298 C     WRITE(LOUT,1000) DAT,TIM
27299  1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
27300
27301       RETURN
27302       END
27303
27304 ************************************************************************
27305 *                                                                      *
27306 *                 7) Random number generator package                   *
27307 *                                                                      *
27308 *    THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND        *
27309 *    SERVICE ROUTINES.                                                 *
27310 *    THE ALGORITHM IS FROM                                             *
27311 *      'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR'                     *
27312 *      G.MARSAGLIA, A.ZAMAN ;  FSU-SCRI-87-50                          *
27313 *    IMPLEMENTATION BY K. HAHN  DEC. 88,                               *
27314 *    THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS *
27315 *    AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ),        *
27316 *    THE PERIOD IS ABOUT 2**144,                                       *
27317 *    TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS,            *
27318 *    THE PACKAGE CONTAINS                                              *
27319 *      FUNCTION DT_RNDM(I)                  : GENERATOR                *
27320 *      SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION           *
27321 *      SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J)  : PUT SEED TO GENERATOR    *
27322 *      SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J)  : TAKE SEED FROM GENERATOR *
27323 *      SUBROUTINE DT_RNDMTE(IO)             : TEST OF GENERATOR        *
27324 *---                                                                   *
27325 *    FUNCTION DT_RNDM(I)                                               *
27326 *       GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS  IN (0..1)          *
27327 *       I  - DUMMY VARIABLE, NOT USED                                  *
27328 *    SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)                             *
27329 *       INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM *
27330 *       NA1,NA2,NA3,NB1  - VALUES FOR INITIALIZING THE GENERATOR       *
27331 *                          NA? MUST BE IN 1..178 AND NOT ALL 1         *
27332 *                          12,34,56  ARE THE STANDARD VALUES           *
27333 *                          NB1 MUST BE IN 1..168                       *
27334 *                          78  IS THE STANDARD VALUE                   *
27335 *    SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J)                               *
27336 *       PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS   *
27337 *       AS AFTER THE LAST DT_RNDMOU CALL )                             *
27338 *       U(97),C,CD,CM,I,J  - SEED VALUES AS TAKEN FROM DT_RNDMOU       *
27339 *    SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J)                               *
27340 *       TAKES SEED FROM GENERATOR                                      *
27341 *       U(97),C,CD,CM,I,J  - SEED VALUES                               *
27342 *    SUBROUTINE DT_RNDMTE(IO)                                          *
27343 *       TEST OF THE GENERATOR                                          *
27344 *       IO     - DEFINES OUTPUT                                        *
27345 *                  = 0  OUTPUT ONLY IF AN ERROR IS DETECTED            *
27346 *                  = 1  OUTPUT INDEPENDEND ON AN ERROR                 *
27347 *       DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO   *
27348 *       SAME STATUS                                                    *
27349 *       AS BEFORE CALL OF DT_RNDMTE                                    *
27350 ************************************************************************
27351 *$ CREATE DT_RNDM.FOR
27352 *COPY DT_RNDM
27353 *
27354 c$$$*===rndm===============================================================*
27355 c$$$*
27356 c$$$      DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
27357 c$$$
27358 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27359 c$$$      SAVE
27360 c$$$
27361 c$$$* random number generator
27362 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27363 c$$$
27364 c$$$* counter of calls to random number generator
27365 c$$$* uncomment if needed
27366 c$$$C     COMMON /DTRNCT/ IRNCT0,IRNCT1
27367 c$$$C     LOGICAL LFIRST
27368 c$$$C     DATA LFIRST /.TRUE./
27369 c$$$
27370 c$$$* counter of calls to random number generator
27371 c$$$* uncomment if needed
27372 c$$$C     IF (LFIRST) THEN
27373 c$$$C        IRNCT0 = 0
27374 c$$$C        IRNCT1 = 0
27375 c$$$C        LFIRST = .FALSE.
27376 c$$$C     ENDIF
27377 c$$$ 100  CONTINUE
27378 c$$$      DT_RNDM = U(I)-U(J)
27379 c$$$      IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0
27380 c$$$      U(I) = DT_RNDM
27381 c$$$      I    = I-1
27382 c$$$      IF ( I.EQ.0 ) I = 97
27383 c$$$      J    = J-1
27384 c$$$      IF ( J.EQ.0 ) J = 97
27385 c$$$      C    = C-CD
27386 c$$$      IF ( C.LT.0.0D0 ) C = C+CM
27387 c$$$      DT_RNDM = DT_RNDM-C
27388 c$$$      IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0
27389 c$$$
27390 c$$$      IF ((DT_RNDM.EQ.0.D0).OR.(DT_RNDM.EQ.1.D0)) GOTO 100
27391 c$$$
27392 c$$$* counter of calls to random number generator
27393 c$$$* uncomment if needed
27394 c$$$C     IRNCT0 = IRNCT0+1
27395 c$$$
27396 c$$$      RETURN
27397 c$$$      END
27398 c$$$
27399 c$$$*$ CREATE DT_RNDMST.FOR
27400 c$$$*COPY DT_RNDMST
27401 c$$$*
27402 c$$$*===rndmst=============================================================*
27403 c$$$*
27404 c$$$      SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
27405 c$$$
27406 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27407 c$$$      SAVE
27408 c$$$
27409 c$$$* random number generator
27410 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27411 c$$$
27412 c$$$      MA1 = NA1
27413 c$$$      MA2 = NA2
27414 c$$$      MA3 = NA3
27415 c$$$      MB1 = NB1
27416 c$$$      I   = 97
27417 c$$$      J   = 33
27418 c$$$      DO 20 II2 = 1,97
27419 c$$$        S = 0
27420 c$$$        T = 0.5D0
27421 c$$$        DO 10 II1 = 1,24
27422 c$$$          MAT  = MOD(MOD(MA1*MA2,179)*MA3,179)
27423 c$$$          MA1  = MA2
27424 c$$$          MA2  = MA3
27425 c$$$          MA3  = MAT
27426 c$$$          MB1  = MOD(53*MB1+1,169)
27427 c$$$          IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
27428 c$$$   10   T = 0.5D0*T
27429 c$$$   20 U(II2) = S
27430 c$$$      C  =   362436.0D0/16777216.0D0
27431 c$$$      CD =  7654321.0D0/16777216.0D0
27432 c$$$      CM = 16777213.0D0/16777216.0D0
27433 c$$$      RETURN
27434 c$$$      END
27435 c$$$
27436 c$$$*$ CREATE DT_RNDMIN.FOR
27437 c$$$*COPY DT_RNDMIN
27438 c$$$*
27439 c$$$*===rndmin=============================================================*
27440 c$$$*
27441 c$$$      SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
27442 c$$$
27443 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27444 c$$$      SAVE
27445 c$$$
27446 c$$$* random number generator
27447 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27448 c$$$
27449 c$$$      DIMENSION UIN(97)
27450 c$$$
27451 c$$$      DO 10 KKK = 1,97
27452 c$$$   10 U(KKK) = UIN(KKK)
27453 c$$$      C  = CIN
27454 c$$$      CD = CDIN
27455 c$$$      CM = CMIN
27456 c$$$      I  = IIN
27457 c$$$      J  = JIN
27458 c$$$
27459 c$$$      RETURN
27460 c$$$      END
27461 c$$$
27462 c$$$*$ CREATE DT_RNDMOU.FOR
27463 c$$$*COPY DT_RNDMOU
27464 c$$$*
27465 c$$$*===rndmou=============================================================*
27466 c$$$*
27467 c$$$      SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
27468 c$$$
27469 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27470 c$$$      SAVE
27471 c$$$
27472 c$$$* random number generator
27473 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27474 c$$$
27475 c$$$      DIMENSION UOUT(97)
27476 c$$$
27477 c$$$      DO 10 KKK = 1,97
27478 c$$$   10 UOUT(KKK) = U(KKK)
27479 c$$$      COUT  = C
27480 c$$$      CDOUT = CD
27481 c$$$      CMOUT = CM
27482 c$$$      IOUT  = I
27483 c$$$      JOUT  = J
27484 c$$$
27485 c$$$      RETURN
27486 c$$$      END
27487 c$$$
27488 c$$$*$ CREATE DT_RNDMTE.FOR
27489 c$$$*COPY DT_RNDMTE
27490 c$$$*
27491 c$$$*===rndmte=============================================================*
27492 c$$$*
27493 c$$$      SUBROUTINE DT_RNDMTE(IO)
27494 c$$$
27495 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27496 c$$$      SAVE
27497 c$$$
27498 c$$$      DIMENSION UU(97),U(6),X(6),D(6)
27499 c$$$      DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0,
27500 c$$$     +8354498.D0, 10633180.D0/
27501 c$$$
27502 c$$$      CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ)
27503 c$$$      CALL DT_RNDMST(12,34,56,78)
27504 c$$$      DO 10 II1 = 1,20000
27505 c$$$   10 XX = DT_RNDM(XX)
27506 c$$$      SD        = 0.0D0
27507 c$$$      DO 20 II2 = 1,6
27508 c$$$        X(II2)  = 4096.D0*(4096.D0*DT_RNDM(SD))
27509 c$$$        D(II2)  = X(II2)-U(II2)
27510 c$$$   20 SD = SD+D(II2)
27511 c$$$      CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
27512 c$$$**sr 24.01.95
27513 c$$$C     IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6)
27514 c$$$      IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN
27515 c$$$C        WRITE(6,1000)
27516 c$$$ 1000    FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
27517 c$$$     &          ' passed')
27518 c$$$      ENDIF
27519 c$$$**
27520 c$$$      RETURN
27521 c$$$  500 FORMAT('  === TEST OF THE RANDOM-GENERATOR ===',/,
27522 c$$$     &'    EXPECTED VALUE    CALCULATED VALUE     DIFFERENCE',/, 6(F17.
27523 c$$$     &1,F20.1,F15.3,/), '  === END OF TEST ;',
27524 c$$$     &'  GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE')
27525 c$$$      END
27526 *
27527 *$ CREATE PHO_RNDM.FOR
27528 *COPY PHO_RNDM
27529 *
27530 *===pho_rndm===========================================================*
27531 *
27532       DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
27533
27534       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27535       SAVE
27536
27537       PHO_RNDM = DT_RNDM(DUMMY)
27538
27539       RETURN
27540       END
27541
27542 *$ CREATE PYR.FOR
27543 *COPY PYR
27544 *
27545 *===pyr================================================================*
27546 *
27547       DOUBLE PRECISION FUNCTION PYR(IDUMMY)
27548
27549       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27550       SAVE
27551
27552       DUMMY = DBLE(IDUMMY)
27553       PYR = DT_RNDM(DUMMY)
27554
27555       RETURN
27556       END
27557
27558 *$ CREATE DT_TITLE.FOR
27559 *COPY DT_TITLE
27560 *
27561 *===title==============================================================*
27562 *
27563       SUBROUTINE DT_TITLE
27564
27565       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27566       SAVE
27567       PARAMETER ( LINP = 10 ,
27568      &            LOUT = 6 ,
27569      &            LDAT = 9 )
27570
27571       CHARACTER*6 CVERSI
27572       CHARACTER*11 CCHANG
27573       DATA CVERSI,CCHANG /'3.0-5 ','08 Jan 2007'/
27574
27575       CALL DT_XTIME
27576       WRITE(LOUT,1000) CVERSI,CCHANG
27577  1000 FORMAT(1X,'+-------------------------------------------------',
27578      &                  '----------------------+',/,
27579      &     1X,'|',71X,'|',/,
27580      &     1X,'|',26X,'DPMJET version ',A6,24X,'|',/,
27581      &     1X,'|',71X,'|',/,
27582      &     1X,'|',22X,'(Last change: ',A11,')',23X,'|',/,
27583      &     1X,'|',71X,'|',/,
27584      &     1X,'|',12X,'Authors: Stefan Roesler   (CERN)',27X,'|',/,
27585      &     1X,'|',21X,'Ralph Engel      (FZ Karlsruhe)',19X,'|',/,
27586      &     1X,'|',21X,'Johannes Ranft   (Siegen Univ.)',19X,'|',/,
27587      &     1X,'|',71X,'|',/,
27588      &     1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html',
27589      &                                              17X,'|',/,
27590      &     1X,'|',71X,'|',/,
27591      &     1X,'+-------------------------------------------------',
27592      &                '----------------------+',/,
27593      &     1X,'| Please send suggestions, bug reports, etc. to: ',
27594      &                                  'Stefan.Roesler@cern.ch |',/,
27595      &     1X,'+-------------------------------------------------',
27596      &                '----------------------+',/)
27597
27598       RETURN
27599       END
27600
27601 *$ CREATE DT_EVTINI.FOR
27602 *COPY DT_EVTINI
27603 *
27604 *===evtini=============================================================*
27605 *
27606       SUBROUTINE DT_EVTINI
27607
27608 ************************************************************************
27609 * Initialization of DTEVT1.                                            *
27610 * This version dated 15.01.94 is written by S. Roesler                 *
27611 ************************************************************************
27612
27613       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27614       SAVE
27615       PARAMETER ( LINP = 10 ,
27616      &            LOUT = 6 ,
27617      &            LDAT = 9 )
27618
27619 * event history
27620       PARAMETER (NMXHKK=200000)
27621       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27622      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27623      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27624 * extended event history
27625       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27626      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27627      &                IHIST(2,NMXHKK)
27628 * event flag
27629       COMMON /DTEVNO/ NEVENT,ICASCA
27630       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27631 * emulsion treatment
27632       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
27633      &                NCOMPO,IEMUL
27634
27635 * initialization of DTEVT1/DTEVT2
27636       NEND = NHKK
27637       IF (NEVENT.EQ.1) NEND = NMXHKK
27638       NHKK   = 0
27639       NEVHKK = NEVENT
27640       DO 1 I=1,NEND
27641          ISTHKK(I)   = 0
27642          IDHKK(I)    = 0
27643          JMOHKK(1,I) = 0
27644          JMOHKK(2,I) = 0
27645          JDAHKK(1,I) = 0
27646          JDAHKK(2,I) = 0
27647          IDRES(I)    = 0
27648          IDXRES(I)   = 0
27649          NOBAM(I)    = 0
27650          IDCH(I)     = 0
27651          IHIST(1,I)  = 0
27652          IHIST(2,I)  = 0
27653          DO 2 J=1,4
27654             PHKK(J,I) = 0.0D0
27655             VHKK(J,I) = 0.0D0
27656             WHKK(J,I) = 0.0D0
27657     2    CONTINUE
27658          PHKK(5,I) = 0.0D0
27659     1 CONTINUE
27660       DO 3 I=1,10
27661          NPOINT(I) = 0
27662     3 CONTINUE
27663       CALL DT_CHASTA(-1)
27664
27665 C* initialization of DTLTRA
27666 C      IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
27667
27668       RETURN
27669       END
27670
27671 *$ CREATE DT_STATIS.FOR
27672 *COPY DT_STATIS
27673 *
27674 *===statis=============================================================*
27675 *
27676       SUBROUTINE DT_STATIS(MODE)
27677
27678 ************************************************************************
27679 * Initialization and output of run-statistics.                         *
27680 *              MODE  = 1     initialization                            *
27681 *                    = 2     output                                    *
27682 * This version dated 23.01.94 is written by S. Roesler                 *
27683 ************************************************************************
27684
27685       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27686       SAVE
27687       PARAMETER ( LINP = 10 ,
27688      &            LOUT = 6 ,
27689      &            LDAT = 9 )
27690       PARAMETER (TINY3=1.0D-3)
27691
27692 * statistics
27693       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
27694      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
27695      &                ICEVTG(8,0:30)
27696 * rejection counter
27697       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27698      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27699      &                IREXCI(3),IRDIFF(2),IRINC
27700 * central particle production, impact parameter biasing
27701       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
27702 * various options for treatment of partons (DTUNUC 1.x)
27703 * (chain recombination, Cronin,..)
27704       LOGICAL LCO2CR,LINTPT
27705       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
27706      &                LCO2CR,LINTPT
27707 * nucleon-nucleon event-generator
27708       CHARACTER*8 CMODEL
27709       LOGICAL LPHOIN
27710       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
27711 * flags for particle decays
27712       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
27713      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
27714      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
27715 * diquark-breaking mechanism
27716       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
27717
27718       DIMENSION PP(4),PT(4)
27719
27720       GOTO (1,2) MODE
27721
27722 * initialization
27723     1 CONTINUE
27724
27725 *   initialize statistics counter
27726       ICREQU = 0
27727       ICSAMP = 0
27728       ICCPRO = 0
27729       ICDPR  = 0
27730       ICDTA  = 0
27731       ICRJSS = 0
27732       ICVV2S = 0
27733       DO 10 I=1,9
27734          ICRES(I)    = 0
27735          ICCHAI(1,I) = 0
27736          ICCHAI(2,I) = 0
27737    10 CONTINUE
27738 *   initialize rejection counter
27739       IRPT      = 0
27740       IRHHA     = 0
27741       LOMRES    = 0
27742       LOBRES    = 0
27743       IRFRAG    = 0
27744       IREVT     = 0
27745       IRRES(1)  = 0
27746       IRRES(2)  = 0
27747       IRCHKI(1) = 0
27748       IRCHKI(2) = 0
27749       IRCRON(1) = 0
27750       IRCRON(2) = 0
27751       IRCRON(3) = 0
27752       IRDIFF(1) = 0
27753       IRDIFF(2) = 0
27754       IRINC     = 0
27755       DO 11 I=1,5
27756          ICDIFF(I) = 0
27757    11 CONTINUE
27758       DO 12 I=1,8
27759          DO 13 J=0,30
27760             ICEVTG(I,J) = 0
27761    13    CONTINUE
27762    12 CONTINUE
27763
27764       RETURN
27765
27766 * output
27767     2 CONTINUE
27768
27769 *   statistics counter
27770       WRITE(LOUT,1000)
27771  1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/,
27772      &       28X,'---------------------')
27773       IF (ICREQU.GT.0) THEN
27774       WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
27775  1001 FORMAT(/,1X,'number of events requested / sampled',13X,
27776      &       I8,' / ',I8,/,1X,'number of samp. evts per requested ',
27777      &       'event',11X,F9.1)
27778       ENDIF
27779       IF (ICDIFF(1).NE.0) THEN
27780          WRITE(LOUT,1009) ICDIFF
27781  1009    FORMAT(/,1X,'diffractive events:    total   ',I8,/,49X,
27782      &          'low mass   high mass',/,24X,'single diffraction',
27783      &          7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
27784       ENDIF
27785       IF (ICENTR.GT.0.AND.ICSAMP.GT.0.AND.ICCPRO.GT.0) THEN
27786          WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
27787      &                    DBLE(ICSAMP)/DBLE(ICCPRO)
27788  1002    FORMAT(/,1X,'central production:',/,2X,'mean number',
27789      &          ' of sampled Glauber-events per event',9X,F9.1,/,
27790      &          2X,'fraction of production cross section',21X,F10.6)
27791       ENDIF
27792       IF (ICSAMP.GT.0) THEN
27793       WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
27794      &                 DBLE(ICDTA)/DBLE(ICSAMP)
27795  1003 FORMAT(/,54X,'proj.    targ.',/,1X,'average number of wounded',
27796      &       ' nucleons after x-sampling',2(4X,F6.2))
27797       ENDIF
27798
27799       IF (MCGENE.EQ.1) THEN
27800          IF (ICSAMP.GT.0) THEN
27801          WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
27802  1004    FORMAT(/,1X,'mean number of sea-sea chain rejections per',
27803      &          ' event',3X,F9.1)
27804          IF (ISICHA.EQ.1) THEN
27805             WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
27806  1005       FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
27807      &             'of single chains  per event',13X,F9.1)
27808          ENDIF
27809          ENDIF
27810          IF (ICSAMP.GT.0.AND.ICREQU.GT.0) THEN
27811          WRITE(LOUT,1006)
27812  1006    FORMAT(/,1X,'chain system statistics:  (per event)',/,
27813      &       23X,'mean number of chains      mean number of chains',/,
27814      &       23X,'sampled    hadronized      having mass of a reso.')
27815          WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
27816      &                     DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
27817      &                     DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
27818      &                  DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
27819  1007    FORMAT(1X,'sea     - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27820      &          1X,'disea   - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27821      &          1X,'sea     - disea   ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27822      &          1X,'sea     - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27823      &          1X,'disea   - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27824      &          1X,'valence - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27825      &          1X,'valence - disea   ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27826      &          1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27827      &          1X,'fused chains      ',18X,F4.1,17X,F4.1,/)
27828          WRITE(LOUT,1008)
27829      &     (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
27830      &     DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
27831      &     DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
27832      &     (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
27833      &     (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
27834      &     DBLE(IRHHA)/DBLE(ICREQU),
27835      &     DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
27836      &     (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
27837  1008    FORMAT(/,1X,'Rejection counter:  (NEVT = no. of events)',/,/,
27838      &       1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
27839      &       F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
27840      &       'Intrins. p_t (GETSPT)',21X,'IRPT     /NEVT = ',F7.2,/,
27841      &       1X,'Chain mass corr. for resonances (EVTRES)',2X,
27842      &       'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES)  IRRES(2) /',
27843      &       'NEVT = ',F7.2,/,43X,'LOMRES   /NEVT = ',F7.2,/,
27844      &       43X,'LOBRES   /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
27845      &       ' 2-chain systems (CHKINE)  IRCHKI(1)/NEVT = ',F7.2,/,
27846      &       43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
27847      &       'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
27848      &       F7.2,/,1X,'Total no. of rej.',
27849      &       ' in chain-systems treatment (GETCSY)',/,43X,
27850      &       'IRHHA    /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
27851      &       ' (not yet used!)',4X,'IRFRAG   /NEVT = ',F7.2,/,
27852      &       1X,'Total no. of rej. in DPM-treatment of one event',
27853      &       ' (EVENTA)',/,43X,'IREVT    /NEVT = ',F7.2,/,1X,
27854      &       'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
27855      &       ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
27856      &       'IREXCI(3) = ',I5,/)
27857          ENDIF
27858       ELSEIF (MCGENE.EQ.2) THEN
27859          WRITE(LOUT,1010) ELOJET
27860  1010    FORMAT(/,/,1X,'PHOJET-treatment of chain systems above  ',
27861      &          F4.1,' GeV')
27862          WRITE(LOUT,1011)
27863  1011    FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
27864      &          30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
27865      &          5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
27866          WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
27867      &                    (INT(ICCHAI(2,I)/2.0D0),I=1,8),
27868      &                    (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
27869      &                    ((ICEVTG(I,J),I=1,8),J=3,7),
27870      &                    ((ICEVTG(I,J),I=1,8),J=19,21),
27871      &                    (ICEVTG(I,8),I=1,8),
27872      &                    ((ICEVTG(I,J),I=1,8),J=22,24),
27873      &                    (ICEVTG(I,9),I=1,8),
27874      &                    ((ICEVTG(I,J),I=1,8),J=25,28),
27875      &                    ((ICEVTG(I,J),I=1,8),J=10,18)
27876  1012    FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
27877      &          8I8,/,/,1X,'PHOJET ',8I8,/,'   sngl ',8I8,/,/,
27878      &          ' no-dif.',8I8,/,
27879      &          ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
27880      &          ' diff-1 ',8I8,/,'  low   ',8I8,/,'  high  ',8I8,/,
27881      &          '  h-diff',8I8,/,' diff-2 ',8I8,/,'  low   ',8I8,/,
27882      &          '  high  ',8I8,/,'  h-diff',8I8,/,' dbl-di.',8I8,/,
27883      &          '  lo-lo ',8I8,/,'  hi-hi ',8I8,/,'  lo-hi ',8I8,/,
27884      &          '  hi-lo ',8I8,/,
27885      &          ' dir-ga.',8I8,/,/,' dir-1  ',8I8,/,' dir-2  ',8I8,/,
27886      &          ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
27887      &          ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
27888          WRITE(LOUT,1013)
27889  1013    FORMAT(/,1X,'2. chain system statistics -',
27890      &          ' mean numbers per evt:',/,30X,'---------------------',
27891      &          /,/,16X,'s-s',7X,'d-s',7X,'s-d')
27892          IF (ICSAMP.GT.0) THEN
27893          WRITE(LOUT,1014)
27894      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
27895      &                 (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
27896      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
27897  1014    FORMAT(/,1X,'req.to.    ',3E10.2,/,/,1X,'low rq.    ',3E10.2,/,
27898      &          1X,'low ac.    ',3E10.2,/,/,1X,'PHOJET     ',3E10.2,/,/,
27899      &          ' no-dif.    ',3E10.2,/,' el-sca.    ',3E10.2,/,
27900      &          ' qel-sc.    ',3E10.2,/,' dbl-Po.    ',3E10.2,/,
27901      &          ' diff-1     ',3E10.2,/,' diff-2     ',3E10.2,/,
27902      &          ' dbl-di.    ',3E10.2,/,' dir-ga.    ',3E10.2,/,/,
27903      &          ' dir-1      ',3E10.2,/,' dir-2      ',3E10.2,/,
27904      &          ' dbl-dir    ',3E10.2,/,' s-Pom.     ',3E10.2,/,
27905      &          ' h-Pom.     ',3E10.2,/,' s-Reg.     ',3E10.2,/,
27906      &          ' enh-trg    ',3E10.2,/,' enh-log    ',3E10.2)
27907          ENDIF
27908          WRITE(LOUT,1015)
27909  1015    FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
27910          IF (ICSAMP.GT.0) THEN
27911          WRITE(LOUT,1016)
27912      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
27913      &                 (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
27914      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
27915  1016    FORMAT(/,1X,'req.to.    ',5E10.2,/,/,1X,'low rq.    ',5E10.2,/,
27916      &          1X,'low ac.    ',5E10.2,/,/,1X,'PHOJET     ',5E10.2,/,/,
27917      &          ' no-dif.    ',5E10.2,/,' el-sca.    ',5E10.2,/,
27918      &          ' qel-sc.    ',5E10.2,/,' dbl-Po.    ',5E10.2,/,
27919      &          ' diff-1     ',5E10.2,/,' diff-2     ',5E10.2,/,
27920      &          ' dbl-di.    ',5E10.2,/,' dir-ga.    ',5E10.2,/,/,
27921      &          ' dir-1      ',5E10.2,/,' dir-2      ',5E10.2,/,
27922      &          ' dbl-dir    ',5E10.2,/,' s-Pom.     ',5E10.2,/,
27923      &          ' h-Pom.     ',5E10.2,/,' s-Reg.     ',5E10.2,/,
27924      &          ' enh-trg    ',5E10.2,/,' enh-log    ',5E10.2)
27925          ENDIF
27926
27927       ENDIF
27928       CALL DT_CHASTA(1)
27929
27930       IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
27931      &                        .OR.(PDBSEA(3).GT.0.0D0)) THEN
27932          WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
27933      &    DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
27934      &    DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
27935          WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
27936      &    DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
27937      &    DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
27938          WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
27939      &    DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
27940      &    DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
27941          WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
27942      &    DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
27943      &    DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
27944          WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
27945      &    DBRKA(3,1),DBRKA(3,2),
27946      &    DBRKA(3,3),DBRKA(3,4)
27947          WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
27948      &    DBRKR(3,1),DBRKR(3,2),
27949      &    DBRKR(3,3),DBRKR(3,4)
27950          WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
27951      &    DBRKA(3,5),DBRKA(3,6),
27952      &    DBRKA(3,7),DBRKA(3,8)
27953          WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
27954      &    DBRKR(3,5),DBRKR(3,6),
27955      &    DBRKR(3,7),DBRKR(3,8)
27956       ENDIF
27957
27958       FAC = 1.0D0
27959       IF (MCGENE.EQ.2) THEN
27960 C        CALL PHO_PHIST(-2,SIGMAX)
27961          CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
27962       ENDIF
27963
27964       CALL DT_XTIME
27965
27966       RETURN
27967       END
27968
27969 *$ CREATE DT_EVTOUT.FOR
27970 *COPY DT_EVTOUT
27971 *
27972 *===evtout=============================================================*
27973 *
27974       SUBROUTINE DT_EVTOUT(MODE)
27975
27976 ************************************************************************
27977 *            MODE  = 1  plot content of complete DTEVT1 to out. unit   *
27978 *                    3  plot entries of extended DTEVT1 (DTEVT2)       *
27979 *                    4  plot entries of DTEVT1 and DTEVT2              *
27980 * This version dated 11.12.94 is written by S. Roesler                 *
27981 ************************************************************************
27982
27983       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27984       SAVE
27985       PARAMETER ( LINP = 10 ,
27986      &            LOUT = 6 ,
27987      &            LDAT = 9 )
27988 * event history
27989       PARAMETER (NMXHKK=200000)
27990       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27991      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27992      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27993
27994       DIMENSION IRANGE(NMXHKK)
27995
27996       IF (MODE.EQ.2) RETURN
27997
27998       CALL DT_EVTPLO(IRANGE,MODE)
27999
28000       RETURN
28001       END
28002
28003 *$ CREATE DT_EVTPLO.FOR
28004 *COPY DT_EVTPLO
28005 *
28006 *===evtplo=============================================================*
28007 *
28008       SUBROUTINE DT_EVTPLO(IRANGE,MODE)
28009
28010 ************************************************************************
28011 *            MODE  = 1  plot content of complete DTEVT1 to out. unit   *
28012 *                    2  plot entries of DTEVT1 given by IRANGE         *
28013 *                    3  plot entries of extended DTEVT1 (DTEVT2)       *
28014 *                    4  plot entries of DTEVT1 and DTEVT2              *
28015 *                    5  plot rejection counter                         *
28016 * This version dated 11.12.94 is written by S. Roesler                 *
28017 ************************************************************************
28018
28019       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28020       SAVE
28021       PARAMETER ( LINP = 10 ,
28022      &            LOUT = 6 ,
28023      &            LDAT = 9 )
28024
28025       CHARACTER*16 CHAU
28026
28027 * event history
28028       PARAMETER (NMXHKK=200000)
28029       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28030      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28031      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28032 * extended event history
28033       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28034      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28035      &                IHIST(2,NMXHKK)
28036 * rejection counter
28037       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
28038      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
28039      &                IREXCI(3),IRDIFF(2),IRINC
28040
28041       DIMENSION IRANGE(NMXHKK)
28042
28043       IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
28044          WRITE(LOUT,1000)
28045  1000    FORMAT(/,1X,'EVTPLO:',14X,'    content of COMMON /DTEVT1/',/,
28046      &         15X,'           --------------------------',/,/,
28047      &             '       ST    ID  M1   M2   D1   D2     PX     PY',
28048      &             '     PZ      E       M',/)
28049          DO 1 I=1,NHKK
28050             WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28051      &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28052      &                       PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
28053      &                       PHKK(5,I)
28054 C           WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28055 C    &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28056 C    &                       PHKK(3,I),PHKK(4,I)
28057 C           WRITE(LOUT,'(4E15.4)')
28058 C    &         VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
28059  1001       FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
28060  1011       FORMAT(I5,I5,I6,4I5,2E15.5)
28061     1    CONTINUE
28062          WRITE(LOUT,*)
28063 C        DO 4 I=1,NHKK
28064 C           WRITE(LOUT,1006) I,ISTHKK(I),
28065 C    &                    VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
28066 C    &                    WHKK(2,I),WHKK(3,I)
28067 C1006       FORMAT(1X,I4,I6,6E10.3)
28068 C   4    CONTINUE
28069       ENDIF
28070
28071       IF (MODE.EQ.2) THEN
28072          WRITE(LOUT,1000)
28073          NC = 0
28074     2    CONTINUE
28075          NC = NC+1
28076          IF (IRANGE(NC).EQ.-100) GOTO 9999
28077          I = IRANGE(NC)
28078          WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28079      &                    JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28080      &                    PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
28081      &                    PHKK(5,I)
28082          GOTO 2
28083       ENDIF
28084
28085       IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
28086          WRITE(LOUT,1002)
28087  1002    FORMAT(/,1X,'EVTPLO:',14X,
28088      &         ' content of COMMON /DTEVT1/,/DTEVT2/',/,
28089      &         15X,'        -----------------------------------',/,/,
28090      &             '       ST    ID   M1   M2   D1   D2  IDR  IDXR',
28091      &             ' NOBAM IDCH    M',/)
28092          DO 3 I=1,NHKK
28093 C           IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
28094                KF    = IDHKK(I)
28095                IDCHK = KF/10000
28096                IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28097      &            (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
28098                CALL PYNAME(KF,CHAU)
28099                WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28100      &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28101      &                       IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
28102      &                       PHKK(5,I),CHAU
28103  1003          FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
28104 C           ENDIF
28105     3    CONTINUE
28106       ENDIF
28107
28108       IF (MODE.EQ.5) THEN
28109          WRITE(LOUT,1004)
28110  1004    FORMAT(/,1X,'EVTPLO:',14X,'    content of COMMON /DTREJC/',/,
28111      &         15X,'           --------------------------',/)
28112          WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
28113      &                    IRSEA,IRCRON
28114  1005    FORMAT(1X,'IRPT   = ',I5,'  IRHHA = ',I5,/,
28115      &          1X,'IRRES  = ',2I5,'  LOMRES = ',I5,'  LOBRES = ',I5,/,
28116      &          1X,'IREMC  = ',10I5,/,
28117      &          1X,'IRFRAG = ',I5,'  IRSEA = ',I5,' IRCRON = ',I5,/)
28118       ENDIF
28119
28120  9999 RETURN
28121       END
28122
28123 *$ CREATE DT_EVTPUT.FOR
28124 *COPY DT_EVTPUT
28125 *
28126 *===evtput=============================================================*
28127 *
28128       SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
28129
28130       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28131       SAVE
28132       PARAMETER ( LINP = 10 ,
28133      &            LOUT = 6 ,
28134      &            LDAT = 9 )
28135       PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
28136      &           TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0)
28137
28138 * event history
28139       PARAMETER (NMXHKK=200000)
28140       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28141      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28142      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28143 * extended event history
28144       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28145      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28146      &                IHIST(2,NMXHKK)
28147 * Lorentz-parameters of the current interaction
28148       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28149      &                UMO,PPCM,EPROJ,PPROJ
28150 * particle properties (BAMJET index convention)
28151       CHARACTER*8  ANAME
28152       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28153      &                IICH(210),IIBAR(210),K1(210),K2(210)
28154
28155 C     IF (MODE.GT.100) THEN
28156 C        WRITE(LOUT,'(1X,A,I5,A,I5)')
28157 C    &        'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
28158 C        NHKK = NHKK-MODE+100
28159 C        RETURN
28160 C     ENDIF
28161       MO1  = M1
28162       MO2  = M2
28163       NHKK = NHKK+1
28164
28165       IF (NHKK.GT.NMXHKK) THEN
28166          WRITE(LOUT,1000) NHKK
28167  1000    FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
28168      &             '! program execution stopped..')
28169          STOP
28170       ENDIF
28171       IF (M1.LT.0) MO1 = NHKK+M1
28172       IF (M2.LT.0) MO2 = NHKK+M2
28173       ISTHKK(NHKK)   = IST
28174       IDHKK(NHKK)    = ID
28175       JMOHKK(1,NHKK) = MO1
28176       JMOHKK(2,NHKK) = MO2
28177       JDAHKK(1,NHKK) = 0
28178       JDAHKK(2,NHKK) = 0
28179       IDRES(NHKK)    = IDR
28180       IDXRES(NHKK)   = IDXR
28181       IDCH(NHKK)     = IDC
28182 ** here we need to do something..
28183       IF (ID.EQ.88888) THEN
28184          IDMO1 = ABS(IDHKK(MO1))
28185          IDMO2 = ABS(IDHKK(MO2))
28186          IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
28187          IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
28188          IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
28189          IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
28190       ELSE
28191          NOBAM(NHKK) = 0
28192       ENDIF
28193       IDBAM(NHKK) = IDT_ICIHAD(ID)
28194       IF (MO1.GT.0) THEN
28195          IF (JDAHKK(1,MO1).NE.0) THEN
28196             JDAHKK(2,MO1) = NHKK
28197          ELSE
28198             JDAHKK(1,MO1) = NHKK
28199          ENDIF
28200       ENDIF
28201       IF (MO2.GT.0) THEN
28202          IF (JDAHKK(1,MO2).NE.0) THEN
28203             JDAHKK(2,MO2) = NHKK
28204          ELSE
28205             JDAHKK(1,MO2) = NHKK
28206          ENDIF
28207       ENDIF
28208 C      IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
28209 C         PTOT   = SQRT(PX**2+PY**2+PZ**2)
28210 C         AM0    = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
28211 C         AMRQ   = AAM(IDBAM(NHKK))
28212 C         AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
28213 C         IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
28214 C     &       (PTOT.GT.ZERO)) THEN
28215 C            DELTA = -AMDIF2/(2.0D0*(E+PTOT))
28216 CC           DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
28217 C            E     = E+DELTA
28218 C            PTOT1 = PTOT-DELTA
28219 C            PX    = PX*PTOT1/PTOT
28220 C            PY    = PY*PTOT1/PTOT
28221 C            PZ    = PZ*PTOT1/PTOT
28222 C         ENDIF
28223 C      ENDIF
28224       PHKK(1,NHKK) = PX
28225       PHKK(2,NHKK) = PY
28226       PHKK(3,NHKK) = PZ
28227       PHKK(4,NHKK) = E
28228       PTOT = SQRT( PX**2+PY**2+PZ**2 )
28229       IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
28230          PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
28231          PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
28232       ELSE
28233          PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
28234 C        IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
28235 C    &      WRITE(LOUT,'(1X,A,G10.3)')
28236 C    &        'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
28237          PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
28238       ENDIF
28239       IDCHK = ID/10000
28240       IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
28241 * special treatment for chains:
28242 *    z coordinate of chain in Lab  = pos. of target nucleon
28243 *    time of chain-creation in Lab = time of passage of projectile
28244 *                                    nucleus at pos. of taget nucleus
28245 C        VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
28246 C        VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
28247          VHKK(1,NHKK) = VHKK(1,MO2)
28248          VHKK(2,NHKK) = VHKK(2,MO2)
28249          VHKK(3,NHKK) = VHKK(3,MO2)
28250          VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
28251 C        WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
28252 C        WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
28253          WHKK(1,NHKK) = WHKK(1,MO1)
28254          WHKK(2,NHKK) = WHKK(2,MO1)
28255          WHKK(3,NHKK) = WHKK(3,MO1)
28256          WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
28257       ELSE
28258          IF (MO1.GT.0) THEN
28259             DO 1 I=1,4
28260                VHKK(I,NHKK) = VHKK(I,MO1)
28261                WHKK(I,NHKK) = WHKK(I,MO1)
28262     1       CONTINUE
28263          ELSE
28264             DO 2 I=1,4
28265                VHKK(I,NHKK) = ZERO
28266                WHKK(I,NHKK) = ZERO
28267     2       CONTINUE
28268          ENDIF
28269       ENDIF
28270
28271       RETURN
28272       END
28273
28274 *$ CREATE DT_CHASTA.FOR
28275 *COPY DT_CHASTA
28276 *
28277 *===chasta=============================================================*
28278 *
28279       SUBROUTINE DT_CHASTA(MODE)
28280
28281 ************************************************************************
28282 * This subroutine performs CHAin STAtistics and checks sequence of     *
28283 * partons in dtevt1 and sorts them with projectile partons coming      *
28284 * first if necessary.                                                  *
28285 *                                                                      *
28286 * This version dated  8.5.00  is written by S. Roesler.                *
28287 ************************************************************************
28288
28289       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28290       SAVE
28291       PARAMETER ( LINP = 10 ,
28292      &            LOUT = 6 ,
28293      &            LDAT = 9 )
28294
28295       CHARACTER*5 CCHTYP
28296
28297 * event history
28298       PARAMETER (NMXHKK=200000)
28299       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28300      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28301      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28302 * extended event history
28303       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28304      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28305      &                IHIST(2,NMXHKK)
28306 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
28307       PARAMETER (MAXCHN=10000)
28308       COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
28309
28310       DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
28311      &          CCHTYP(9),ICHSTA(10),ITOT(10)
28312       DATA ICHCFG /1800*0/
28313       DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
28314       DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
28315       DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
28316       DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
28317       DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
28318       DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
28319       DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
28320      &              'ad aq',' d ad','ad d ',' g g '/
28321 *
28322 * initialization
28323 *
28324       IF (MODE.EQ.-1) THEN
28325          NCHAIN = 0
28326 *
28327 * loop over DTEVT1 and analyse chain configurations
28328 *
28329       ELSEIF (MODE.EQ.0) THEN
28330          DO 21 IDX=NPOINT(3),NHKK
28331             IDCHK = IDHKK(IDX)/10000
28332             IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28333      &          (IDHKK(IDX).NE.80000).AND.
28334      &          (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
28335                IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
28336                   WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
28337      &                          ' at entry ',IDX
28338                   GOTO 21
28339                ENDIF
28340 *
28341                IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28342                IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28343                IMO1 = IST1/10
28344                IMO1 = IST1-10*IMO1
28345                IMO2 = IST2/10
28346                IMO2 = IST2-10*IMO2
28347 *   swop parton entries if necessary since we need projectile partons
28348 *   to come first in the common
28349                IF (IMO1.GT.IMO2) THEN
28350                   NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
28351                   DO 22 K=1,NPTN/2
28352                      I0 = JMOHKK(1,IDX)-1+K
28353                      I1 = JMOHKK(2,IDX)+1-K
28354                      ITMP = ISTHKK(I0)
28355                      ISTHKK(I0) = ISTHKK(I1)
28356                      ISTHKK(I1) = ITMP
28357                      ITMP = IDHKK(I0)
28358                      IDHKK(I0) = IDHKK(I1)
28359                      IDHKK(I1) = ITMP
28360                      IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
28361      &                  JDAHKK(1,JMOHKK(1,I0)) = I1
28362                      IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
28363      &                  JDAHKK(2,JMOHKK(1,I0)) = I1
28364                      IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
28365      &                  JDAHKK(1,JMOHKK(2,I0)) = I1
28366                      IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
28367      &                  JDAHKK(2,JMOHKK(2,I0)) = I1
28368                      IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
28369      &                  JDAHKK(1,JMOHKK(1,I1)) = I0
28370                      IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
28371      &                  JDAHKK(2,JMOHKK(1,I1)) = I0
28372                      IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
28373      &                  JDAHKK(1,JMOHKK(2,I1)) = I0
28374                      IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
28375      &                  JDAHKK(2,JMOHKK(2,I1)) = I0
28376                      ITMP = JMOHKK(1,I0)
28377                      JMOHKK(1,I0) = JMOHKK(1,I1)
28378                      JMOHKK(1,I1) = ITMP
28379                      ITMP = JMOHKK(2,I0)
28380                      JMOHKK(2,I0) = JMOHKK(2,I1)
28381                      JMOHKK(2,I1) = ITMP
28382                      ITMP = JDAHKK(1,I0)
28383                      JDAHKK(1,I0) = JDAHKK(1,I1)
28384                      JDAHKK(1,I1) = ITMP
28385                      ITMP = JDAHKK(2,I0)
28386                      JDAHKK(2,I0) = JDAHKK(2,I1)
28387                      JDAHKK(2,I1) = ITMP
28388                      DO 23 J=1,4
28389                         RTMP1 = PHKK(J,I0)
28390                         RTMP2 = VHKK(J,I0)
28391                         RTMP3 = WHKK(J,I0)
28392                         PHKK(J,I0) = PHKK(J,I1)
28393                         VHKK(J,I0) = VHKK(J,I1)
28394                         WHKK(J,I0) = WHKK(J,I1)
28395                         PHKK(J,I1) = RTMP1
28396                         VHKK(J,I1) = RTMP2
28397                         WHKK(J,I1) = RTMP3
28398    23                CONTINUE
28399                      RTMP1 = PHKK(5,I0)
28400                      PHKK(5,I0) = PHKK(5,I1)
28401                      PHKK(5,I1) = RTMP1
28402                      ITMP = IDRES(I0)
28403                      IDRES(I0) = IDRES(I1)
28404                      IDRES(I1) = ITMP
28405                      ITMP = IDXRES(I0)
28406                      IDXRES(I0) = IDXRES(I1)
28407                      IDXRES(I1) = ITMP
28408                      ITMP = NOBAM(I0)
28409                      NOBAM(I0) = NOBAM(I1)
28410                      NOBAM(I1) = ITMP
28411                      ITMP = IDBAM(I0)
28412                      IDBAM(I0) = IDBAM(I1)
28413                      IDBAM(I1) = ITMP
28414                      ITMP = IDCH(I0)
28415                      IDCH(I0) = IDCH(I1)
28416                      IDCH(I1) = ITMP
28417                      ITMP = IHIST(1,I0)
28418                      IHIST(1,I0) = IHIST(1,I1)
28419                      IHIST(1,I1) = ITMP
28420                      ITMP = IHIST(2,I0)
28421                      IHIST(2,I0) = IHIST(2,I1)
28422                      IHIST(2,I1) = ITMP
28423    22             CONTINUE
28424                ENDIF
28425                IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28426                IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28427 *
28428 *   parton 1 (projectile side)
28429                IF (IST1.EQ.21) THEN
28430                   IDX1 = 1
28431                ELSEIF (IST1.EQ.22) THEN
28432                   IDX1 = 2
28433                ELSEIF (IST1.EQ.31) THEN
28434                   IDX1 = 3
28435                ELSEIF (IST1.EQ.32) THEN
28436                   IDX1 = 4
28437                ELSEIF (IST1.EQ.41) THEN
28438                   IDX1 = 5
28439                ELSEIF (IST1.EQ.42) THEN
28440                   IDX1 = 6
28441                ELSEIF (IST1.EQ.51) THEN
28442                   IDX1 = 7
28443                ELSEIF (IST1.EQ.52) THEN
28444                   IDX1 = 8
28445                ELSEIF (IST1.EQ.61) THEN
28446                   IDX1 = 9
28447                ELSEIF (IST1.EQ.62) THEN
28448                   IDX1 = 10
28449                ELSE
28450 c                 WRITE(LOUT,*)
28451 c    &               ' CHASTA: unknown parton status flag (',
28452 c    &               IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28453                   GOTO 21
28454                ENDIF
28455                ID = IDHKK(JMOHKK(1,IDX))
28456                IF (ABS(ID).LE.4) THEN
28457                   IF (ID.GT.0) THEN
28458                      ITYP1 = 1
28459                   ELSE
28460                      ITYP1 = 2
28461                   ENDIF
28462                ELSEIF (ABS(ID).GE.1000) THEN
28463                   IF (ID.GT.0) THEN
28464                      ITYP1 = 3
28465                   ELSE
28466                      ITYP1 = 4
28467                   ENDIF
28468                ELSEIF (ID.EQ.21) THEN
28469                   ITYP1 = 5
28470                ELSE
28471                   WRITE(LOUT,*)
28472      &               ' CHASTA: inconsistent parton identity (',
28473      &               ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28474                   GOTO 21
28475                ENDIF
28476 *
28477 *   parton 2 (target side)
28478                IF (IST2.EQ.21) THEN
28479                   IDX2 = 1
28480                ELSEIF (IST2.EQ.22) THEN
28481                   IDX2 = 2
28482                ELSEIF (IST2.EQ.31) THEN
28483                   IDX2 = 3
28484                ELSEIF (IST2.EQ.32) THEN
28485                   IDX2 = 4
28486                ELSEIF (IST2.EQ.41) THEN
28487                   IDX2 = 5
28488                ELSEIF (IST2.EQ.42) THEN
28489                   IDX2 = 6
28490                ELSEIF (IST2.EQ.51) THEN
28491                   IDX2 = 7
28492                ELSEIF (IST2.EQ.52) THEN
28493                   IDX2 = 8
28494                ELSEIF (IST2.EQ.61) THEN
28495                   IDX2 = 9
28496                ELSEIF (IST2.EQ.62) THEN
28497                   IDX2 = 10
28498                ELSE
28499 c                 WRITE(LOUT,*)
28500 c    &               ' CHASTA: unknown parton status flag (',
28501 c    &               IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
28502                   GOTO 21
28503                ENDIF
28504                ID = IDHKK(JMOHKK(2,IDX))
28505                IF (ABS(ID).LE.4) THEN
28506                   IF (ID.GT.0) THEN
28507                      ITYP2 = 1
28508                   ELSE
28509                      ITYP2 = 2
28510                   ENDIF
28511                ELSEIF (ABS(ID).GE.1000) THEN
28512                   IF (ID.GT.0) THEN
28513                      ITYP2 = 3
28514                   ELSE
28515                      ITYP2 = 4
28516                   ENDIF
28517                ELSEIF (ID.EQ.21) THEN
28518                   ITYP2 = 5
28519                ELSE
28520                   WRITE(LOUT,*)
28521      &               ' CHASTA: inconsistent parton identity (',
28522      &               ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28523                   GOTO 21
28524                ENDIF
28525 *
28526 *   fill counter
28527                ITYPE = ICHTYP(ITYP1,ITYP2)
28528                IF (ITYPE.NE.0) THEN
28529                   ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
28530                   NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
28531                   ICHCFG(IDX1,IDX2,ITYPE,2) =
28532      &               ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
28533
28534                   NCHAIN = NCHAIN+1
28535                   IF (NCHAIN.GT.MAXCHN) THEN
28536                      WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
28537      &                  NCHAIN,MAXCHN
28538                      STOP
28539                   ENDIF
28540                   IDXCHN(1,NCHAIN) = IDX
28541                   IDXCHN(2,NCHAIN) = ITYPE
28542                ELSE
28543                   WRITE(LOUT,*)
28544      &               ' CHASTA: inconsistent chain at entry ',IDX
28545                   GOTO 21
28546                ENDIF
28547             ENDIF
28548    21    CONTINUE
28549 *
28550 * write statistics to output unit
28551 *
28552       ELSEIF (MODE.EQ.1) THEN
28553          WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
28554          DO 31 I=1,10
28555             WRITE(LOUT,'(/,2A)')
28556      &         ' -----------------------------------------',
28557      &         '------------------------------------'
28558             WRITE(LOUT,'(2A)')
28559      &         ' p\\t         21     22     31     32     41',
28560      &         '     42     51     52     61     62'
28561             WRITE(LOUT,'(2A)')
28562      &         ' -----------------------------------------',
28563      &         '------------------------------------'
28564             DO 32 J=1,10
28565                ITOT(J) = 0
28566                DO 33 K=1,9
28567                   ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
28568    33          CONTINUE
28569    32       CONTINUE
28570             WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
28571             DO 34 K=1,9
28572                ISUM = 0
28573                DO 35 J=1,10
28574                   ISUM = ISUM+ICHCFG(I,J,K,1)
28575    35          CONTINUE
28576                IF (ISUM.GT.0)
28577      &            WRITE(LOUT,'(1X,A5,2X,10I7)')
28578      &               CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
28579    34       CONTINUE
28580 C           WRITE(LOUT,'(2A)')
28581 C    &         ' -----------------------------------------',
28582 C    &         '-------------------------------'
28583    31    CONTINUE
28584 *
28585       ELSE
28586          WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
28587          STOP
28588       ENDIF
28589
28590       RETURN
28591       END
28592 *$ CREATE PHO_PHIST.FOR
28593 *COPY PHO_PHIST
28594 *
28595 *===pohist=============================================================*
28596 *
28597       SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
28598
28599       IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28600       SAVE
28601
28602       PARAMETER ( LINP = 10 ,
28603      &            LOUT = 6 ,
28604      &            LDAT = 9 )
28605       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
28606 * Glauber formalism: cross sections
28607       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
28608      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
28609      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
28610      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
28611      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
28612      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
28613      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
28614      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
28615      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
28616      &                BSLOPE,NEBINI,NQBINI
28617
28618       ILAB = 0
28619       IF (IMODE.EQ.10) THEN
28620          IMODE = 1
28621          ILAB  = 1
28622       ENDIF
28623       IF (ABS(IMODE).LT.1000) THEN
28624 * PHOJET-statistics
28625 C        CALL POHISX(IMODE,WEIGHT)
28626          IF (IMODE.EQ.-1) THEN
28627             MODE = 1
28628             XSTOT(1,1,1) = WEIGHT
28629          ENDIF
28630          IF (IMODE.EQ. 1) MODE = 2
28631          IF (IMODE.EQ.-2) MODE = 3
28632          IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
28633 C        IF (MODE.EQ.3) WRITE(LOUT,*)
28634 C    &      ' Sigma = ',XSPRO(1,1,1),' mb   used for normalization'
28635          CALL DT_HISTOG(MODE)
28636          CALL DT_USRHIS(MODE)
28637       ELSE
28638 * DTUNUC-statistics
28639          MODE = IMODE/1000
28640 C        IF (MODE.EQ.3) WRITE(LOUT,*)
28641 C    &      ' Sigma = ',XSPRO(1,1,1),' mb   used for normalization'
28642          CALL DT_HISTOG(MODE)
28643          CALL DT_USRHIS(MODE)
28644       ENDIF
28645
28646       RETURN
28647       END
28648
28649 *$ CREATE DT_SWPPHO.FOR
28650 *COPY DT_SWPPHO
28651 *
28652 *===swppho=============================================================*
28653 *
28654       SUBROUTINE DT_SWPPHO(ILAB)
28655
28656       IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28657       SAVE
28658       PARAMETER ( LINP = 10 ,
28659      &            LOUT = 6 ,
28660      &            LDAT = 9 )
28661       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28662
28663       LOGICAL LSTART
28664
28665 * event history
28666       PARAMETER (NMXHKK=200000)
28667       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28668      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28669      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28670 * extended event history
28671       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28672      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28673      &                IHIST(2,NMXHKK)
28674 * flags for input different options
28675       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28676       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28677      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28678 * properties of photon/lepton projectiles
28679       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
28680
28681 **PHOJET105a
28682 C     PARAMETER (NMXHEP=2000)
28683 C     COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28684 C    &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
28685 C     COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28686 C     COMMON /PLASAV/ PLAB
28687 **PHOJET110
28688 C  standard particle data interface
28689       INTEGER NMXHEP
28690       PARAMETER (NMXHEP=4000)
28691       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28692       DOUBLE PRECISION PHEP,VHEP
28693       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28694      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28695      &                VHEP(4,NMXHEP),NSD1, NSD2, NDD
28696 C  extension to standard particle data interface (PHOJET specific)
28697       INTEGER IMPART,IPHIST,ICOLOR
28698       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28699 C  global event kinematics and particle IDs
28700       INTEGER IFPAP,IFPAB
28701       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28702       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28703 **
28704       DATA ICOUNT/0/
28705
28706       DATA LSTART /.TRUE./
28707
28708 C     IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
28709       IF ((IFRAME.EQ.1).AND.LSTART) THEN
28710          UMO  = ECM
28711          ELA  = ZERO
28712          PLA  = ZERO
28713          IDP  = IDT_ICIHAD(IFPAP(1))
28714          IDT  = IDT_ICIHAD(IFPAP(2))
28715          VIRT = PVIRT(1)
28716          CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
28717          PLAB = PLA
28718          LSTART = .FALSE.
28719       ENDIF
28720
28721       NHKK   = 0
28722       ICOUNT = ICOUNT+1
28723 C     NEVHKK = NEVHEP
28724       NEVHKK = ICOUNT
28725       IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
28726       DO 1 I=3,NHEP
28727          IF (ISTHEP(I).EQ.1) THEN
28728             NHKK = NHKK+1
28729             ISTHKK(NHKK) = 1
28730             IDHKK(NHKK)  = IDHEP(I)
28731             JMOHKK(1,NHKK) = 0
28732             JMOHKK(2,NHKK) = 0
28733             JDAHKK(1,NHKK) = 0
28734             JDAHKK(2,NHKK) = 0
28735             DO 2 K=1,4
28736                PHKK(K,NHKK) = PHEP(K,I)
28737                VHKK(K,NHKK) = ZERO
28738                WHKK(K,NHKK) = ZERO
28739     2       CONTINUE
28740             IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
28741      &         CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
28742      &                    PHKK(3,NHKK),PHKK(4,NHKK),-3)
28743             PHKK(5,NHKK) = PHEP(5,I)
28744             IDRES(NHKK)  = 0
28745             IDXRES(NHKK) = 0
28746             NOBAM(NHKK)  = 0
28747             IDBAM(NHKK)  = IDT_ICIHAD(IDHEP(I))
28748             IDCH(NHKK)   = 0
28749          ENDIF
28750     1 CONTINUE
28751
28752       RETURN
28753       END
28754
28755 *$ CREATE DT_HISTOG.FOR
28756 *COPY DT_HISTOG
28757 *
28758 *===histog=============================================================*
28759 *
28760       SUBROUTINE DT_HISTOG(MODE)
28761
28762 ************************************************************************
28763 * This version dated 25.03.96 is written by S. Roesler                 *
28764 ************************************************************************
28765
28766       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28767       SAVE
28768       PARAMETER ( LINP = 10 ,
28769      &            LOUT = 6 ,
28770      &            LDAT = 9 )
28771
28772       LOGICAL LFSP,LRNL
28773
28774 * event history
28775       PARAMETER (NMXHKK=200000)
28776       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28777      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28778      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28779 * extended event history
28780       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28781      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28782      &                IHIST(2,NMXHKK)
28783 * event flag used for histograms
28784       COMMON /DTNORM/ ICEVT,IEVHKK
28785 * flags for activated histograms
28786       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
28787
28788       IEVHKK = NEVHKK
28789       GOTO (1,2,3) MODE
28790
28791 *------------------------------------------------------------------
28792 * initialization
28793     1 CONTINUE
28794       ICEVT = 0
28795       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
28796       IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
28797
28798       RETURN
28799 *------------------------------------------------------------------
28800 * filling of histogram with event-record
28801     2 CONTINUE
28802       ICEVT = ICEVT+1
28803
28804       DO 20 I=1,NHKK
28805          CALL DT_SWPFSP(I,LFSP,LRNL)
28806          IF (LFSP) THEN
28807             IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
28808             IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
28809          ENDIF
28810          IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
28811    20 CONTINUE
28812       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
28813
28814       RETURN
28815 *------------------------------------------------------------------
28816 * output
28817     3 CONTINUE
28818       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
28819       IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
28820
28821       RETURN
28822       END
28823
28824 *$ CREATE DT_SWPFSP.FOR
28825 *COPY DT_SWPFSP
28826 *
28827 *===swpfsp=============================================================*
28828 *
28829       SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
28830
28831       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28832       SAVE
28833       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28834       PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
28835      &           PI   =TWOPI/TWO,
28836      &           BOG  =TWOPI/360.0D0)
28837
28838 * event history
28839       PARAMETER (NMXHKK=200000)
28840       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28841      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28842      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28843 * extended event history
28844       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28845      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28846      &                IHIST(2,NMXHKK)
28847 * particle properties (BAMJET index convention)
28848       CHARACTER*8  ANAME
28849       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28850      &                IICH(210),IIBAR(210),K1(210),K2(210)
28851 * Lorentz-parameters of the current interaction
28852       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28853      &                UMO,PPCM,EPROJ,PPROJ
28854 * flags for input different options
28855       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28856       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28857      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28858 * (original name: PAREVT)
28859       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
28860      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
28861       PARAMETER ( NALLWP = 39   )
28862       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
28863      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
28864      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
28865      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
28866 * temporary storage for one final state particle
28867       LOGICAL LFRAG,LGREY,LBLACK
28868       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28869      &                SINTHE,COSTHE,THETA,THECMS,
28870      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28871      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28872      &                LFRAG,LGREY,LBLACK
28873
28874       LOGICAL LFSP,LRNL
28875
28876       LFSP = .FALSE.
28877       LRNL = .FALSE.
28878       ISTRNL = 1000
28879       MULDEF = 1
28880       IF (LEVPRT) ISTRNL = 1001
28881
28882       IF (ABS(ISTHKK(IDX)).EQ.1) THEN
28883          IST    = ISTHKK(IDX)
28884          IDPDG  = IDHKK(IDX)
28885          LFRAG  = .FALSE.
28886          IF (IDHKK(IDX).LT.80000) THEN
28887             IDBJT  = IDBAM(IDX)
28888             IBARY  = IIBAR(IDBJT)
28889             ICHAR  = IICH(IDBJT)
28890             AMASS  = AAM(IDBJT)
28891          ELSEIF (IDHKK(IDX).EQ.80000) THEN
28892             IDBJT  = 0
28893             IBARY  = IDRES(IDX)
28894             ICHAR  = IDXRES(IDX)
28895             AMASS  = PHKK(5,IDX)
28896             INUT   = IBARY-ICHAR
28897             IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
28898             IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
28899             IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
28900             IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
28901             IF (IDBJT.EQ.0) LFRAG = .TRUE.
28902          ELSE
28903             GOTO 9999
28904          ENDIF
28905          PE     = PHKK(4,IDX)
28906          PX     = PHKK(1,IDX)
28907          PY     = PHKK(2,IDX)
28908          PZ     = PHKK(3,IDX)
28909          PT2    = PX**2+PY**2
28910          PT     = SQRT(PT2)
28911          PTOT   = SQRT(PT2+PZ**2)
28912          SINTHE = PT/MAX(PTOT,TINY14)
28913          COSTHE = PZ/MAX(PTOT,TINY14)
28914          IF (COSTHE.GT.ONE) THEN
28915             THETA = ZERO
28916          ELSEIF (COSTHE.LT.-ONE) THEN
28917             THETA = TWOPI/2.0D0
28918          ELSE
28919             THETA = ACOS(COSTHE)
28920          ENDIF
28921          EKIN   = PE-AMASS
28922 **sr 15.4.96 new E_t-definition
28923          IF (IBARY.GT.0) THEN
28924             ET = EKIN*SINTHE
28925          ELSEIF (IBARY.LT.0) THEN
28926             ET = (EKIN+TWO*AMASS)*SINTHE
28927          ELSE
28928             ET = PE*SINTHE
28929          ENDIF
28930 **
28931          XLAB   = PZ/MAX(PPROJ,TINY14)
28932 C        XLAB   = PE/MAX(EPROJ,TINY14)
28933          BETA   = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
28934      &                     *(ONE+AMASS/MAX(PE,TINY14)) ))
28935          PPLUS  = PE+PZ
28936          PMINUS = PE-PZ
28937          IF (PMINUS.GT.TINY14) THEN
28938             YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28939          ELSE
28940             YY = 100.0D0
28941          ENDIF
28942          IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28943             ETA = -LOG(TAN(THETA/TWO))
28944          ELSE
28945             ETA = 100.0D0
28946          ENDIF
28947          IF (IFRAME.EQ.1) THEN
28948             CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
28949             PPLUS  = EECMS+PZCMS
28950             PMINUS = EECMS-PZCMS
28951             IF ((PPLUS*PMINUS).GT.TINY14) THEN
28952                YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28953             ELSE
28954                YYCMS = 100.0D0
28955             ENDIF
28956             PTOTCM = SQRT(PT2+PZCMS**2)
28957             COSTH = PZCMS/MAX(PTOTCM,TINY14)
28958             IF (COSTH.GT.ONE) THEN
28959                THECMS = ZERO
28960             ELSEIF (COSTH.LT.-ONE) THEN
28961                THECMS = TWOPI/2.0D0
28962             ELSE
28963                THECMS = ACOS(COSTH)
28964             ENDIF
28965             IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
28966                ETACMS = -LOG(TAN(THECMS/TWO))
28967             ELSE
28968                ETACMS = 100.0D0
28969             ENDIF
28970             XF = PZCMS/MAX(PPCM,TINY14)
28971             THECMS = THECMS/BOG
28972          ELSE
28973             PZCMS  = PZ
28974             EECMS  = PE
28975             YYCMS  = YY
28976             ETACMS = ETA
28977             XF     = XLAB
28978             THECMS = THETA/BOG
28979          ENDIF
28980          THETA  = THETA/BOG
28981
28982 * set flag for "grey/black"
28983          LGREY  = .FALSE.
28984          LBLACK = .FALSE.
28985          EK     = EKIN
28986          IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
28987          IF (MULDEF.EQ.1) THEN
28988 *  EMU01-Def.
28989             IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
28990      &                              (EK.LE.375.0D-3)      ).OR.
28991      &           ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
28992      &                              (EK.LE. 56.0D-3)      ).OR.
28993      &           ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
28994      &                              (EK.LE. 56.0D-3)      ).OR.
28995      &           ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
28996      &                              (EK.LE.198.0D-3)      ).OR.
28997      &           ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
28998      &                              (EK.LE.198.0D-3)      ).OR.
28999      &           ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
29000      &             (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
29001      &             (IDBJT.NE.16).AND.
29002      &             (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)    ) )
29003      &         LGREY = .TRUE.
29004             IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
29005      &           ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
29006      &           ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
29007      &           ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
29008      &           ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
29009      &           ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
29010      &             (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
29011      &             (IDBJT.NE.16).AND.(BETA.LE.0.23D0)  ) )
29012      &         LBLACK = .TRUE.
29013          ELSE
29014 *  common Def.
29015             IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
29016             IF (BETA.LE.0.23D0) LBLACK=.TRUE.
29017          ENDIF
29018          LFSP = .TRUE.
29019       ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
29020          IST    = ISTHKK(IDX)
29021          IDPDG  = IDHKK(IDX)
29022          LFRAG  = .TRUE.
29023          IDBJT  = 0
29024          IBARY  = IDRES(IDX)
29025          ICHAR  = IDXRES(IDX)
29026          AMASS  = PHKK(5,IDX)
29027          PE     = PHKK(4,IDX)
29028          PX     = PHKK(1,IDX)
29029          PY     = PHKK(2,IDX)
29030          PZ     = PHKK(3,IDX)
29031          PT2    = PX**2+PY**2
29032          PT     = SQRT(PT2)
29033          PTOT   = SQRT(PT2+PZ**2)
29034          SINTHE = PT/MAX(PTOT,TINY14)
29035          COSTHE = PZ/MAX(PTOT,TINY14)
29036          IF (COSTHE.GT.ONE) THEN
29037             THETA = ZERO
29038          ELSEIF (COSTHE.LT.-ONE) THEN
29039             THETA = TWOPI/2.0D0
29040          ELSE
29041             THETA  = ACOS(COSTHE)
29042          ENDIF
29043          EKIN   = PE-AMASS
29044 **sr 15.4.96 new E_t-definition
29045 C        ET     = PE*SINTHE
29046          ET     = EKIN*SINTHE
29047 **
29048          IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
29049             ETA = -LOG(TAN(THETA/TWO))
29050          ELSE
29051             ETA = 100.0D0
29052          ENDIF
29053          THETA  = THETA/BOG
29054          LRNL   = .TRUE.
29055       ENDIF
29056
29057  9999 CONTINUE
29058       RETURN
29059       END
29060
29061 *$ CREATE DT_HIMULT.FOR
29062 *COPY DT_HIMULT
29063 *
29064 *===himult=============================================================*
29065 *
29066       SUBROUTINE DT_HIMULT(MODE)
29067
29068 ************************************************************************
29069 * Tables of average energies/multiplicities.                           *
29070 * This version dated 30.08.2000 is written by S. Roesler               *
29071 ************************************************************************
29072
29073       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29074       SAVE
29075       PARAMETER ( LINP = 10 ,
29076      &            LOUT = 6 ,
29077      &            LDAT = 9 )
29078       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29079
29080       PARAMETER (SWMEXP=1.7D0)
29081
29082       CHARACTER*8 ANAMEH(4)
29083
29084 * particle properties (BAMJET index convention)
29085       CHARACTER*8  ANAME
29086       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29087      &                IICH(210),IIBAR(210),K1(210),K2(210)
29088 * temporary storage for one final state particle
29089       LOGICAL LFRAG,LGREY,LBLACK
29090       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29091      &                SINTHE,COSTHE,THETA,THECMS,
29092      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29093      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29094      &                LFRAG,LGREY,LBLACK
29095 * event flag used for histograms
29096       COMMON /DTNORM/ ICEVT,IEVHKK
29097 * Lorentz-parameters of the current interaction
29098       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
29099      &                UMO,PPCM,EPROJ,PPROJ
29100
29101       PARAMETER (NOPART=210)
29102       DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
29103      &          AVPT(4,NOPART),IAVPT(4,NOPART)
29104       DATA ANAMEH /'DEUTERON','3-H     ','3-HE    ','4-HE    '/
29105
29106       GOTO (1,2,3) MODE
29107
29108 *------------------------------------------------------------------
29109 * initialization
29110     1 CONTINUE
29111       DO 10 I=1,NOPART
29112          DO 11 J=1,4
29113             AVMULT(J,I) = ZERO
29114             AVE(J,I)    = ZERO
29115             AVSWM(J,I)  = ZERO
29116             AVPT(J,I)   = ZERO
29117             IAVPT(J,I)  = 0
29118    11    CONTINUE
29119    10 CONTINUE
29120
29121       RETURN
29122
29123 *------------------------------------------------------------------
29124 * filling of histogram with event-record
29125     2 CONTINUE
29126       IF (PE.LT.0.0D0) THEN
29127          WRITE(LOUT,*) ' HIMULT:  PE < 0 ! ',PE
29128          RETURN
29129       ENDIF
29130       IF (.NOT.LFRAG) THEN
29131          IVEL = 2
29132          IF (LGREY)  IVEL = 3
29133          IF (LBLACK) IVEL = 4
29134          AVE(1,IDBJT)       = AVE(1,IDBJT)   +PE
29135          AVE(IVEL,IDBJT)    = AVE(IVEL,IDBJT)+PE
29136          AVPT(1,IDBJT)     = AVPT(1,IDBJT)   +PT
29137          AVPT(IVEL,IDBJT)  = AVPT(IVEL,IDBJT)+PT
29138          IAVPT(1,IDBJT)    = IAVPT(1,IDBJT)   +1
29139          IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
29140          AVSWM(1,IDBJT)     = AVSWM(1,IDBJT)   +PE**SWMEXP
29141          AVSWM(IVEL,IDBJT)  = AVSWM(IVEL,IDBJT)+PE**SWMEXP
29142          AVMULT(1,IDBJT)    = AVMULT(1,IDBJT)   +ONE
29143          AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
29144          IF (IDBJT.LT.116) THEN
29145 *   total energy, multiplicity
29146             AVE(1,30)       = AVE(1,30)   +PE
29147             AVE(IVEL,30)    = AVE(IVEL,30)+PE
29148             AVPT(1,30)     = AVPT(1,30)   +PT
29149             AVPT(IVEL,30)  = AVPT(IVEL,30)+PT
29150             IAVPT(1,30)    = IAVPT(1,30)   +1
29151             IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
29152             AVSWM(1,30)     = AVSWM(1,30)+PE**SWMEXP
29153             AVSWM(IVEL,30)  = AVSWM(IVEL,30)+PE**SWMEXP
29154             AVMULT(1,30)    = AVMULT(1,30)   +ONE
29155             AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
29156 *   charged energy, multiplicity
29157             IF (ICHAR.LT.0) THEN
29158                AVE(1,26)       = AVE(1,26)   +PE
29159                AVE(IVEL,26)    = AVE(IVEL,26)+PE
29160                AVPT(1,26)     = AVPT(1,26)   +PT
29161                AVPT(IVEL,26)  = AVPT(IVEL,26)+PT
29162                IAVPT(1,26)    = IAVPT(1,26)   +1
29163                IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
29164                AVSWM(1,26)     = AVSWM(1,26)   +PE**SWMEXP
29165                AVSWM(IVEL,26)  = AVSWM(IVEL,26)+PE**SWMEXP
29166                AVMULT(1,26)    = AVMULT(1,26)   +ONE
29167                AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
29168             ENDIF
29169             IF (ICHAR.NE.0) THEN
29170                AVE(1,27)       = AVE(1,27)   +PE
29171                AVE(IVEL,27)    = AVE(IVEL,27)+PE
29172                AVPT(1,27)     = AVPT(1,27)   +PT
29173                AVPT(IVEL,27)  = AVPT(IVEL,27)+PT
29174                IAVPT(1,27)    = IAVPT(1,27)   +1
29175                IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
29176                AVSWM(1,27)     = AVSWM(1,27)   +PE**SWMEXP
29177                AVSWM(IVEL,27)  = AVSWM(IVEL,27)+PE**SWMEXP
29178                AVMULT(1,27)    = AVMULT(1,27)   +ONE
29179                AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
29180             ENDIF
29181          ENDIF
29182       ENDIF
29183
29184       RETURN
29185
29186 *------------------------------------------------------------------
29187 * output
29188     3 CONTINUE
29189       WRITE(LOUT,3000)
29190  3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
29191      &       29X,'---------------------',/)
29192       IF (MULDEF.EQ.1) THEN
29193          WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
29194       ELSE
29195          BETGRE = 0.7D0
29196          BETBLC = 0.23D0
29197          WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
29198  3002    FORMAT(1X,'fast:  beta > ',F4.2,'    grey:  ',F4.2,' > beta > '
29199      &          ,F4.2,'    black:  beta < ',F4.2,/)
29200       ENDIF
29201       WRITE(LOUT,3003) SWMEXP
29202  3003 FORMAT(1X,'particle    |',12X,'average multiplicity',/,
29203      &      13X,'|     total         fast',
29204 C    &      '       grey     black      K      f(',F3.1,')',/,1X,
29205      &      '       grey     black    <pt>     f(',F3.1,')',/,1X,
29206      &      '------------+--------------',
29207      &      '-------------------------------------------------')
29208       DO 30 I=1,NOPART
29209          DO 31 J=1,4
29210             AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
29211             AVE(J,I)    = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
29212             AVPT(J,I)   = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
29213             AVSWM(J,I)  = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
29214    31    CONTINUE
29215          IF (I.LE.115) THEN
29216             WRITE(LOUT,3004) ANAME(I),I,
29217      &                       AVMULT(1,I),AVMULT(2,I),
29218      &                       AVMULT(3,I),AVMULT(4,I),
29219 C    &                       AVE(1,I),AVSWM(1,I)
29220      &                       AVPT(1,I),AVSWM(1,I)
29221          ELSEIF (I.LE.119) THEN
29222             WRITE(LOUT,3004) ANAMEH(I-115),I,
29223      &                       AVMULT(1,I),AVMULT(2,I),
29224      &                       AVMULT(3,I),AVMULT(4,I),
29225 C    &                       AVE(1,I),AVSWM(1,I)
29226      &                       AVPT(1,I),AVSWM(1,I)
29227          ENDIF
29228  3004    FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
29229    30 CONTINUE
29230 **temporary
29231 C     WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
29232 C    &               AVMULT(3,27)+AVMULT(4,27)
29233 **
29234
29235       RETURN
29236       END
29237
29238 *$ CREATE DT_HISTAT.FOR
29239 *COPY DT_HISTAT
29240 *
29241 *===histat=============================================================*
29242 *
29243       SUBROUTINE DT_HISTAT(IDX,MODE)
29244
29245 ************************************************************************
29246 * This version dated 26.02.96 is written by S. Roesler                 *
29247 *                                                                      *
29248 * Last change 27.12.2006 by S. Roesler.                                *
29249 ************************************************************************
29250
29251       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29252       SAVE
29253       PARAMETER ( LINP = 10 ,
29254      &            LOUT = 6 ,
29255      &            LDAT = 9 )
29256       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29257       PARAMETER (NDIM=199)
29258
29259 * event history
29260       PARAMETER (NMXHKK=200000)
29261       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
29262      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
29263      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
29264 * extended event history
29265       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
29266      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
29267      &                IHIST(2,NMXHKK)
29268 * particle properties (BAMJET index convention)
29269       CHARACTER*8  ANAME
29270       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29271      &                IICH(210),IIBAR(210),K1(210),K2(210)
29272       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
29273 * Glauber formalism: cross sections
29274       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
29275      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
29276      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
29277      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
29278      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
29279      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
29280      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
29281      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
29282      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
29283      &                BSLOPE,NEBINI,NQBINI
29284 * emulsion treatment
29285       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
29286      &                NCOMPO,IEMUL
29287 * properties of interacting particles
29288       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
29289 * rejection counter
29290       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
29291      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
29292      &                IREXCI(3),IRDIFF(2),IRINC
29293 * statistics: residual nuclei
29294       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
29295      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
29296      &                NINCST(2,4),NINCEV(2),
29297      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
29298      &                NRESPB(2),NRESCH(2),NRESEV(4),
29299      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
29300      &                NEVAFI(2,2)
29301 * parameter for intranuclear cascade
29302       LOGICAL LPAULI
29303       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
29304 * (original name: PAREVT)
29305       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
29306      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
29307       PARAMETER ( NALLWP = 39   )
29308       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
29309      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
29310      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
29311      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
29312 * (original name: FRBKCM)
29313       PARAMETER ( MXFFBK =     6 )
29314       PARAMETER ( MXZFBK =     9 )
29315       PARAMETER ( MXNFBK =    10 )
29316       PARAMETER ( MXAFBK =    16 )
29317       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
29318       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
29319       PARAMETER ( NXAFBK = MXAFBK + 1 )
29320       PARAMETER ( MXPSST =   300 )
29321       PARAMETER ( MXPSFB = 41000 )
29322       LOGICAL LFRMBK, LNCMSS
29323       COMMON /FKFRBK/  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
29324      &          EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
29325      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
29326      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
29327      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
29328      &          IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
29329      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
29330      &          IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
29331      &          IFBFRB, NBUFBK, LFRMBK, LNCMSS
29332 * (original name: INPFLG)
29333       COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
29334 * temporary storage for one final state particle
29335       LOGICAL LFRAG,LGREY,LBLACK
29336       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29337      &                SINTHE,COSTHE,THETA,THECMS,
29338      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29339      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29340      &                LFRAG,LGREY,LBLACK
29341 * event flag used for histograms
29342       COMMON /DTNORM/ ICEVT,IEVHKK
29343 * statistics: double-Pomeron exchange
29344       COMMON /DTFLG2/ INTFLG,IPOPO
29345
29346       DIMENSION EMUSAM(NCOMPX)
29347
29348       CHARACTER*13 CMSG(3)
29349       DATA CMSG /'not requested','not requested','not requested'/
29350
29351       GOTO (1,2,3,4,5) MODE
29352
29353 *------------------------------------------------------------------
29354 * initialization
29355     1 CONTINUE
29356 *  emulsion treatment
29357       IF (NCOMPO.GT.0) THEN
29358          DO 10 I=1,NCOMPX
29359             EMUSAM(I) = ZERO
29360    10    CONTINUE
29361       ENDIF
29362 * common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
29363       NINCGE = 0
29364       DO 11 I=1,2
29365          EXCDPM(I)   = ZERO
29366          EXCDPM(I+2) = ZERO
29367          EXCEVA(I)   = ZERO
29368          NINCWO(I)   = 0
29369          NINCEV(I)   = 0
29370          NRESTO(I)   = 0
29371          NRESPR(I)   = 0
29372          NRESNU(I)   = 0
29373          NRESBA(I)   = 0
29374          NRESPB(I)   = 0
29375          NRESCH(I)   = 0
29376          NRESEV(I)   = 0
29377          NRESEV(I+2) = 0
29378          NEVAGA(I)   = 0
29379          NEVAHT(I)   = 0
29380          NEVAFI(1,I) = 0
29381          NEVAFI(2,I) = 0
29382          DO 12 J=1,6
29383             IF (J.LE.2) NINCHR(I,J) = 0
29384             IF (J.LE.3) NINCCO(I,J) = 0
29385             IF (J.LE.4) NINCST(I,J) = 0
29386             NEVA(I,J) = 0
29387    12    CONTINUE
29388          DO 13 J=1,210
29389             NEVAHY(1,I,J) = 0
29390             NEVAHY(2,I,J) = 0
29391    13    CONTINUE
29392    11 CONTINUE
29393       MAXGEN = 0
29394 **dble Po statistics.
29395       KPOPO = 0
29396
29397       RETURN
29398 *------------------------------------------------------------------
29399 * filling of histogram with event-record
29400     2 CONTINUE
29401       IF (IST.EQ.-1) THEN
29402          IF (.NOT.LFRAG) THEN
29403             IF (IDPDG.EQ.2212) THEN
29404                NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
29405             ELSEIF (IDPDG.EQ.2112) THEN
29406                NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
29407             ELSEIF (IDPDG.EQ.22) THEN
29408                NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
29409             ELSEIF (IDPDG.EQ.80000) THEN
29410                IF (IDBJT.EQ.116) THEN
29411                   NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
29412                ELSEIF (IDBJT.EQ.117) THEN
29413                   NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
29414                ELSEIF (IDBJT.EQ.118) THEN
29415                   NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
29416                ELSEIF (IDBJT.EQ.119) THEN
29417                   NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
29418                ENDIF
29419             ENDIF
29420          ELSE
29421 *   heavy fragments (here: fission products only)
29422             NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
29423             NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
29424             NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29425          ENDIF
29426       ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
29427          IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
29428       ENDIF
29429
29430       RETURN
29431 *------------------------------------------------------------------
29432 * output
29433     3 CONTINUE
29434
29435 **dble Po statistics.
29436 C     WRITE(LOUT,'(1X,A,2I7,2E12.4)')
29437 C    &   '# evts. / # dble-Po. evts / s_in / s_popo :',
29438 C    & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
29439
29440 *  emulsion treatment
29441       IF (NCOMPO.GT.0) THEN
29442          WRITE(LOUT,3000)
29443  3000    FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
29444      &          22X,'----------------------------',/,/,19X,
29445      &          'mass    charge          fraction',/,39X,
29446      &          'input     treated',/)
29447          DO 30 I=1,NCOMPO
29448             WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
29449      &                       EMUSAM(I)/DBLE(ICEVT)
29450  3013       FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
29451    30    CONTINUE
29452       ENDIF
29453
29454 *  i.n.c. statistics: output
29455       WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
29456  3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
29457      &       22X,'---------------------------------',/,/,1X,
29458      &       'no. of events for normalization: (accepted final events,',
29459      &       ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
29460      &       /,1X,'no. of rejected events due to intranuclear',
29461      &       ' cascade',15X,I6,/)
29462       ICEV  = MAX(ICEVT,1)
29463       ICEV1 = ICEV
29464       IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
29465       WRITE(LOUT,3002)
29466      &     (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
29467      &     ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
29468      &     KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
29469      &    (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29470      &     (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
29471      &     (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29472      &     (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
29473  3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
29474      &       5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
29475      &       ' proj./ target (mean per evt)',/,8X,'baryons:  pos. ',
29476      &       F7.3,' /',F7.3,'   neg. ',F7.3,' /',F7.3,/,8X,
29477      &       'mesons:   pos. ',F7.3,' /',F7.3,'   neg. ',F7.3,' /',F7.3,
29478      &       /,1X,'maximum no. of generations treated (maximum allowed:'
29479      &       ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
29480      &       ' interactions in proj./ target (mean per evt1)',
29481      &       F7.3,' /',F7.3,/,8X,'out of which by inelastic',
29482      &       ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
29483      &       'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
29484      &       '(ap, K-, pi- only)     ',F7.3,' /',F7.3,/)
29485       WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
29486      &                 IREXCI(1)+IREXCI(2)+IREXCI(3)
29487  3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
29488      &       'evaporation',/,22X,'-----------------------------',
29489      &       '------------',/,/,1X,'no. of events for normal.: ',
29490      &       '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
29491      &       ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
29492      &       ' rejected events     (',I4,',',I4,',',I4,')',22X,I6,/)
29493
29494       WRITE(LOUT,3004)
29495  3004 FORMAT(/,22X,'1) before evaporation-step:',/)
29496       ICEV  = MAX(NRESEV(2),1)
29497       WRITE(LOUT,3005)
29498      &     (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
29499      &     (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
29500      &     (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
29501      &     (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
29502      &     (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
29503      &     (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
29504      &     (EXCDPM(I)/DBLE(ICEV),I=1,2),
29505      &     (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
29506  3005    FORMAT(1X,'residual nuclei:  (mean values per evt)',12X,
29507      &       'proj. / target',/,/,8X,'total number of particles',15X,
29508      &       2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29509      &       'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
29510      &       'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
29511      &       /,8X,'excitation energy (bef. evap.-step)   ',2E11.3,/,
29512      &       8X,'excitation energy per nucleon         ',2E11.3,/,/)
29513
29514 * evaporation / fission / fragmentation statistics: output
29515       ICEV  = MAX(NRESEV(2),1)
29516       ICEV1 = MAX(NRESEV(4),1)
29517       NTEVA1 =
29518      &   NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
29519       NTEVA2 =
29520      &   NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
29521       IF (LEVPRT) THEN
29522          IF (IFISS.EQ.1) CMSG(1) = 'requested    '
29523          IF (LFRMBK)     CMSG(2) = 'requested    '
29524          IF (LDEEXG)     CMSG(3) = 'requested    '
29525          WRITE(LOUT,3006)
29526      &        CMSG,
29527      &        DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
29528      &        (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
29529      &        (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
29530      &        (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
29531      &        (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
29532      &        (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
29533      &        (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
29534      &        (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
29535      &        (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
29536  3006    FORMAT(22X,'2) after  evaporation-step:',/,/,1X,'Fission:',
29537      &       13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
29538      &       'deexcitation:',2X,A13,/,/,
29539      &       1X,'evaporation/deexcitation:  (mean values per evt1)  ',
29540      &       'proj. / target',/,/,8X,'total number of evap. particles',
29541      &       9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29542      &       'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
29543      &       '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
29544      &       2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
29545      &       'heavy fragments',25X,2F9.3,/)
29546          IF (IFISS.EQ.1) THEN
29547             WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
29548      &                       NEVAFI(2,1),NEVAFI(2,2),
29549      &             DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
29550      &             DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
29551  3007       FORMAT(1X,'Fission:   total number of events',14X,2I9,/
29552      &             12X,'out of which fission occured',8X,2I9,/,
29553      &             50X,'(',F5.2,'%) (',F5.2,'%)',/)
29554          ENDIF
29555 C        IF ((LFRMBK).OR.(IFISS.EQ.1)) THEN
29556 C           WRITE(LOUT,3008)
29557 C3008       FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
29558 C    &             '       proj.   / target',/)
29559 C           DO 31 I=1,210
29560 C              IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
29561 C                 WRITE(LOUT,3009) I,
29562 C    &            (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29563 C3009             FORMAT(38X,I3,3X,2E12.3)
29564 C              ENDIF
29565 C  31       CONTINUE
29566 C           WRITE(LOUT,3010)
29567 C3010       FORMAT(1X,'heavy fragments - statistics:',7X,'mass  ',
29568 C    &             '       proj.   / target',/)
29569 C           DO 32 I=1,210
29570 C              IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
29571 C                 WRITE(LOUT,3011) I,
29572 C    &            (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29573 C3011             FORMAT(38X,I3,3X,2E12.3)
29574 C              ENDIF
29575 C  32       CONTINUE
29576 C           WRITE(LOUT,*)
29577 C        ENDIF
29578       ELSE
29579          WRITE(LOUT,3012)
29580  3012    FORMAT(22X,'2) after  evaporation-step:',/,/,1X,
29581      &       'Evaporation:         not requested',/)
29582       ENDIF
29583
29584       RETURN
29585 *------------------------------------------------------------------
29586 * filling of histogram with event-record
29587     4 CONTINUE
29588 *  emulsion treatment
29589       IF (NCOMPO.GT.0) THEN
29590          DO 40 I=1,NCOMPO
29591             IF (IT.EQ.IEMUMA(I)) THEN
29592                EMUSAM(I) = EMUSAM(I)+ONE
29593             ENDIF
29594    40    CONTINUE
29595       ENDIF
29596       NINCGE = NINCGE+MAXGEN
29597       MAXGEN = 0
29598 **dble Po statistics.
29599       IF (IPOPO.EQ.1) KPOPO = KPOPO+1
29600
29601       RETURN
29602 *------------------------------------------------------------------
29603 * filling of histogram with event-record
29604     5 CONTINUE
29605       IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
29606          IB = IIBAR(IDBAM(IDX))
29607          IC = IICH(IDBAM(IDX))
29608          J  = ISTHKK(IDX)-14
29609          IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
29610             NINCST(J,1) = NINCST(J,1)+1
29611          ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
29612             NINCST(J,2) = NINCST(J,2)+1
29613          ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
29614             NINCST(J,3) = NINCST(J,3)+1
29615          ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
29616             NINCST(J,4) = NINCST(J,4)+1
29617          ENDIF
29618       ELSEIF (ISTHKK(IDX).EQ.17) THEN
29619          NINCWO(1) = NINCWO(1)+1
29620       ELSEIF (ISTHKK(IDX).EQ.18) THEN
29621          NINCWO(2) = NINCWO(2)+1
29622       ELSEIF (ISTHKK(IDX).EQ.1001) THEN
29623          IB = IDRES(IDX)
29624          IC = IDXRES(IDX)
29625          IF (IC.GT.0) THEN
29626             NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
29627             NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
29628          ENDIF
29629          NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29630       ENDIF
29631
29632       RETURN
29633       END
29634
29635 *$ CREATE DT_NEWHGR.FOR
29636 *COPY DT_NEWHGR
29637 *
29638 *===newhgr=============================================================*
29639 *
29640       SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
29641
29642 ************************************************************************
29643 *                                                                      *
29644 *     Histogram initialization.                                        *
29645 *                                                                      *
29646 *     input:  XLIM1/XLIM2  lower/upper edge of histogram-window        *
29647 *             XLIM3        bin size                                    *
29648 *             IBIN    > 0  number of bins in equidistant lin. binning  *
29649 *                     = -1 reset histograms                            *
29650 *                     < -1 |IBIN| number of bins in equidistant log.   *
29651 *                          binning or log. binning in user def. struc. *
29652 *             XLIMB(*)     user defined bin structure                  *
29653 *                                                                      *
29654 *     The bin structure is sensitive to                                *
29655 *             XLIM1, XLIM3, IBIN     if     XLIM3 > 0   (lin.)         *
29656 *             XLIM1, XLIM2, IBIN     if     XLIM3 = 0   (lin. & log.)  *
29657 *             XLIMB, IBIN            if     XLIM3 < 0                  *
29658 *                                                                      *
29659 *                                                                      *
29660 *     output: IREFN        histogram index                             *
29661 *                          (= -1 for inconsistent histogr. request)    *
29662 *                                                                      *
29663 * This subroutine is based on a original version by R. Engel.          *
29664 * This version dated 22.4.95 is written  by S. Roesler.                *
29665 ************************************************************************
29666
29667       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29668       SAVE
29669       PARAMETER ( LINP = 10 ,
29670      &            LOUT = 6 ,
29671      &            LDAT = 9 )
29672
29673       LOGICAL LSTART
29674
29675       PARAMETER (ZERO   =  0.0D0,
29676      &           TINY   =  1.0D-10)
29677
29678       DIMENSION XLIMB(*)
29679
29680 * histograms
29681       PARAMETER (NHIS=150, NDIM=250)
29682       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29683      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29684 * auxiliary common for histograms
29685       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29686
29687       DATA LSTART /.TRUE./
29688
29689 * reset histogram counter
29690       IF (LSTART.OR.(IBIN.EQ.-1)) THEN
29691          IHISL  = 0
29692          IF (IBIN.EQ.-1) RETURN
29693          LSTART = .FALSE.
29694       ENDIF
29695
29696       IHIS  = IHISL+1
29697 * check for maximum number of allowed histograms
29698       IF (IHIS.GT.NHIS) THEN
29699          WRITE(LOUT,1003) IHIS,NHIS,IHIS
29700  1003    FORMAT(1X,'NEWHGR:   warning!  number of histograms (',
29701      &          I4,') exceeds array size (',I4,')',/,21X,
29702      &          'histogram',I3,' skipped!')
29703          GOTO 9999
29704       ENDIF
29705
29706       IREFN = IHIS
29707       IBINS(IHIS) = ABS(IBIN)
29708 * check requested number of bins
29709       IF (IBINS(IHIS).GE.NDIM) THEN
29710          WRITE(LOUT,1000) IBIN,NDIM,NDIM
29711  1000    FORMAT(1X,'NEWHGR:   warning!  number of bins (',
29712      &          I3,') exceeds array size (',I3,')',/,21X,
29713      &          'and will be reset to ',I3)
29714          IBINS(IHIS) = NDIM
29715       ENDIF
29716       IF (IBINS(IHIS).EQ.0) THEN
29717          WRITE(LOUT,1001) IBIN,IHIS
29718  1001    FORMAT(1X,'NEWHGR:   warning!  inconsistent number of',
29719      &          ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
29720          GOTO 9999
29721       ENDIF
29722
29723 * initialize arrays
29724       DO 1 I=1,NDIM
29725          DO 2 K=1,3
29726             HIST(K,IHIS,I)   = ZERO
29727             HIST(K+3,IHIS,I) = ZERO
29728             TMPHIS(K,IHIS,I) = ZERO
29729     2    CONTINUE
29730          HIST(7,IHIS,I)   = ZERO
29731     1 CONTINUE
29732       DENTRY(1,IHIS)= ZERO
29733       DENTRY(2,IHIS)= ZERO
29734       OVERF(IHIS)   = ZERO
29735       UNDERF(IHIS)  = ZERO
29736       TMPUFL(IHIS)  = ZERO
29737       TMPOFL(IHIS)  = ZERO
29738
29739 * bin str. sensitive to lower edge, bin size, and numb. of bins
29740       IF (XLIM3.GT.ZERO) THEN
29741          DO 3 K=1,IBINS(IHIS)+1
29742             HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
29743     3    CONTINUE
29744          ISWI(IHIS) = 1
29745 * bin str. sensitive to lower/upper edge and numb. of bins
29746       ELSEIF (XLIM3.EQ.ZERO) THEN
29747 *   linear binning
29748          IF (IBIN.GT.0) THEN
29749             XLOW = XLIM1
29750             XHI  = XLIM2
29751             IF (XLIM2.LE.XLIM1) THEN
29752                WRITE(LOUT,1002) XLIM1,XLIM2
29753  1002          FORMAT(1X,'NEWHGR:   warning!  inconsistent x-range',
29754      &                /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29755                GOTO 9999
29756             ENDIF
29757             ISWI(IHIS) = 1
29758          ELSEIF (IBIN.LT.-1) THEN
29759 *   logarithmic binning
29760             IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
29761                WRITE(LOUT,1004) XLIM1,XLIM2
29762  1004          FORMAT(1X,'NEWHGR:   warning!  inconsistent log. ',
29763      &                'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29764                GOTO 9999
29765             ENDIF
29766             IF (XLIM2.LE.XLIM1) THEN
29767                WRITE(LOUT,1005) XLIM1,XLIM2
29768  1005          FORMAT(1X,'NEWHGR:   warning!  inconsistent x-range',
29769      &                /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29770                GOTO 9999
29771             ENDIF
29772             XLOW = LOG10(XLIM1)
29773             XHI  = LOG10(XLIM2)
29774             ISWI(IHIS) = 3
29775          ENDIF
29776          DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
29777          DO 4 K=1,IBINS(IHIS)+1
29778             HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
29779     4    CONTINUE
29780       ELSE
29781 * user defined bin structure
29782          DO 5 K=1,IBINS(IHIS)+1
29783             IF (IBIN.GT.0) THEN
29784                HIST(1,IHIS,K) = XLIMB(K)
29785                ISWI(IHIS) = 2
29786             ELSEIF (IBIN.LT.-1) THEN
29787                HIST(1,IHIS,K) = LOG10(XLIMB(K))
29788                ISWI(IHIS) = 4
29789             ENDIF
29790     5    CONTINUE
29791       ENDIF
29792
29793 * histogram accepted
29794       IHISL = IHIS
29795
29796       RETURN
29797
29798  9999 CONTINUE
29799       IREFN = -1
29800       RETURN
29801       END
29802
29803 *$ CREATE DT_FILHGR.FOR
29804 *COPY DT_FILHGR
29805 *
29806 *===filhgr=============================================================*
29807 *
29808       SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
29809
29810 ************************************************************************
29811 *                                                                      *
29812 *     Scoring for histogram IHIS.                                      *
29813 *                                                                      *
29814 * This subroutine is based on a original version by R. Engel.          *
29815 * This version dated 23.4.95 is written  by S. Roesler.                *
29816 ************************************************************************
29817
29818       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29819       SAVE
29820       PARAMETER ( LINP = 10 ,
29821      &            LOUT = 6 ,
29822      &            LDAT = 9 )
29823
29824       PARAMETER (ZERO = 0.0D0,
29825      &           ONE  = 1.0D0,
29826      &           TINY = 1.0D-10)
29827
29828 * histograms
29829       PARAMETER (NHIS=150, NDIM=250)
29830       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29831      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29832 * auxiliary common for histograms
29833       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29834
29835       DATA NCEVT /1/
29836
29837       X = XI
29838       Y = YI
29839
29840 * dump content of temorary arrays into histograms
29841       IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
29842          CALL DT_EVTHIS(IDUM)
29843          NCEVT = NEVT
29844       ENDIF
29845
29846 * check histogram index
29847       IF (IHIS.EQ.-1) RETURN
29848       IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
29849 C        WRITE(LOUT,1000) IHIS,IHISL
29850  1000    FORMAT(1X,'FILHGR:   warning!  histogram index',I4,
29851      &          ' out of range (1..',I3,')')
29852          RETURN
29853       ENDIF
29854
29855       IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
29856 * bin structure not explicitly given
29857          IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
29858          DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
29859          IF (X.LT.HIST(1,IHIS,1)) THEN
29860             I1 = 0
29861          ELSE
29862             I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
29863          ENDIF
29864
29865       ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
29866 * user defined bin structure
29867          IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
29868          IF (X.LT.HIST(1,IHIS,1)) THEN
29869             I1 = 0
29870          ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
29871             I1 = IBINS(IHIS)+1
29872          ELSE
29873 *   binary sort algorithm
29874             KMIN = 0
29875             KMAX = IBINS(IHIS)+1
29876     1       CONTINUE
29877             IF ((KMAX-KMIN).EQ.1) GOTO 2
29878             KK = (KMAX+KMIN)/2
29879             IF (X.LE.HIST(1,IHIS,KK)) THEN
29880                KMAX=KK
29881             ELSE
29882                KMIN=KK
29883             ENDIF
29884             GOTO 1
29885     2       CONTINUE
29886             I1 = KMIN
29887          ENDIF
29888
29889       ELSE
29890          WRITE(LOUT,1001)
29891  1001    FORMAT(1X,'FILHGR:   warning!  histogram not initialized')
29892          RETURN
29893       ENDIF
29894
29895 * scoring
29896       IF (I1.LE.0) THEN
29897          TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
29898       ELSEIF (I1.LE.IBINS(IHIS)) THEN
29899          TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
29900          IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
29901             TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
29902          ELSE
29903             TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
29904          ENDIF
29905          TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
29906       ELSE
29907          TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
29908       ENDIF
29909
29910       RETURN
29911       END
29912
29913 *$ CREATE DT_EVTHIS.FOR
29914 *COPY DT_EVTHIS
29915 *
29916 *===evthis=============================================================*
29917 *
29918       SUBROUTINE DT_EVTHIS(NEVT)
29919
29920 ************************************************************************
29921 * Dump content of temorary histograms into /DTHIS1/. This subroutine   *
29922 * is called after each event and for the last event before any call    *
29923 * to OUTHGR.                                                           *
29924 *         NEVT   number of events dumped, this is only needed to       *
29925 *                get the normalization after the last event            *
29926 * This version dated 23.4.95 is written  by S. Roesler.                *
29927 ************************************************************************
29928
29929       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29930       SAVE
29931       PARAMETER ( LINP = 10 ,
29932      &            LOUT = 6 ,
29933      &            LDAT = 9 )
29934
29935       LOGICAL LNOETY
29936
29937       PARAMETER (ZERO = 0.0D0,
29938      &           ONE  = 1.0D0,
29939      &           TINY = 1.0D-10)
29940
29941 * histograms
29942       PARAMETER (NHIS=150, NDIM=250)
29943       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29944      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29945 * auxiliary common for histograms
29946       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29947
29948       DATA NCEVT /0/
29949
29950       NCEVT = NCEVT+1
29951       NEVT  = NCEVT
29952
29953       DO 1 I=1,IHISL
29954          LNOETY = .TRUE.
29955          DO 2 J=1,IBINS(I)
29956             IF (TMPHIS(1,I,J).GT.ZERO) THEN
29957                LNOETY = .FALSE.
29958                HIST(2,I,J)   = HIST(2,I,J)+ONE
29959                HIST(7,I,J)   = HIST(7,I,J)+TMPHIS(1,I,J)
29960                DENTRY(2,I)   = DENTRY(2,I)+TMPHIS(1,I,J)
29961                AVX           = TMPHIS(2,I,J)/TMPHIS(1,I,J)
29962                HIST(3,I,J)   = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
29963                HIST(4,I,J)   = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
29964                HIST(5,I,J)   = HIST(5,I,J)+TMPHIS(3,I,J)
29965                HIST(6,I,J)   = HIST(6,I,J)+TMPHIS(3,I,J)**2
29966                TMPHIS(1,I,J) = ZERO
29967                TMPHIS(2,I,J) = ZERO
29968                TMPHIS(3,I,J) = ZERO
29969             ENDIF
29970     2    CONTINUE
29971          IF (LNOETY) THEN
29972             IF (TMPUFL(I).GT.ZERO) THEN
29973                UNDERF(I) = UNDERF(I)+ONE
29974                TMPUFL(I) = ZERO
29975             ELSEIF (TMPOFL(I).GT.ZERO) THEN
29976                OVERF(I)  = OVERF(I)+ONE
29977                TMPOFL(I) = ZERO
29978             ENDIF
29979          ELSE
29980             DENTRY(1,I) = DENTRY(1,I)+ONE
29981          ENDIF
29982     1 CONTINUE
29983
29984       RETURN
29985       END
29986
29987 *$ CREATE DT_OUTHGR.FOR
29988 *COPY DT_OUTHGR
29989 *
29990 *===outhgr=============================================================*
29991 *
29992       SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
29993      &                  ILOGY,INORM,NMODE)
29994
29995 ************************************************************************
29996 *                                                                      *
29997 *     Plot histogram(s) to standard output unit                        *
29998 *                                                                      *
29999 *         I1..6         indices of histograms to be plotted            *
30000 *         CHEAD,IHEAD   header string,integer                          *
30001 *         NEVTS         number of events                               *
30002 *         FAC           scaling factor                                 *
30003 *         ILOGY   = 1   logarithmic y-axis                             *
30004 *         INORM         normalization                                  *
30005 *                 = 0   no further normalization (FAC is obsolete)     *
30006 *                 = 1   per event and bin width                        *
30007 *                 = 2   per entry and bin width                        *
30008 *                 = 3   per bin entry                                  *
30009 *                 = 4   per event and "bin width" x1^2...x2^2          *
30010 *                 = 5   per event and "log. bin width" ln x1..ln x2    *
30011 *                 = 6   per event                                      *
30012 *         MODE    = 0   no output but normalization applied            *
30013 *                 = 1   all valid histograms separately (small frame)  *
30014 *                       all valid histograms separately (small frame)  *
30015 *                 = -1  and tables as histograms                       *
30016 *                 = 2   all valid histograms (one plot, wide frame)    *
30017 *                       all valid histograms (one plot, wide frame)    *
30018 *                 = -2  and tables as histograms                       *
30019 *                                                                      *
30020 *                                                                      *
30021 *     Note: All histograms to be plotted with one call to this         *
30022 *           subroutine and |MODE|=2 must have the same bin structure!  *
30023 *           There is no test included ensuring this fact.              *
30024 *                                                                      *
30025 * This version dated 23.4.95 is written  by S. Roesler.                *
30026 ************************************************************************
30027
30028       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30029       SAVE
30030       PARAMETER ( LINP = 10 ,
30031      &            LOUT = 6 ,
30032      &            LDAT = 9 )
30033
30034       CHARACTER*72 CHEAD
30035
30036       PARAMETER (ZERO   =  0.0D0,
30037      &           IZERO  =  0,
30038      &           ONE    =  1.0D0,
30039      &           TWO    =  2.0D0,
30040      &           OHALF  =  0.5D0,
30041      &           EPS    =  1.0D-5,
30042      &           TINY   =  1.0D-8,
30043      &           SMALL  =  -1.0D8,
30044      &           RLARGE =  1.0D8 )
30045
30046 * histograms
30047       PARAMETER (NHIS=150, NDIM=250)
30048       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30049      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30050
30051       PARAMETER (NDIM2 = 2*NDIM)
30052       DIMENSION XX(NDIM2),YY(NDIM2)
30053
30054       PARAMETER (NHISTO = 6)
30055       DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
30056      &          IDX(NHISTO)
30057
30058       CHARACTER*43 CNORM(0:8)
30059       DATA CNORM /'no further normalization                   ',
30060      &            'per event and bin width                    ',
30061      &            'per entry1 and bin width                   ',
30062      &            'per bin entry                              ',
30063      &            'per event and "bin width" x1^2...x2^2      ',
30064      &            'per event and "log. bin width" ln x1..ln x2',
30065      &            'per event                                  ',
30066      &            'per bin entry1                             ',
30067      &            'per entry2 and bin width                   '/
30068
30069       IDX1(1) = I1
30070       IDX1(2) = I2
30071       IDX1(3) = I3
30072       IDX1(4) = I4
30073       IDX1(5) = I5
30074       IDX1(6) = I6
30075
30076       MODE = NMODE
30077
30078 * initialization if "wide frame" is requested
30079       IF (ABS(MODE).EQ.2) THEN
30080          DO 1 I=1,NHISTO
30081             DO 2 J=1,NDIM
30082                XX1(J,I) = ZERO
30083                YY1(J,I) = ZERO
30084     2       CONTINUE
30085     1    CONTINUE
30086       ENDIF
30087
30088 * plot header
30089       WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
30090
30091 * check histogram indices
30092       NHI = 0
30093       DO 3 I=1,NHISTO
30094          IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
30095             IF (ISWI(IDX1(I)).NE.0) THEN
30096                IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
30097                   WRITE(LOUT,1000)
30098      &                 IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
30099  1000             FORMAT(/,1X,'OUTHGR:   warning!  no entries in',
30100      &                   ' histogram ',I3,/,21X,'underflows:',F10.0,
30101      &                   '   overflows:  ',F10.0)
30102                ELSE
30103                   NHI = NHI+1
30104                   IDX(NHI) = IDX1(I)
30105                ENDIF
30106             ENDIF
30107          ENDIF
30108     3 CONTINUE
30109       IF (NHI.EQ.0) THEN
30110          WRITE(LOUT,1001)
30111  1001    FORMAT(/,1X,'OUTHGR:   warning!  histogram indices not valid')
30112          RETURN
30113       ENDIF
30114
30115 * check normalization request
30116       IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
30117      &     ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
30118      &                        (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
30119      &     (INORM.LT.0).OR.(INORM.GT.8) ) THEN
30120          WRITE(LOUT,1002) NEVTS,INORM,FAC
30121  1002    FORMAT(/,1X,'OUTHGR:   warning!  normalization request not ',
30122      &          'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
30123      &          'FAC = ',E11.4)
30124          RETURN
30125       ENDIF
30126
30127       WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
30128
30129 * apply normalization
30130       DO 4 N=1,NHI
30131
30132          I = IDX(N)
30133
30134          IF (ISWI(I).EQ.1) THEN
30135             WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30136  1003       FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
30137      &             ' to',2X,E10.4,',',2X,I3,' bins')
30138          ELSEIF (ISWI(I).EQ.2) THEN
30139             WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30140             WRITE(LOUT,1007)
30141  1007       FORMAT(1X,'user defined bin structure')
30142          ELSEIF (ISWI(I).EQ.3) THEN
30143             WRITE(LOUT,1004)
30144      &         I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30145  1004       FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
30146      &             ' to',2X,E10.4,',',2X,I3,' bins')
30147          ELSEIF (ISWI(I).EQ.4) THEN
30148             WRITE(LOUT,1004)
30149      &         I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30150             WRITE(LOUT,1007)
30151          ELSE
30152             WRITE(LOUT,1008) ISWI(I)
30153  1008       FORMAT(/,1X,'warning!  inconsistent bin structure flag ',I4)
30154          ENDIF
30155          WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
30156  1005    FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
30157      &          ' overfl.:',F8.0)
30158          WRITE(LOUT,1009) CNORM(INORM)
30159  1009    FORMAT(1X,'normalization: ',A,/)
30160
30161          DO 5 K=1,IBINS(I)
30162             CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
30163             YMEAN = FAC*YMEAN
30164             YERR  = FAC*YERR
30165             WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
30166             WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
30167  1006       FORMAT(1X,5E11.3)
30168 *    small frame
30169             II = 2*K
30170             XX(II-1) = HIST(1,I,K)
30171             XX(II)   = HIST(1,I,K+1)
30172             YY(II-1) = YMEAN
30173             YY(II)   = YMEAN
30174 *    wide frame
30175             XX1(K,N) = XMEAN
30176             IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
30177      &         XX1(K,N) = LOG10(XMEAN)
30178             YY1(K,N) = YMEAN
30179     5    CONTINUE
30180
30181 * plot small frame
30182          IF (ABS(MODE).EQ.1) THEN
30183             IBIN2 = 2*IBINS(I)
30184             WRITE(LOUT,'(/,1X,A)') 'Preview:'
30185             IF(ILOGY.EQ.1) THEN
30186               CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30187             ELSE
30188               CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30189             ENDIF
30190          ENDIF
30191
30192     4 CONTINUE
30193
30194 * plot wide frame
30195       IF (ABS(MODE).EQ.2) THEN
30196          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30197          NSIZE = NDIM*NHISTO
30198          DXLOW = HIST(1,IDX(1),1)
30199          DDX   = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
30200          YLOW  = RLARGE
30201          YHI   = SMALL
30202          DO 6 I=1,NHISTO
30203             DO 7 J=1,NDIM
30204                IF (YY1(J,I).LT.YLOW) THEN
30205                   IF (ILOGY.EQ.1) THEN
30206                      IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
30207                   ELSE
30208                      YLOW = YY1(J,I)
30209                   ENDIF
30210                ENDIF
30211                IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
30212     7       CONTINUE
30213     6    CONTINUE
30214          DY = (YHI-YLOW)/DBLE(NDIM)
30215          IF (DY.LE.ZERO) THEN
30216             WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
30217      &         'OUTHGR:   warning! zero bin width for histograms ',
30218      &         IDX,': ',YLOW,YHI
30219             RETURN
30220          ENDIF
30221          IF (ILOGY.EQ.1) THEN
30222             YLOW = LOG10(YLOW)
30223             DY   = (LOG10(YHI)-YLOW)/100.0D0
30224             DO 8 I=1,NHISTO
30225                DO 9 J=1,NDIM
30226                   IF (YY1(J,I).LE.ZERO) THEN
30227                      YY1(J,I) = YLOW
30228                   ELSE
30229                      YY1(J,I) = LOG10(YY1(J,I))
30230                   ENDIF
30231     9          CONTINUE
30232     8       CONTINUE
30233          ENDIF
30234          CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
30235       ENDIF
30236
30237       RETURN
30238       END
30239
30240 *$ CREATE DT_GETBIN.FOR
30241 *COPY DT_GETBIN
30242 *
30243 *===getbin=============================================================*
30244 *
30245       SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
30246      &                  XMEAN,YMEAN,YERR)
30247
30248 ************************************************************************
30249 * This version dated 23.4.95 is written  by S. Roesler.                *
30250 ************************************************************************
30251
30252       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30253       SAVE
30254       PARAMETER ( LINP = 10 ,
30255      &            LOUT = 6 ,
30256      &            LDAT = 9 )
30257
30258       PARAMETER (ZERO   = 0.0D0,
30259      &           ONE    = 1.0D0,
30260      &           TINY35 = 1.0D-35)
30261
30262 * histograms
30263       PARAMETER (NHIS=150, NDIM=250)
30264       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30265      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30266
30267       XLOW = HIST(1,IHIS,IBIN)
30268       XHI  = HIST(1,IHIS,IBIN+1)
30269       IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
30270          XLOW = 10**XLOW
30271          XHI  = 10**XHI
30272       ENDIF
30273       IF (NORM.EQ.2) THEN
30274          DX   = XHI-XLOW
30275          NEVT = INT(DENTRY(1,IHIS))
30276       ELSEIF (NORM.EQ.3) THEN
30277          DX   = ONE
30278          NEVT = INT(HIST(2,IHIS,IBIN))
30279       ELSEIF (NORM.EQ.4) THEN
30280          DX   = XHI**2-XLOW**2
30281          NEVT = KEVT
30282       ELSEIF (NORM.EQ.5) THEN
30283          DX   = LOG(ABS(XHI))-LOG(ABS(XLOW))
30284          NEVT = KEVT
30285       ELSEIF (NORM.EQ.6) THEN
30286          DX   = ONE
30287          NEVT = KEVT
30288       ELSEIF (NORM.EQ.7) THEN
30289          DX   = ONE
30290          NEVT = INT(HIST(7,IHIS,IBIN))
30291       ELSEIF (NORM.EQ.8) THEN
30292          DX   = XHI-XLOW
30293          NEVT = INT(DENTRY(2,IHIS))
30294       ELSE
30295          DX   = ABS(XHI-XLOW)
30296          NEVT = KEVT
30297       ENDIF
30298       IF (ABS(DX).LT.TINY35) DX = ONE
30299       NEVT   = MAX(NEVT,1)
30300       YMEAN  = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
30301       YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
30302       YERR   = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
30303       YSUM   = HIST(5,IHIS,IBIN)
30304       IF (ABS(YSUM).LT.TINY35) YSUM = ONE
30305 C     XMEAN  = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
30306       XMEAN  = HIST(3,IHIS,IBIN)/YSUM
30307       IF (XMEAN.EQ.ZERO) XMEAN = XLOW
30308
30309       RETURN
30310       END
30311
30312 *$ CREATE DT_JOIHIS.FOR
30313 *COPY DT_JOIHIS
30314 *
30315 *===joihis=============================================================*
30316 *
30317       SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
30318
30319 ************************************************************************
30320 *                                                                      *
30321 *     Operation on histograms.                                         *
30322 *                                                                      *
30323 *     input:  IH1,IH2      histogram indices to be joined              *
30324 *             COPER        character defining the requested operation, *
30325 *                          i.e. '+', '-', '*', '/'                     *
30326 *             FAC1,FAC2    factors for joining, i.e.                   *
30327 *                          FAC1*histo1 COPER FAC2*histo2               *
30328 *                                                                      *
30329 * This version dated 23.4.95 is written  by S. Roesler.                *
30330 ************************************************************************
30331
30332       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30333       SAVE
30334       PARAMETER ( LINP = 10 ,
30335      &            LOUT = 6 ,
30336      &            LDAT = 9 )
30337
30338       CHARACTER COPER*1
30339
30340       PARAMETER (ZERO   =  0.0D0,
30341      &           ONE    =  1.0D0,
30342      &           OHALF  =  0.5D0,
30343      &           TINY8  =  1.0D-8,
30344      &           SMALL  =  -1.0D8,
30345      &           RLARGE =  1.0D8 )
30346
30347 * histograms
30348       PARAMETER (NHIS=150, NDIM=250)
30349       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30350      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30351
30352       PARAMETER (NDIM2 = 2*NDIM)
30353       DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
30354
30355       CHARACTER*43 CNORM(0:6)
30356       DATA CNORM /'no further normalization                   ',
30357      &            'per event and bin width                    ',
30358      &            'per entry and bin width                    ',
30359      &            'per bin entry                              ',
30360      &            'per event and "bin width" x1^2...x2^2      ',
30361      &            'per event and "log. bin width" ln x1..ln x2',
30362      &            'per event                                  '/
30363
30364 * check histogram indices
30365       IF ((IH1.LT.    1).OR.(IH2.LT.    1).OR.
30366      &    (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
30367          WRITE(LOUT,1000) IH1,IH2,IHISL
30368  1000    FORMAT(1X,'JOIHIS:   warning!  inconsistent histogram ',
30369      &          'indices (',I3,',',I3,'),',/,21X,'valid range:  1,',I3)
30370          GOTO 9999
30371       ENDIF
30372
30373 * check bin structure of histograms to be joined
30374       IF (IBINS(IH1).NE.IBINS(IH2)) THEN
30375          WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
30376  1001    FORMAT(1X,'JOIHIS:   warning!  joining histograms ',I3,
30377      &          ' and ',I3,' failed',/,21X,
30378      &          'due to different numbers of bins (',I3,',',I3,')')
30379          GOTO 9999
30380       ENDIF
30381       DO 1 K=1,IBINS(IH1)+1
30382          IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
30383             WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
30384  1002       FORMAT(1X,'JOIHIS:   warning!  joining histograms ',I3,
30385      &             ' and ',I3,' failed at bin edge ',I3,/,21X,
30386      &             'X1,X2 = ',2E11.4)
30387             GOTO 9999
30388          ENDIF
30389     1 CONTINUE
30390
30391       WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
30392  1003 FORMAT(1X,'JOIHIS:   joining histograms ',I3,',',I3,' with ',
30393      &       'operation ',A,/,11X,'and factors ',2E11.4)
30394       WRITE(LOUT,1004) CNORM(NORM)
30395  1004 FORMAT(1X,'normalization: ',A,/)
30396
30397       DO 2 K=1,IBINS(IH1)
30398          CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
30399          CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
30400          XLOW  = XLOW1
30401          XHI   = XHI1
30402          XMEAN = OHALF*(XMEAN1+XMEAN2)
30403          IF (COPER.EQ.'+') THEN
30404             YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
30405          ELSEIF (COPER.EQ.'*') THEN
30406             YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
30407          ELSEIF (COPER.EQ.'/') THEN
30408             IF (YMEAN2.EQ.ZERO) THEN
30409                YMEAN = ZERO
30410             ELSE
30411                IF (FAC2.EQ.ZERO) FAC2 = ONE
30412                YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
30413             ENDIF
30414          ELSE
30415             GOTO 9998
30416          ENDIF
30417          WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30418          WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30419  1006    FORMAT(1X,5E11.3)
30420 *    small frame
30421          II = 2*K
30422          XX(II-1) = HIST(1,IH1,K)
30423          XX(II)   = HIST(1,IH1,K+1)
30424          YY(II-1) = YMEAN
30425          YY(II)   = YMEAN
30426 *    wide frame
30427          XX1(K) = XMEAN
30428          IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
30429          YY1(K) = YMEAN
30430     2 CONTINUE
30431
30432 * plot small frame
30433       IF (ABS(MODE).EQ.1) THEN
30434          IBIN2 = 2*IBINS(IH1)
30435          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30436          IF(ILOGY.EQ.1) THEN
30437            CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30438          ELSE
30439            CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30440          ENDIF
30441       ENDIF
30442
30443 * plot wide frame
30444       IF (ABS(MODE).EQ.2) THEN
30445          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30446          NSIZE = NDIM
30447          DXLOW = HIST(1,IH1,1)
30448          DDX   = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
30449          YLOW  = RLARGE
30450          YHI   = SMALL
30451          DO 3 I=1,NDIM
30452             IF (YY1(I).LT.YLOW) THEN
30453                IF (ILOGY.EQ.1) THEN
30454                   IF (YY1(I).GT.ZERO) YLOW = YY1(I)
30455                ELSE
30456                   YLOW = YY1(I)
30457                ENDIF
30458             ENDIF
30459             IF (YY1(I).GT.YHI) YHI = YY1(I)
30460     3    CONTINUE
30461          DY = (YHI-YLOW)/DBLE(NDIM)
30462          IF (DY.LE.ZERO) THEN
30463             WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
30464      &         'JOIHIS:   warning! zero bin width for histograms ',
30465      &         IH1,IH2,': ',YLOW,YHI
30466             RETURN
30467          ENDIF
30468          IF (ILOGY.EQ.1) THEN
30469             YLOW = LOG10(YLOW)
30470             DY   = (LOG10(YHI)-YLOW)/100.0D0
30471             DO 4 I=1,NDIM
30472                IF (YY1(I).LE.ZERO) THEN
30473                   YY1(I) = YLOW
30474                ELSE
30475                   YY1(I) = LOG10(YY1(I))
30476                ENDIF
30477     4       CONTINUE
30478          ENDIF
30479          CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
30480       ENDIF
30481
30482       RETURN
30483
30484  9998 CONTINUE
30485       WRITE(LOUT,1005) COPER
30486  1005 FORMAT(1X,'JOIHIS:   unknown operation ',A)
30487
30488  9999 CONTINUE
30489       RETURN
30490       END
30491
30492 *$ CREATE DT_XGRAPH.FOR
30493 *COPY DT_XGRAPH
30494 *
30495 *===qgraph=============================================================*
30496 *
30497       SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
30498 C***********************************************************************
30499 C
30500 C     calculate quasi graphic picture with 25 lines and 79 columns
30501 C     ranges will be chosen automatically
30502 C
30503 C     input     N          dimension of input fields
30504 C               IARG       number of curves (fields) to plot
30505 C               X          field of X
30506 C               Y1         field of Y1
30507 C               Y2         field of Y2
30508 C
30509 C This subroutine is written by R. Engel.
30510 C***********************************************************************
30511       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30512       SAVE
30513
30514       PARAMETER ( LINP = 10 ,
30515      &            LOUT = 6 ,
30516      &            LDAT = 9 )
30517 C
30518       DIMENSION X(N),Y1(N),Y2(N)
30519       PARAMETER (EPS=1.D-30)
30520       PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30521       CHARACTER SYMB(5)
30522       CHARACTER COL(0:149,0:49)
30523 C
30524       DATA SYMB /'0','e','z','#','x'/
30525 C
30526       ISPALT=IBREIT-10
30527 C
30528 C***  automatic range fitting
30529 C
30530       XMAX=X(1)
30531       XMIN=X(1)
30532       DO 600 I=1,N
30533          XMAX=MAX(X(I),XMAX)
30534          XMIN=MIN(X(I),XMIN)
30535  600  CONTINUE
30536       XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30537 C
30538       ITEST=0
30539       DO 1100 K=0,IZEIL-1
30540          ITEST=ITEST+1
30541          IF (ITEST.EQ.IYRAST) THEN
30542             DO 1010 L=1,ISPALT-1
30543                COL(L,K)='-'
30544 1010        CONTINUE
30545             COL(ISPALT,K)='+'
30546             ITEST=0
30547             DO 1020 L=0,ISPALT-1,IXRAST
30548                COL(L,K)='+'
30549 1020        CONTINUE
30550          ELSE
30551             DO 1030 L=1,ISPALT-1
30552                COL(L,K)=' '
30553 1030        CONTINUE
30554             DO 1040 L=0,ISPALT-1,IXRAST
30555                COL(L,K)='|'
30556 1040        CONTINUE
30557             COL(ISPALT,K)='|'
30558          ENDIF
30559 1100  CONTINUE
30560 C
30561 C***  plot curve Y1
30562 C
30563       YMAX=Y1(1)
30564       YMIN=Y1(1)
30565       DO 500 I=1,N
30566          YMAX=MAX(Y1(I),YMAX)
30567          YMIN=MIN(Y1(I),YMIN)
30568 500   CONTINUE
30569       IF(IARG.GT.1) THEN
30570         DO 550 I=1,N
30571            YMAX=MAX(Y2(I),YMAX)
30572            YMIN=MIN(Y2(I),YMIN)
30573 550     CONTINUE
30574       ENDIF
30575       YMAX=(YMAX-YMIN)/40.0D0+YMAX
30576       YMIN=YMIN-(YMAX-YMIN)/40.0D0
30577       YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
30578       IF(YZOOM.LT.EPS) THEN
30579         WRITE(LOUT,'(1X,A)')
30580      &    'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30581         RETURN
30582       ENDIF
30583 C
30584 C***  plot curve Y1
30585 C
30586       ILAST=-1
30587       LLAST=-1
30588       DO 1200 K=1,N
30589          L=NINT((X(K)-XMIN)/XZOOM)
30590          I=NINT((YMAX-Y1(K))/YZOOM)
30591          IF(ILAST.GE.0) THEN
30592            LD = L-LLAST
30593            ID = I-ILAST
30594            DO 55 II=0,LD,SIGN(1,LD)
30595              DO 66 KK=0,ID,SIGN(1,ID)
30596                COL(II+LLAST,KK+ILAST)=SYMB(1)
30597  66          CONTINUE
30598  55        CONTINUE
30599          ELSE
30600            COL(L,I)=SYMB(1)
30601          ENDIF
30602          ILAST = I
30603          LLAST = L
30604 1200  CONTINUE
30605 C
30606       IF(IARG.GT.1) THEN
30607 C
30608 C***  plot curve Y2
30609 C
30610         DO 1250 K=1,N
30611            L=NINT((X(K)-XMIN)/XZOOM)
30612            I=NINT((YMAX-Y2(K))/YZOOM)
30613            COL(L,I)=SYMB(2)
30614 1250    CONTINUE
30615       ENDIF
30616 C
30617 C***  write it
30618 C
30619       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30620 C
30621 C***  write range of X
30622 C
30623       XZOOM = (XMAX-XMIN)/DBLE(7)
30624       WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30625 C
30626       DO 1300 K=0,IZEIL-1
30627          YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
30628          WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30629  110     FORMAT(1X,1PE9.2,70A1)
30630 1300  CONTINUE
30631 C
30632 C***  write range of X
30633 C
30634       XZOOM = (XMAX-XMIN)/DBLE(7)
30635       WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30636       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30637  120  FORMAT(6X,7(1PE10.3))
30638       END
30639
30640 *$ CREATE DT_XGLOGY.FOR
30641 *COPY DT_XGLOGY
30642 *
30643 *===qglogy=============================================================*
30644 *
30645       SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
30646 C***********************************************************************
30647 C
30648 C     calculate quasi graphic picture with 25 lines and 79 columns
30649 C     logarithmic y axis
30650 C     ranges will be chosen automatically
30651 C
30652 C     input     N          dimension of input fields
30653 C               IARG       number of curves (fields) to plot
30654 C               X          field of X
30655 C               Y1         field of Y1
30656 C               Y2         field of Y2
30657 C
30658 C This subroutine is written by R. Engel.
30659 C***********************************************************************
30660 C
30661       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30662       SAVE
30663
30664       PARAMETER ( LINP = 10 ,
30665      &            LOUT = 6 ,
30666      &            LDAT = 9 )
30667       DIMENSION X(N),Y1(N),Y2(N)
30668       PARAMETER (EPS=1.D-30)
30669       PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30670       CHARACTER SYMB(5)
30671       CHARACTER COL(0:149,0:49)
30672       PARAMETER (DEPS = 1.D-10)
30673 C
30674       DATA SYMB /'0','e','z','#','x'/
30675 C
30676       ISPALT=IBREIT-10
30677 C
30678 C***  automatic range fitting
30679 C
30680       XMAX=X(1)
30681       XMIN=X(1)
30682       DO 600 I=1,N
30683          XMAX=MAX(X(I),XMAX)
30684          XMIN=MIN(X(I),XMIN)
30685  600  CONTINUE
30686       XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30687 C
30688       ITEST=0
30689       DO 1100 K=0,IZEIL-1
30690          ITEST=ITEST+1
30691          IF (ITEST.EQ.IYRAST) THEN
30692             DO 1010 L=1,ISPALT-1
30693                COL(L,K)='-'
30694 1010        CONTINUE
30695             COL(ISPALT,K)='+'
30696             ITEST=0
30697             DO 1020 L=0,ISPALT-1,IXRAST
30698                COL(L,K)='+'
30699 1020        CONTINUE
30700          ELSE
30701             DO 1030 L=1,ISPALT-1
30702                COL(L,K)=' '
30703 1030        CONTINUE
30704             DO 1040 L=0,ISPALT-1,IXRAST
30705                COL(L,K)='|'
30706 1040        CONTINUE
30707             COL(ISPALT,K)='|'
30708          ENDIF
30709 1100  CONTINUE
30710 C
30711 C***  plot curve Y1
30712 C
30713       YMAX=Y1(1)
30714       YMIN=MAX(Y1(1),EPS)
30715       DO 500 I=1,N
30716          YMAX =MAX(Y1(I),YMAX)
30717          IF(Y1(I).GT.EPS) THEN
30718            IF(YMIN.EQ.EPS) THEN
30719              YMIN = Y1(I)/10.D0
30720            ELSE
30721              YMIN = MIN(Y1(I),YMIN)
30722            ENDIF
30723          ENDIF
30724 500   CONTINUE
30725       IF(IARG.GT.1) THEN
30726         DO 550 I=1,N
30727            YMAX=MAX(Y2(I),YMAX)
30728            IF(Y2(I).GT.EPS) THEN
30729              IF(YMIN.EQ.EPS) THEN
30730                YMIN = Y2(I)
30731              ELSE
30732                YMIN = MIN(Y2(I),YMIN)
30733              ENDIF
30734            ENDIF
30735 550     CONTINUE
30736       ENDIF
30737 C
30738       DO 560 I=1,N
30739         Y1(I) = MAX(Y1(I),YMIN)
30740  560  CONTINUE
30741       IF(IARG.GT.1) THEN
30742         DO 570 I=1,N
30743           Y2(I) = MAX(Y2(I),YMIN)
30744  570    CONTINUE
30745       ENDIF
30746 C
30747       IF(YMAX.LE.YMIN) THEN
30748         WRITE(LOUT,'(/1X,A,2E12.3,/)')
30749      &     'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
30750         WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
30751         RETURN
30752       ENDIF
30753 C
30754       YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
30755       YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
30756       YZOOM=(YMA-YMI)/DBLE(IZEIL)
30757       IF(YZOOM.LT.EPS) THEN
30758         WRITE(LOUT,'(1X,A)')
30759      &    'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30760         RETURN
30761       ENDIF
30762 C
30763 C***  plot curve Y1
30764 C
30765       ILAST=-1
30766       LLAST=-1
30767       DO 1200 K=1,N
30768          L=NINT((X(K)-XMIN)/XZOOM)
30769          I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
30770          IF(ILAST.GE.0) THEN
30771            LD = L-LLAST
30772            ID = I-ILAST
30773            DO 55 II=0,LD,SIGN(1,LD)
30774              DO 66 KK=0,ID,SIGN(1,ID)
30775                COL(II+LLAST,KK+ILAST)=SYMB(1)
30776  66          CONTINUE
30777  55        CONTINUE
30778          ELSE
30779            COL(L,I)=SYMB(1)
30780          ENDIF
30781          ILAST = I
30782          LLAST = L
30783 1200  CONTINUE
30784 C
30785       IF(IARG.GT.1) THEN
30786 C
30787 C***  plot curve Y2
30788 C
30789         DO 1250 K=1,N
30790            L=NINT((X(K)-XMIN)/XZOOM)
30791            I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
30792            COL(L,I)=SYMB(2)
30793 1250    CONTINUE
30794       ENDIF
30795 C
30796 C***  write it
30797 C
30798       WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
30799       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30800 C
30801 C***  write range of X
30802 C
30803       XZOOM1 = (XMAX-XMIN)/DBLE(7)
30804       WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30805 C
30806       DO 1300 K=0,IZEIL-1
30807          YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
30808          WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30809  110     FORMAT(1X,1PE9.2,70A1)
30810 1300  CONTINUE
30811 C
30812 C***  write range of X
30813 C
30814       WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30815       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30816  120  FORMAT(6X,7(1PE10.3))
30817 C
30818       END
30819
30820 *$ CREATE DT_SRPLOT.FOR
30821 *COPY DT_SRPLOT
30822 *
30823 *===plot===============================================================*
30824 *
30825       SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
30826
30827       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30828       SAVE
30829
30830       PARAMETER ( LINP = 10 ,
30831      &            LOUT = 6 ,
30832      &            LDAT = 9 )
30833 *
30834 *     initial version
30835 *     J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
30836 *     This is a subroutine of fluka to plot Y across the page
30837 *     as a function of X down the page. Up to 37 curves can be
30838 *     plotted in the same picture with different plotting characters.
30839 *     Output of first 10 overprinted characters addad by FB 88
30840 *  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
30841 *
30842 *     Input Variables:
30843 *        X   = array containing the values of X
30844 *        Y   = array containing the values of Y
30845 *        N   = number of values in X and in Y
30846 *              can exceed the fixed number of lines
30847 *        M   = number of different curves X,Y are containing
30848 *        MM  = number of points in each curve i.e. N=M*MM
30849 *        XO  = smallest value of X to be plotted
30850 *        DX  = increment of X between subsequent lines
30851 *        YO  = smallest value of Y to be plotted
30852 *        DY  = increment of Y between subsequent character spaces
30853 *
30854 *        other variables used inside:
30855 *        XX  = numbers along the X-coordinate axis
30856 *        YY  = numbers along the Y-coordinate axis
30857 *        LL  = ten lines temporary storage for the plot
30858 *        L   = character set used to plot different curves
30859 *        LOV = memorizes overprinted symbols
30860 *              the first 10 overprinted symbols are printed on
30861 *              the end of the line to avoid ambiguities
30862 *              (added by FB as considered quite helpful)
30863 *
30864 *********************************************************************
30865 *
30866       DIMENSION XX(61),YY(61),LL(101,10)
30867       DIMENSION X(N),Y(N),L(40),LOV(40,10)
30868       INTEGER*4 LL, L, LOV
30869       DATA  L/
30870      11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
30871      21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
30872      31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
30873      41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H  /
30874 *
30875 *
30876       MN=51
30877       DO 10 I=1,MN
30878         AI=I-1
30879    10 XX(I)=XO+AI*DX
30880       DO 20 I=1,11
30881         AI=I-1
30882    20 YY(I)=YO+10.0D0*AI*DY
30883       WRITE(LOUT, 500) (YY(I),I=1,11)
30884       MMN=MN-1
30885 *
30886 *
30887       DO 90 JJ=1,MMN,10
30888         JJJ=JJ-1
30889         DO 30 I=1,101
30890           DO 30 J=1,10
30891    30   LL(I,J)=L(40)
30892         DO 40 I=1,101
30893    40   LL(I,1)=L(39)
30894         DO 50 I=1,101,10
30895           DO 50 J=1,10
30896    50   LL(I,J)=L(38)
30897         DO 60 I=1,40
30898           DO 60 J=1,10
30899    60   LOV(I,J)=L(40)
30900 *
30901 *
30902         DO 70 I=1,M
30903           DO 70 J=1,MM
30904             II=J+(I-1)*MM
30905             AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
30906             AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
30907             AIX=AIX-DBLE(JJJ)
30908 *           changed Sept.88 by FB to avoid INTEGER OVERFLOW
30909             IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
30910      +      . AIY .LT. 102.D0) THEN
30911               IX=INT(AIX)
30912               IY=INT(AIY)
30913               IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
30914      +        THEN
30915                 IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
30916      +          =LL(IY,IX)
30917                 LL(IY,IX)=L(I)
30918               ENDIF
30919             ENDIF
30920    70   CONTINUE
30921 *
30922 *
30923         DO 80 I=1,10
30924           II=I+JJJ
30925           III=II+1
30926           WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
30927      &                    (LOV(J,I),J=1,10)
30928    80   CONTINUE
30929    90 CONTINUE
30930 *
30931 *
30932       WRITE(LOUT, 520)
30933       WRITE(LOUT, 500) (YY(I),I=1,11)
30934       RETURN
30935 *
30936   500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
30937   510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
30938   520 FORMAT(20X,10('1---------'),'1')
30939       END
30940
30941 *$ CREATE DT_DEFSET.FOR
30942 *COPY DT_DEFSET
30943 *
30944 *===defset=============================================================*
30945 *
30946       BLOCK DATA DT_DEFSET
30947
30948       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30949       SAVE
30950
30951 * flags for input different options
30952       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
30953       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
30954      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
30955       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
30956 * emulsion treatment
30957       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
30958      &                NCOMPO,IEMUL
30959
30960 * / DTFLG1 /
30961       DATA IFRAG  / 2, 1 /
30962       DATA IRESCO / 1 /
30963       DATA IMSHL  / 1 /
30964       DATA IRESRJ / 0 /
30965       DATA IOULEV / -1, -1, -1, -1, -1, -1 /
30966       DATA LEMCCK / .FALSE. /
30967       DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
30968      &              .TRUE.,.TRUE.,.TRUE./
30969       DATA LSEADI / .TRUE. /
30970       DATA LEVAPO / .TRUE. /
30971       DATA IFRAME / 1 /
30972       DATA ITRSPT / 0 /
30973
30974 * / DTCOMP /
30975       DATA EMUFRA / NCOMPX*0.0D0 /
30976       DATA IEMUMA / NCOMPX*1 /
30977       DATA IEMUCH / NCOMPX*1 /
30978       DATA NCOMPO / 0 /
30979       DATA IEMUL  / 0 /
30980
30981       END
30982
30983 *$ CREATE DT_HADPRP.FOR
30984 *COPY DT_HADPRP
30985 *
30986 *===hadprp=============================================================*
30987 *
30988       BLOCK DATA DT_HADPRP
30989
30990       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30991       SAVE
30992
30993 * auxiliary common for reggeon exchange (DTUNUC 1.x)
30994       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
30995      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
30996      &                IQTCHR(-6:6),MQUARK(3,39)
30997 * hadron index conversion (BAMJET <--> PDG)
30998       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
30999      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
31000      &                IAMCIN(210)
31001 * names of hadrons used in input-cards
31002       CHARACTER*8 BTYPE
31003       COMMON /DTPAIN/ BTYPE(30)
31004
31005 * / DTQUAR /
31006 *----------------------------------------------------------------------*
31007 *                                                                      *
31008 *     Quark content of particles:                                      *
31009 *          index   quark   el. charge  bar. charge  isospin  isospin3  *
31010 *              1 = u          2/3          1/3        1/2       1/2    *
31011 *             -1 = ubar      -2/3         -1/3        1/2      -1/2    *
31012 *              2 = d         -1/3          1/3        1/2      -1/2    *
31013 *             -2 = dbar       1/3         -1/3        1/2       1/2    *
31014 *              3 = s         -1/3          1/3         0         0     *
31015 *             -3 = sbar       1/3         -1/3         0         0     *
31016 *              4 = c          2/3          1/3         0         0     *
31017 *             -4 = cbar      -2/3         -1/3         0         0     *
31018 *              5 = b         -1/3          1/3         0         0     *
31019 *             -5 = bbar       1/3         -1/3         0         0     *
31020 *              6 = t          2/3          1/3         0         0     *
31021 *             -6 = tbar      -2/3         -1/3         0         0     *
31022 *                                                                      *
31023 *         Mquark = particle quark composition (Paprop numbering)       *
31024 *         Iqechr = electric charge ( in 1/3 unit )                     *
31025 *         Iqbchr = baryonic charge ( in 1/3 unit )                     *
31026 *         Iqichr = isospin ( in 1/2 unit ), z component                *
31027 *         Iqschr = strangeness                                         *
31028 *         Iqcchr = charm                                               *
31029 *         Iquchr = beauty                                              *
31030 *         Iqtchr = ......                                              *
31031 *                                                                      *
31032 *----------------------------------------------------------------------*
31033       DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
31034       DATA IQBCHR / 6*-1, 0, 6*1 /
31035       DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
31036       DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
31037       DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
31038       DATA IQUCHR / 0, 1, 9*0, -1, 0 /
31039       DATA IQTCHR / -1, 11*0, 1 /
31040       DATA MQUARK /
31041      &   2, 1, 1,   -2,-1,-1,    0, 0, 0,    0, 0, 0,    0, 0, 0,
31042      &   0, 0, 0,    0, 0, 0,    2, 2, 1,   -2,-2,-1,    0, 0, 0,
31043      &   0, 0, 0,    0, 0, 0,    1,-2, 0,    2,-1, 0,    1,-3, 0,
31044      &   3,-1, 0,    1, 2, 3,   -1,-2,-3,    0, 0, 0,    2, 2, 3,
31045      &   1, 1, 3,    1, 2, 3,    1,-1, 0,    2,-3, 0,    3,-2, 0,
31046      &   2,-2, 0,    3,-3, 0,    0, 0, 0,    0, 0, 0,    0, 0, 0,
31047      &  -1,-1,-3,   -1,-2,-3,   -2,-2,-3,    1, 3, 3,   -1,-3,-3,
31048      &   2, 3, 3,   -2,-3,-3,    3, 3, 3,   -3,-3,-3 /
31049
31050 * / DTHAIC /
31051 * (renamed) (HAdron InDex COnversion)
31052 * translation table version filled up by r.e. 25.01.94                 *
31053       DATA IAMCIN /
31054      &2212,-2212,11,-11,12,              -12,22,2112,-2112,-13,
31055      &13,130,211,-211,321,               -321,3122,-3122,310,3112,
31056      &3222,3212,111,311,-311,            0,0,0,0,0,
31057      &221,213,113,-213,223,              323,313,-323,-313,10323,
31058      &10313,-10323,-10313,30323,30313,   -30323,-30313,3224,3214,3114,
31059      &3216,3218,2224,2214,2114,          1114,12224,12214,12114,11114,
31060      &99999,99999,22212,22112,32124,     31214,-2224,-2214,-2114,-1114,
31061      &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
31062      &5*99999,                           5*99999,
31063      &4*99999,331,                       333,3322,3312,-3222,-3212,
31064      &-3112,-3322,-3312,3224,3214,       3114,3324,3314,3334,-3224,
31065      &-3214,-3114,-3324,-3314,-3334,     421,411,-411,-421,431,
31066      &-431,441,423,413,-413,             -423,433,-433,20443,443,
31067      &-15,15,16,-16,14,                  -14,4122,4232,4132,4222,
31068      &4212,4112,3*99999,                 3*99999,-4122,-4232,
31069      &-4132,-4222,-4212,-4112,99999,     5*99999,
31070      &5*99999,                           5*99999,
31071      &10*99999,
31072      &5*99999 , 20211,20111,-20211,99999,20321,
31073      &-20321,20311,-20311,7*99999 ,
31074      &7*99999,12212,12112,99999/
31075
31076 * / DTHAIC /
31077 * (HAdron InDex COnversion)
31078       DATA (IPDG2(1,K),K=1,7)
31079      &   /   -11,   -12,   -13,   -15,   -16,   -14,     0/
31080       DATA (IBAM2(1,K),K=1,7)
31081      &   /     4,     6,    10,   131,   134,   136,     0/
31082       DATA (IPDG2(2,K),K=1,7)
31083      &   /    11,    12,    22,    13,    15,    16,    14/
31084       DATA (IBAM2(2,K),K=1,7)
31085      &   /     3,     5,     7,    11,   132,   133,   135/
31086       DATA (IPDG3(1,K),K=1,22)
31087      &   /  -211,  -321,  -311,  -213,  -323,  -313,  -411,  -421,
31088      &      -431,  -413,  -423,  -433,     0,     0,     0,     0,
31089      &         0,     0,     0,     0,     0,     0/
31090       DATA (IBAM3(1,K),K=1,22)
31091      &   /    14,    16,    25,    34,    38,    39,   118,   119,
31092      &       121,   125,   126,   128,     0,     0,     0,     0,
31093      &         0,     0,     0,     0,     0,     0/
31094       DATA (IPDG3(2,K),K=1,22)
31095      &   /   130,   211,   321,   310,   111,   311,   221,   213,
31096      &       113,   223,   323,   313,   331,   333,   421,   411,
31097      &       431,   441,   423,   413,   433,   443/
31098       DATA (IBAM3(2,K),K=1,22)
31099      &   /    12,    13,    15,    19,    23,    24,    31,    32,
31100      &        33,    35,    36,    37,    95,    96,   116,   117,
31101      &       120,   122,   123,   124,   127,   130/
31102       DATA (IPDG4(1,K),K=1,29)
31103      &   / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
31104      &     -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
31105      &     -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
31106      &     -4212, -4112,     0,     0,     0/
31107       DATA (IBAM4(1,K),K=1,29)
31108      &   /     2,     9,    18,    67,    68,    69,    70,    75,
31109      &        76,    99,   100,   101,   102,   103,   110,   111,
31110      &       112,   113,   114,   115,   149,   150,   151,   152,
31111      &       153,   154,     0,     0,     0/
31112       DATA (IPDG4(2,K),K=1,29)
31113      &   /  2212,  2112,  3122,  3112,  3222,  3212,  3224,  3214,
31114      &      3114,  3216,  3218,  2224,  2214,  2114,  1114,  3322,
31115      &      3312,  3224,  3214,  3114,  3324,  3314,  3334,  4122,
31116      &      4232,  4132,  4222,  4212,  4112/
31117       DATA (IBAM4(2,K),K=1,29)
31118      &   /     1,     8,    17,    20,    21,    22,    48,    49,
31119      &        50,    51,    52,    53,    54,    55,    56,    97,
31120      &        98,   104,   105,   106,   107,   108,   109,   137,
31121      &       138,   139,   140,   141,   142/
31122       DATA (IPDG5(1,K),K=1,19)
31123      &   /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
31124      &    -20211,-20321,-20311,     0,     0,     0,     0,     0,
31125      &         0,     0,     0/
31126       DATA (IBAM5(1,K),K=1,19)
31127      &   /    42,    43,    46,    47,    71,    72,    73,    74,
31128      &       188,   191,   193,     0,     0,     0,     0,     0,
31129      &         0,     0,     0/
31130       DATA (IPDG5(2,K),K=1,19)
31131      &   / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
31132      &     22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
31133      &     20311, 12212, 12112/
31134       DATA (IBAM5(2,K),K=1,19)
31135      &   /    40,    41,    44,    45,    57,    58,    59,    60,
31136      &        63,    64,    65,    66,   129,   186,   187,   190,
31137      &       192,   208,   209/
31138
31139 * / DTPAIN /
31140 * internal particle names
31141       DATA BTYPE / 'PROTON  ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
31142      &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON  ' , 'NEUTRON ' , 'ANEUTRON' ,
31143      &'MUON+   ' , 'MUON-   ' , 'KAONLONG' , 'PION+   ' , 'PION-   ' ,
31144      &'KAON+   ' , 'KAON-   ' , 'LAMBDA  ' , 'ALAMBDA ' , 'KAONSHRT' ,
31145      &'SIGMA-  ' , 'SIGMA+  ' , 'SIGMAZER' , 'PIZERO  ' , 'KAONZERO' ,
31146      &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
31147      &'BLANK   ' /
31148
31149       END
31150
31151 *$ CREATE DT_BLKD46.FOR
31152 *COPY DT_BLKD46
31153 *
31154 *===blkd46=============================================================*
31155 *
31156       BLOCK DATA DT_BLKD46
31157
31158       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31159       SAVE
31160
31161       PARAMETER ( AMELCT = 0.51099906         D-03 )
31162       PARAMETER ( AMMUON = 0.105658389        D+00 )
31163
31164 * particle properties (BAMJET index convention)
31165       CHARACTER*8  ANAME
31166       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31167      &                IICH(210),IIBAR(210),K1(210),K2(210)
31168
31169 * / DTPART /
31170 * Particle  masses Engel version JETSET compatible
31171 C     DATA (AAM(K),K=1,85) /
31172 C    &   .9383D+00, .9383D+00,  AMELCT  ,  AMELCT  , .0000D+00,
31173 C    &   .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON   ,
31174 C    &   AMMUON   , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
31175 C    &   .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
31176 C    &   .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
31177 C    &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31178 C    &   .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
31179 C    &   .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
31180 C    &   .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
31181 C    &   .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
31182 C    &   .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31183 C    &   .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31184 C    &   .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31185 C    &   .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31186 C    &   .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31187 C    &   .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31188 C    &   .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01  /
31189 C     DATA (AAM(K),K=86,183) /
31190 C    &   .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31191 C    &   .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
31192 C    &   .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
31193 C    &   .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
31194 C    &   .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
31195 C    &   .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
31196 C    &   .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
31197 C    &   .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
31198 C    &   .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
31199 C    &   .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
31200 C    &   .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
31201 C    &   .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
31202 C    &   .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
31203 C    &   .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
31204 C    &   .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31205 C    &   .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31206 C    &   .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31207 C    &   .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31208 C    &   .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31209 C    &   .1250D+01, .1250D+01, .1250D+01  /
31210 C     DATA (AAM ( I ), I = 184,210 ) /
31211 C    & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31212 C    & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31213 C    & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31214 C    & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31215 C    & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31216 C    & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31217 C    & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31218 C    & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31219 C    & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31220 * sr 25.1.06: particle masses adjusted to Pythia
31221       DATA (AAM(K),K=1,85) /
31222      &   .938270E+00,.938270E+00, AMELCT    , AMELCT    ,.000000E+00,
31223      &   .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON    ,
31224      &    AMMUON    ,.497670E+00,.139570E+00,.139570E+00,.493600E+00,
31225      &   .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01,
31226      &   .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00,
31227      &     .0000D+00,  .0000D+00,  .0000D+00 , .0000D+00,  .0000D+00,
31228      &   .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00,
31229      &   .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01,
31230      &   .129000E+01,.129000E+01,.129000E+01,  .1421D+01,  .1421D+01,
31231      &     .1421D+01,  .1421D+01,.138280E+01,.138370E+01,.138720E+01,
31232      &     .1820D+01,  .2030D+01,  .1231D+01,  .1232D+01,  .1233D+01,
31233      &     .1234D+01,  .1675D+01,  .1675D+01,  .1675D+01,  .1675D+01,
31234      &     .1500D+01,  .1500D+01,  .1515D+01,  .1515D+01,  .1775D+01,
31235      &     .1775D+01,  .1231D+01,  .1232D+01,  .1233D+01,  .1234D+01,
31236      &     .1675D+01,  .1675D+01,  .1675D+01,  .1675D+01,  .1515D+01,
31237      &     .1515D+01,  .2500D+01,  .4890D+00,  .4890D+00,  .4890D+00,
31238      &     .1300D+01,  .1300D+01,  .1300D+01,  .1300D+01,  .2200D+01  /
31239       DATA (AAM(K),K=86,183) /
31240      &     .2200D+01,  .2200D+01,  .2200D+01,  .1700D+01,  .1700D+01,
31241      &     .1700D+01,  .1700D+01,  .1820D+01,  .2030D+01,.957770E+00,
31242      &   .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01,
31243      &   .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01,
31244      &   .138720E+01,.153180E+01,  .1535D+01,.167245E+01,.138280E+01,
31245      &   .138370E+01,.138720E+01,.153180E+01,  .1535D+01,.167245E+01,
31246      &   .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01,
31247      &   .196850E+01,.297980E+01,.200670E+01,  .2010D+01,  .2010D+01,
31248      &   .200670E+01,.211240E+01,.211240E+01,  .3686D+01,.309688E+01,
31249      &   .177700E+01,.177700E+01,  .0000D+00,  .0000D+00,  .0000D+00,
31250      &     .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01,
31251      &   .245350E+01,.245210E+01,  .2560D+01,  .2560D+01,  .2730D+01,
31252      &     .3610D+01,  .3610D+01,  .3790D+01,.228490E+01,.246560E+01,
31253      &     .2460D+01,.245290E+01,.245350E+01,.245210E+01,  .2560D+01,
31254      &     .2560D+01,  .2730D+01,  .3610D+01,  .3610D+01,  .3790D+01,
31255      &     .2490D+01,  .2490D+01,  .2490D+01,  .2610D+01,  .2610D+01,
31256      &     .2770D+01,  .3670D+01,  .3670D+01,  .3850D+01,  .4890D+01,
31257      &     .2490D+01,  .2490D+01,  .2490D+01,  .2610D+01,  .2610D+01,
31258      &     .2770D+01,  .3670D+01,  .3670D+01,  .3850D+01,  .4890D+01,
31259      &     .1250D+01,  .1250D+01,  .1250D+01  /
31260       DATA (AAM ( I ), I = 184,210 ) /
31261      & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31262      & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31263      & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31264      & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31265      & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31266      & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31267      & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31268      & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31269      & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31270 * Particle  mean lives
31271       DATA (TAU(K),K=1,183) /
31272      &   .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
31273      &   .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
31274      &   .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
31275      &   .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
31276      &   .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
31277      &   70*.0000D+00,
31278      &   .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
31279      &   .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
31280      &   .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
31281      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
31282      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31283      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31284      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31285      &   .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
31286      &   .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31287      &   40*.0000D+00,
31288      &   .0000D+00, .0000D+00, .0000D+00  /
31289       DATA ( TAU ( I ), I = 184,210 ) /
31290      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31291      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31292      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31293      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31294      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31295      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31296      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31297      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31298      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/
31299 * Resonance width Gamma in GeV
31300       DATA (GA(K),K=  1,85) /
31301      &    30*.0000D+00,
31302      &   .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
31303      &   .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
31304      &   .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
31305      &   .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
31306      &   .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
31307      &   .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
31308      &   .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
31309      &   .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
31310      &   .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
31311      &   .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
31312      &   .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00  /
31313       DATA (GA(K),K= 86,183) /
31314      &   .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
31315      &   .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
31316      &   .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31317      &   .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
31318      &   .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
31319      &   .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
31320      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31321      &   .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
31322      &   .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
31323      &   50*.0000D+00,
31324      &   .3000D+00, .3000D+00, .3000D+00  /
31325       DATA ( GA ( I ), I = 184,210 ) /
31326      & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
31327      & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
31328      & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
31329      & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
31330      & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31331      & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31332      & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
31333      & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
31334      & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
31335 * Particle  names
31336 * S+1385+Sigma+(1385)    L02030+Lambda0(2030)
31337 * Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
31338 * designation N*@@ means N*@1(@2)
31339       DATA (ANAME(K),K=1,85) /
31340      &  'P       ','AP      ','E-      ','E+      ','NUE     ',
31341      &  'ANUE    ','GAM     ','NEU     ','ANEU    ','MUE+    ',
31342      &  'MUE-    ','K0L     ','PI+     ','PI-     ','K+      ',
31343      &  'K-      ','LAM     ','ALAM    ','K0S     ','SIGM-   ',
31344      &  'SIGM+   ','SIGM0   ','PI0     ','K0      ','AK0     ',
31345      &  'BLANK   ','BLANK   ','BLANK   ','BLANK   ','BLANK   ',
31346      &  'ETA550  ','RHO+77  ','RHO077  ','RHO-77  ','OM0783  ',
31347      &  'K*+892  ','K*0892  ','K*-892  ','AK*089  ','KA+125  ',
31348      &  'KA0125  ','KA-125  ','AKA012  ','K*+142  ','K*0142  ',
31349      &  'K*-142  ','AK*014  ','S+1385  ','S01385  ','S-1385  ',
31350      &  'L01820  ','L02030  ','N*++12  ','N*+ 12  ','N*012   ',
31351      &  'N*-12   ','N*++16  ','N*+16   ','N*016   ','N*-16   ',
31352      &  'N*+14   ','N*014   ','N*+15   ','N*015   ','N*+18   ',
31353      &  'N*018   ','AN--12  ','AN*-12  ','AN*012  ','AN*+12  ',
31354      &  'AN--16  ','AN*-16  ','AN*016  ','AN*+16  ','AN*-15  ',
31355      &  'AN*015  ','DE*=24  ','RPI+49  ','RPI049  ','RPI-49  ',
31356      &  'PIN++   ','PIN+0   ','PIN+-   ','PIN-0   ','PPPI    ' /
31357       DATA (ANAME(K),K=86,183) /
31358      &  'PNPI    ','APPPI   ','APNPI   ','K+PPI   ','K-PPI   ',
31359      &  'K+NPI   ','K-NPI   ','S+1820  ','S-2030  ','ETA*    ',
31360      &  'PHI     ','TETA0   ','TETA-   ','ASIG-   ','ASIG0   ',
31361      &  'ASIG+   ','ATETA0  ','ATETA+  ','SIG*+   ','SIG*0   ',
31362      &  'SIG*-   ','TETA*0  ','TETA*   ','OMEGA-  ','ASIG*-  ',
31363      &  'ASIG*0  ','ASIG*+  ','ATET*0  ','ATET*+  ','OMEGA+  ',
31364      &  'D0      ','D+      ','D-      ','AD0     ','F+      ',
31365      &  'F-      ','ETAC    ','D*0     ','D*+     ','D*-     ',
31366      &  'AD*0    ','F*+     ','F*-     ','PSI     ','JPSI    ',
31367      &  'TAU+    ','TAU-    ','NUET    ','ANUET   ','NUEM    ',
31368      &  'ANUEM   ','C0+     ','A+      ','A0      ','C1++    ',
31369      &  'C1+     ','C10     ','S+      ','S0      ','T0      ',
31370      &  'XU++    ','XD+     ','XS+     ','AC0-    ','AA-     ',
31371      &  'AA0     ','AC1--   ','AC1-    ','AC10    ','AS-     ',
31372      &  'AS0     ','AT0     ','AXU--   ','AXD-    ','AXS     ',
31373      &  'C1*++   ','C1*+    ','C1*0    ','S*+     ','S*0     ',
31374      &  'T*0     ','XU*++   ','XD*+    ','XS*+    ','TETA++  ',
31375      &  'AC1*--  ','AC1*-   ','AC1*0   ','AS*-    ','AS*0    ',
31376      &  'AT*0    ','AXU*--  ','AXD*-   ','AXS*-   ','ATET--  ',
31377      &  'RO      ','R+      ','R-      '  /
31378       DATA (    ANAME ( I ), I = 184,210 ) /
31379      &'AN*-14  ','AN*014  ','PI+130  ','PI0130  ','PI-130  ','F01400  ',
31380      &'K*+146  ','K*-146  ','K*0146  ','AK0146  ','L01600  ','AL0160  ',
31381      &'S+1660  ','S01660  ','S-1660  ','AS-166  ','AS0166  ','AS+166  ',
31382      &'X01950  ','X-1950  ','AX0195  ','AX+195  ','OM-225  ','AOM+22  ',
31383      &'N*+14   ','N*014   ','BLANK   '/
31384 * Charge of particles and resonances
31385       DATA (IICH ( I ), I =   1,210 ) /
31386      &  1, -1, -1,  1,  0,  0,  0,  0,  0,  1, -1,  0,  1, -1,  1,
31387      & -1,  0,  0,  0, -1,  1,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31388      &  0,  1,  0, -1,  0,  1,  0, -1,  0,  1,  0, -1,  0,  1,  0,
31389      & -1,  0,  1,  0, -1,  0,  0,  2,  1,  0, -1,  2,  1,  0, -1,
31390      &  1,  0,  1,  0,  1,  0, -2, -1,  0,  1, -2, -1,  0,  1, -1,
31391      &  0,  1,  1,  0, -1,  2,  1,  0, -1,  2,  1,  0, -1,  2,  0,
31392      &  1, -1,  1, -1,  0,  0,  0, -1, -1,  0,  1,  0,  1,  1,  0,
31393      & -1,  0, -1, -1, -1,  0,  1,  0,  1,  1,  0,  1, -1,  0,  1,
31394      & -1,  0,  0,  1, -1,  0,  1, -1,  0,  0,  1, -1,  0,  0,  0,
31395      &  0,  1,  1,  0,  2,  1,  0,  1,  0,  0,  2,  1,  1, -1, -1,
31396      &  0, -2, -1,  0, -1,  0,  0, -2, -1, -1,  2,  1,  0,  1,  0,
31397      &  0,  2,  1,  1,  2, -2, -1,  0, -1,  0,  0, -2, -1, -1, -2,
31398      &  0,  1, -1, -1,  0,  1,  0, -1,  0,  1, -1,  0,  0,  0,  0,
31399      &  1,  0, -1, -1,  0,  1,  0, -1,  0,  1, -1,  1,  1,  0,  0/
31400 * Particle  baryonic charges
31401       DATA (IIBAR ( I ), I =   1,210 ) /
31402      &  1, -1,  0,  0,  0,  0,  0,  1, -1,  0,  0,  0,  0,  0,  0,
31403      &  0,  1, -1,  0,  1,  1,  1,  0,  0,  0,  0,  0,  0,  0,  0,
31404      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31405      &  0,  0,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,
31406      &  1,  1,  1,  1,  1,  1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31407      & -1,  2,  0,  0,  0,  1,  1,  1,  1,  2,  2,  0,  0,  1,  1,
31408      &  1,  1,  1,  1,  0,  0,  1,  1, -1, -1, -1, -1, -1,  1,  1,
31409      &  1,  1,  1,  1, -1, -1, -1, -1, -1, -1,  0,  0,  0,  0,  0,
31410      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31411      &  0,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1, -1, -1,
31412      & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,  1,  1,  1,  1,  1,
31413      &  1,  1,  1,  1,  1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31414      &  0,  0,  0, -1, -1,  0,  0,  0,  0,  0,  0,  0,  0,  1, -1,
31415      &  1,  1,  1, -1, -1, -1,  1,  1, -1, -1,  1, -1,  1,  1,  0/
31416 * First number of decay channels used for resonances
31417 * and decaying particles
31418       DATA K1/   1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 16, 17,
31419      &  18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
31420      &   2*330, 46, 51, 52, 54, 55, 58,
31421 *                                                             50
31422      &  60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
31423      & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
31424      & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
31425 *                                         85
31426      & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
31427      & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
31428      & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
31429      & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
31430      & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
31431      & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
31432      & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
31433      & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
31434      & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
31435      & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
31436      & 590, 596, 602 /
31437 * Last number of decay channels used for resonances
31438 * and decaying particles
31439       DATA K2/   1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 15, 16, 17,
31440      & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
31441      & 2* 330, 50, 51, 53, 54, 57,
31442 *                                                                 50
31443      & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
31444      & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
31445      & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
31446 *                                              85
31447      & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
31448      & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
31449      & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
31450      & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
31451      & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
31452      & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
31453      & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
31454      & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
31455      & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
31456      & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
31457      & 589, 595, 601, 602 /
31458
31459        END
31460
31461 *$ CREATE DT_BLKD47.FOR
31462 *COPY DT_BLKD47
31463 *
31464 *===blkd47=============================================================*
31465 *
31466       BLOCK DATA DT_BLKD47
31467
31468       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31469       SAVE
31470
31471 * HADRIN: decay channel information
31472       PARAMETER (IDMAX9=602)
31473       CHARACTER*8 ZKNAME
31474       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
31475
31476 * Name of decay channel
31477 * Designation N*@ means N*@1(1236)
31478 * @1=# means ++,  @1 = = means --
31479 * Designation  P+/0/- means Pi+/Pi0/Pi- , respectively
31480       DATA (ZKNAME(K),K=  1, 85) /
31481      &  'P       ','AP      ','E-      ','E+      ','NUE     ',
31482      &  'ANUE    ','GAM     ','PE-NUE  ','APEANU  ','EANUNU  ',
31483      &  'E-NUAN  ','3PI0    ','PI+-0   ','PIMUNU  ','PIE-NU  ',
31484      &  'MU+NUE  ','MU-NUE  ','MU+NUE  ','PI+PI0  ','PI++-   ',
31485      &  'PI+00   ','M+P0NU  ','E+P0NU  ','MU-NU   ','PI-0    ',
31486      &  'PI+--   ','PI-00   ','M-P0NU  ','E-P0NU  ','PPI-    ',
31487      &  'NPI0    ','PD-NUE  ','PM-NUE  ','APPI+   ','ANPI0   ',
31488      &  'APE+NU  ','APM+NU  ','PI+PI-  ','PI0PI0  ','NPI-    ',
31489      &  'PPI0    ','NPI+    ','LAGA    ','GAGA    ','GAE+E-  ',
31490      &  'GAGA    ','GAGAP0  ','PI000   ','PI+-0   ','PI+-GA  ',
31491      &  'PI+0    ','PI+-    ','PI00    ','PI-0    ','PI+-0   ',
31492      &  'PI+-    ','PI0GA   ','K+PI0   ','K0PI+   ','KOPI0   ',
31493      &  'K+PI-   ','K-PI0   ','AK0PI-  ','AK0PI0  ','K-PI+   ',
31494      &  'K+PI0   ','K0PI+   ','K0PI0   ','K+PI-   ','K-PI0   ',
31495      &  'K0PI-   ','AK0PI0  ','K-PI+   ','K+PI0   ','K0PI+   ',
31496      &  'K+89P0  ','K08PI+  ','K+RO77  ','K0RO+7  ','K+OM07  ',
31497      &  'K+E055  ','K0PI0   ','K+PI+   ','K089P0  ','K+8PI-  '  /
31498       DATA (ZKNAME(K),K= 86,170) /
31499      &  'K0R077  ','K+R-77  ','K+R-77  ','K0OM07  ','K0E055  ',
31500      &  'K-PI0   ','K0PI-   ','K-89P0  ','AK08P-  ','K-R077  ',
31501      &  'AK0R-7  ','K-OM07  ','K-E055  ','AK0PI0  ','K-PI+   ',
31502      &  'AK08P0  ','K-8PI+  ','AK0R07  ','AK0OM7  ','AK0E05  ',
31503      &  'LA0PI+  ','SI0PI+  ','SI+PI0  ','LA0PI0  ','SI+PI-  ',
31504      &  'SI-PI+  ','LA0PI-  ','SI0PI-  ','NEUAK0  ','PK-     ',
31505      &  'SI+PI-  ','SI0PI0  ','SI-PI+  ','LA0ET0  ','S+1PI-  ',
31506      &  'S-1PI+  ','SO1PI0  ','NEUAK0  ','PK-     ','LA0PI0  ',
31507      &  'LA0OM0  ','LA0RO0  ','SI+RO-  ','SI-RO+  ','SI0RO0  ',
31508      &  'LA0ET0  ','SI0ET0  ','SI+PI-  ','SI-PI+  ','SI0PI0  ',
31509      &  'K0S     ','K0L     ','K0S     ','K0L     ','P PI+   ',
31510      &  'P PI0   ','N PI+   ','P PI-   ','N PI0   ','N PI-   ',
31511      &  'P PI+   ','N*#PI0  ','N*+PI+  ','PRHO+   ','P PI0   ',
31512      &  'N PI+   ','N*#PI-  ','N*+PI0  ','N*0PI+  ','PRHO0   ',
31513      &  'NRHO+   ','P PI-   ','N PI0   ','N*+PI-  ','N*0PI0  ',
31514      &  'N*-PI+  ','PRHO-   ','NRHO0   ','N PI-   ','N*0PI-  ',
31515      &  'N*-PI0  ','NRHO-   ','PETA0   ','N*#PI-  ','N*+PI0  '  /
31516       DATA (ZKNAME(K),K=171,255) /
31517      &  'N*0PI+  ','PRHO0   ','NRHO+   ','NETA0   ','N*+PI-  ',
31518      &  'N*0PI0  ','N*-PI+  ','PRHO-   ','NRHO0   ','P PI0   ',
31519      &  'N PI+   ','N*#PI-  ','N*+PI0  ','N*0PI+  ','PRHO0   ',
31520      &  'NRHO+   ','P PI-   ','N PI0   ','N*+PI-  ','N*0PI0  ',
31521      &  'N*-PI+  ','PRHO-   ','NRHO0   ','P PI0   ','N PI+   ',
31522      &  'PRHO0   ','NRHO+   ','LAMK+   ','S+ K0   ','S0 K+   ',
31523      &  'PETA0   ','P PI-   ','N PI0   ','PRHO-   ','NRHO0   ',
31524      &  'LAMK0   ','S0 K0   ','S- K+   ','NETA/   ','APPI-   ',
31525      &  'APPI0   ','ANPI-   ','APPI+   ','ANPI0   ','ANPI+   ',
31526      &  'APPI-   ','AN*=P0  ','AN*-P-  ','APRHO-  ','APPI0   ',
31527      &  'ANPI-   ','AN*=P+  ','AN*-P0  ','AN*0P-  ','APRHO0  ',
31528      &  'ANRHO-  ','APPI+   ','ANPI0   ','AN*-P+  ','AN*0P0  ',
31529      &  'AN*+P-  ','APRHO+  ','ANRHO0  ','ANPI+   ','AN*0P+  ',
31530      &  'AN*+P0  ','ANRHO+  ','APPI0   ','ANPI-   ','AN*=P+  ',
31531      &  'AN*-P0  ','AN*0P-  ','APRHO0  ','ANRHO-  ','APPI+,  ',
31532      &  'ANPI0   ','AN*-P+  ','AN*0P0  ','AN*+P-  ','APRHO+  ',
31533      &  'ANRHO0  ','PN*014  ','NN*=14  ','PI+0    ','PI+-    '  /
31534       DATA (ZKNAME(K),K=256,340) /
31535      &  'PI-0    ','P+0     ','N++     ','P+-     ','P00     ',
31536      &  'N+0     ','N+-     ','N00     ','P-0     ','N-0     ',
31537      &  'P--     ','PPPI0   ','PNPI+   ','PNPI0   ','PPPI-   ',
31538      &  'NNPI+   ','APPPI0  ','APNPI+  ','ANNPI0  ','ANPPI-  ',
31539      &  'APNPI0  ','APPPI-  ','ANNPI-  ','K+PPI0  ','K+NPI+  ',
31540      &  'K0PPI0  ','K-PPI0  ','K-NPI+  ','AKPPI-  ','AKNPI0  ',
31541      &  'K+NPI0  ','K+PPI-  ','K0PPI0  ','K0NPI+  ','K-NPI0  ',
31542      &  'K-PPI-  ','AKNPI-  ','PAK0    ','SI+PI0  ','SI0PI+  ',
31543      &  'SI+ETA  ','S+1PI0  ','S01PI+  ','NEUK-   ','LA0PI-  ',
31544      &  'SI-OM0  ','LA0RO-  ','SI0RO-  ','SI-RO0  ','SI-ET0  ',
31545      &  'SI0PI-  ','SI-0    ','BLANC   ','BLANC   ','BLANC   ',
31546      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31547      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31548      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31549      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31550      &  'EPI+-   ','EPI00   ','GAPI+-  ','GAGA*   ','K+-     ',
31551      &  'KLKS    ','PI+-0   ','EGA     ','LPI0    ','LPI     '  /
31552       DATA (ZKNAME(K),K=341,425) /
31553      &  'APPI0   ','ANPI-   ','ALAGA   ','ANPI    ','ALPI0   ',
31554      &  'ALPI+   ','LAPI+   ','SI+PI0  ','SI0PI+  ','LAPI0   ',
31555      &  'SI+PI-  ','SI-PI+  ','LAPI-   ','SI-PI0  ','SI0PI-  ',
31556      &  'TE0PI0  ','TE-PI+  ','TE0PI-  ','TE-PI0  ','TE0PI   ',
31557      &  'TE-PI   ','LAK-    ','ALPI-   ','AS-PI0  ','AS0PI-  ',
31558      &  'ALPI0   ','AS+PI-  ','AS-PI+  ','ALPI+   ','AS+PI0  ',
31559      &  'AS0PI+  ','AT0PI0  ','AT+PI-  ','AT0PI+  ','AT+PI0  ',
31560      &  'AT0PI   ','AT+PI   ','ALK+    ','K-PI+   ','K-PI+0  ',
31561      &  'K0PI+-  ','K0PI0   ','K-PI++  ','AK0PI+  ','K+PI--  ',
31562      &  'K0PI-   ','K+PI-   ','K+PI-0  ','AKPI-+  ','AK0PI0  ',
31563      &  'ETAPIF  ','K++-    ','K+AK0   ','ETAPI-  ','K--+    ',
31564      &  'K-K0    ','PI00    ','PI+-    ','GAGA    ','D0PI0   ',
31565      &  'D0GA    ','D0PI+   ','D+PI0   ','DFGA    ','AD0PI-  ',
31566      &  'D-PI0   ','D-GA    ','AD0PI0  ','AD0GA   ','F+GA    ',
31567      &  'F+GA    ','F-GA    ','F-GA    ','PSPI+-  ','PSPI00  ',
31568      &  'PSETA   ','E+E-    ','MUE+-   ','PI+-0   ','M+NN    ',
31569      &  'E+NN    ','RHO+NT  ','PI+ANT  ','K*+ANT  ','M-NN    '  /
31570       DATA (ZKNAME(K),K=426,510) /
31571      &  'E-NN    ','RHO-NT  ','PI-NT   ','K*-NT   ','NUET    ',
31572      &  'ANUET   ','NUEM    ','ANUEM   ','SI+ETA  ','SI+ET*  ',
31573      &  'PAK0    ','TET0K+  ','SI*+ET  ','N*+AK0  ','N*++K-  ',
31574      &  'LAMRO+  ','SI0RO+  ','SI+RO0  ','SI+OME  ','PAK*0   ',
31575      &  'N*+AK*  ','N*++K*  ','SI+AK0  ','TET0PI  ','SI+AK*  ',
31576      &  'TET0RO  ','SI0AK*  ','SI+K*-  ','TET0OM  ','TET-RO  ',
31577      &  'SI*0AK  ','C0+PI+  ','C0+PI0  ','C0+PI-  ','A+GAM   ',
31578      &  'A0GAM   ','TET0AK  ','TET0K*  ','OM-RO+  ','OM-PI+  ',
31579      &  'C1++AK  ','A+PI+   ','C0+AK0  ','A0PI+   ','A+AK0   ',
31580      &  'T0PI+   ','ASI-ET  ','ASI-E*  ','APK0    ','ATET0K  ',
31581      &  'ASI*-E  ','AN*-K0  ','AN*--K  ','ALAMRO  ','ASI0RO  ',
31582      &  'ASI-RO  ','ASI-OM  ','APK*0   ','AN*-K*  ','AN*--K  ',
31583      &  'ASI-K0  ','ATETPI  ','ASI-K*  ','ATETRO  ','ASI0K*  ',
31584      &  'ASI-K*  ','ATE0OM  ','ATE+RO  ','ASI*0K  ','AC-PI-  ',
31585      &  'AC-PI0  ','AC-PI+  ','AA-GAM  ','AA0GAM  ','ATET0K  ',
31586      &  'ATE0K*  ','AOM+RO  ','AOM+PI  ','AC1--K  ','AA-PI-  ',
31587      &  'AC0-K0  ','AA0PI-  ','AA-K0   ','AT0PI-  ','C1++GA  '  /
31588       DATA (ZKNAME(K),K=511,540) /
31589      &  'C1++GA  ','C10GAM  ','S+GAM   ','S0GAM   ','T0GAM   ',
31590      &  'XU++GA  ','XD+GAM  ','XS+GAM  ','A+AKPI  ','T02PI+  ',
31591      &  'C1++2K  ','AC1--G  ','AC1-GA  ','AC10GA  ','AS-GAM  ',
31592      &  'AS0GAM  ','AT0GAM  ','AXU--G  ','AXD-GA  ','AXS-GA  ',
31593      &  'AA-KPI  ','AT02PI  ','AC1--K  ','RH-PI+  ','RH+PI-  ',
31594      &  'RH3PI0  ','RH0PI+  ','RH+PI0  ','RH0PI-  ','RH-PI0  '  /
31595       DATA (ZKNAME(I),I=541,602)/
31596      & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
31597      & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
31598      & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
31599      & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
31600      & 'PI+PI-','K+K-  ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
31601      & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
31602      & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
31603      & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
31604      & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
31605 * Weight of decay channel
31606       DATA (WT(K),K=  1, 85) /
31607      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31608      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31609      &   .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
31610      &   .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
31611      &   .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
31612      &   .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
31613      &   .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
31614      &   .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
31615      &   .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
31616      &   .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
31617      &   .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
31618      &   .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
31619      &   .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
31620      &   .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
31621      &   .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
31622      &   .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
31623      &   .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00  /
31624       DATA (WT(K),K= 86,170) /
31625      &   .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
31626      &   .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
31627      &   .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
31628      &   .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
31629      &   .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
31630      &   .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
31631      &   .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
31632      &   .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
31633      &   .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
31634      &   .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
31635      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
31636      &   .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31637      &   .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31638      &   .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31639      &   .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31640      &   .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31641      &   .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00  /
31642       DATA (WT(K),K=171,255) /
31643      &   .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
31644      &   .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
31645      &   .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
31646      &   .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
31647      &   .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
31648      &   .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
31649      &   .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
31650      &   .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
31651      &   .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31652      &   .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31653      &   .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31654      &   .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31655      &   .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31656      &   .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
31657      &   .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
31658      &   .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
31659      &   .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01  /
31660       DATA (WT(K),K=256,340) /
31661      &   .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
31662      &   .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
31663      &   .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
31664      &   .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
31665      &   .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
31666      &   .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
31667      &   .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
31668      &   .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
31669      &   .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
31670      &   .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
31671      &   .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01,
31672      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31673      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31674      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31675      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31676      &   .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
31677      &   .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01  /
31678       DATA (WT(K),K=341,425) /
31679      &   .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
31680      &   .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
31681      &   .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
31682      &   .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
31683      &   .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
31684      &   .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
31685      &   .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
31686      &   .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
31687      &   .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
31688      &   .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
31689      &   .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
31690      &   .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
31691      &   .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
31692      &   .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
31693      &   .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
31694      &   .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
31695      &   .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00  /
31696       DATA (WT(K),K=426,510) /
31697      &   .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
31698      &   .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
31699      &   .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
31700      &   .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
31701      &   .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
31702      &   .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
31703      &   .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31704      &   .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
31705      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
31706      &   .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
31707      &   .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
31708      &   .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
31709      &   .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
31710      &   .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
31711      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
31712      &   .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
31713      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01  /
31714       DATA (WT(K),K=511,540) /
31715      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31716      &   .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
31717      &   .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31718      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31719      &   .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
31720      &   .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00  /
31721 C
31722       DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
31723      & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
31724      & .125D+00,  0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
31725      & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
31726      & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
31727      & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
31728      & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
31729 * Particle numbers in decay channel
31730       DATA (NZK(K,1),K=  1,170) /
31731      &     1,   2,   3,   4,   5,   6,   7,   1,   2,   4,
31732      &     3,  23,  13,  13,  13,  10,  11,  10,  13,  13,
31733      &    13,  10,   4,  11,  14,  14,  14,  11,   3,   1,
31734      &     8,   1,   1,   2,   9,   2,   2,  13,  23,   8,
31735      &     1,   8,  17,   7,   7,   7,  23,  23,  13,  13,
31736      &    13,  13,  23,  14,  13,  13,  23,  15,  24,  24,
31737      &    15,  16,  25,  25,  16,  15,  24,  24,  15,  16,
31738      &    24,  25,  16,  15,  24,  36,  37,  15,  24,  15,
31739      &    15,  24,  15,  37,  36,  24,  15,  24,  24,  16,
31740      &    24,  38,  39,  16,  25,  16,  16,  25,  16,  39,
31741      &    38,  25,  16,  25,  25,  17,  22,  21,  17,  21,
31742      &    20,  17,  22,   8,   1,  21,  22,  20,  17,  48,
31743      &    50,  49,   8,   1,  17,  17,  17,  21,  20,  22,
31744      &    17,  22,  21,  20,  22,  19,  12,  19,  12,   1,
31745      &     1,   8,   1,   8,   8,   1,  53,  54,   1,   1,
31746      &     8,  53,  54,  55,   1,   8,   1,   8,  54,  55,
31747      &    56,   1,   8,   8,  55,  56,   8,   1,  53,  54  /
31748       DATA (NZK(K,1),K=171,340) /
31749      &    55,   1,   8,   8,  54,  55,  56,   1,   8,   1,
31750      &     8,  53,  54,  55,   1,   8,   1,   8,  54,  55,
31751      &    56,   1,   8,   1,   8,   1,   8,  17,  21,  22,
31752      &     1,   1,   8,   1,   8,  17,  22,  20,   8,   2,
31753      &     2,   9,   2,   9,   9,   2,  67,  68,   2,   2,
31754      &     9,  67,  68,  69,   2,   9,   2,   9,  68,  69,
31755      &    70,   2,   9,   9,  69,  70,   9,   2,   9,  67,
31756      &    68,  69,   2,   9,   2,   9,  68,  69,  70,   2,
31757      &     9,   1,   8,  13,  13,  14,   1,   8,   1,   1,
31758      &     8,   8,   8,   1,   8,   1,   1,   1,   1,   1,
31759      &     8,   2,   2,   9,   9,   2,   2,   9,  15,  15,
31760      &    24,  16,  16,  25,  25,  15,  15,  24,  24,  16,
31761      &    16,  25,   1,  21,  22,  21,  48,  49,   8,  17,
31762      &    20,  17,  22,  20,  20,  22,  20,   0,   0,   0,
31763      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31764      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31765      &    31,  31,  13,   7,  15,  12,  13,  31,  17,  17  /
31766       DATA (NZK(K,1),K=341,510) /
31767      &     2,   9,  18,   9,  18,  18,  17,  21,  22,  17,
31768      &    21,  20,  17,  20,  22,  97,  98,  97,  98,  97,
31769      &    98,  17,  18,  99, 100,  18, 101,  99,  18, 101,
31770      &   100, 102, 103, 102, 103, 102, 103,  18,  16,  16,
31771      &    24,  24,  16,  25,  15,  24,  15,  15,  25,  25,
31772      &    31,  15,  15,  31,  16,  16,  23,  13,   7, 116,
31773      &   116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
31774      &   120, 121, 121, 130, 130, 130,   4,  10,  13,  10,
31775      &     4,  32,  13,  36,  11,   3,  34,  14,  38, 133,
31776      &   134, 135, 136,  21,  21,   1,  97, 104,  54,  53,
31777      &    17,  22,  21,  21,   1,  54,  53,  21,  97,  21,
31778      &    97,  22,  21,  97,  98, 105, 137, 137, 137, 138,
31779      &   139,  97,  97, 109, 109, 140, 138, 137, 139, 138,
31780      &   145,  99,  99,   2, 102, 110,  68,  67,  18, 100,
31781      &    99,  99,   2,  68,  67,  99, 102,  99, 102, 100,
31782      &    99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
31783      &   113, 115, 115, 152, 150, 149, 151, 150, 157, 140  /
31784       DATA (NZK(K,1),K=511,540) /
31785      &   141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
31786      &   140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
31787      &   150, 157, 152,  34,  32,  33,  33,  32,  33,  34  /
31788       DATA (NZK(I,1),I=541,602) /  2, 67, 68, 69,  2,  9,  9, 68, 69,
31789      & 70,  2,  9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
31790      & 14, 189, 23, 13, 15, 24,  36,  38,  37,  39, 194, 195, 196, 197,
31791      & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
31792      & 55, 8, 1, 8, 8, 54, 55, 210/
31793       DATA (NZK(K,2),K=  1,170) /
31794      &     0,   0,   0,   0,   0,   0,   0,   3,   4,   6,
31795      &     5,  23,  14,  11,   3,   5,   5,   5,  23,  13,
31796      &    23,  23,  23,   5,  23,  13,  23,  23,  23,  14,
31797      &    23,   3,  11,  13,  23,   4,  10,  14,  23,  14,
31798      &    23,  13,   7,   7,   4,   7,   7,  23,  14,  14,
31799      &    23,  14,  23,  23,  14,  14,   7,  23,  13,  23,
31800      &    14,  23,  14,  23,  13,  23,  13,  23,  14,  23,
31801      &    14,  23,  13,  23,  13,  23,  13,  33,  32,  35,
31802      &    31,  23,  14,  23,  14,  33,  34,  35,  31,  23,
31803      &    14,  23,  14,  33,  34,  35,  31,  23,  13,  23,
31804      &    13,  33,  32,  35,  31,  13,  13,  23,  23,  14,
31805      &    13,  14,  14,  25,  16,  14,  23,  13,  31,  14,
31806      &    13,  23,  25,  16,  23,  35,  33,  34,  32,  33,
31807      &    31,  31,  14,  13,  23,   0,   0,   0,   0,  13,
31808      &    23,  13,  14,  23,  14,  13,  23,  13,  78,  23,
31809      &    13,  14,  23,  13,  79,  78,  14,  23,  14,  23,
31810      &    13,  80,  79,  14,  14,  23,  80,  31,  14,  23  /
31811       DATA (NZK(K,2),K=171,340) /
31812      &    13,  79,  78,  31,  14,  23,  13,  80,  79,  23,
31813      &    13,  14,  23,  13,  79,  78,  14,  23,  14,  23,
31814      &    13,  80,  79,  23,  13,  33,  32,  15,  24,  15,
31815      &    31,  14,  23,  34,  33,  24,  24,  15,  31,  14,
31816      &    23,  14,  13,  23,  13,  14,  23,  14,  80,  23,
31817      &    14,  13,  23,  14,  79,  80,  13,  23,  13,  23,
31818      &    14,  78,  79,  13,  13,  23,  78,  23,  14,  13,
31819      &    23,  14,  79,  80,  13,  23,  13,  23,  14,  78,
31820      &    79,  62,  61,  23,  14,  23,  13,  13,  13,  23,
31821      &    13,  13,  23,  14,  14,  14,   1,   8,   8,   1,
31822      &     8,   1,   8,   8,   1,   8,   1,   8,   1,   8,
31823      &     1,   1,   8,   1,   8,   8,   1,   1,   8,   8,
31824      &     1,   8,  25,  23,  13,  31,  23,  13,  16,  14,
31825      &    35,  34,  34,  33,  31,  14,  23,   0,   0,   0,
31826      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31827      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31828      &    13,  23,  14,   7,  16,  19,  14,   7,  23,  14  /
31829       DATA (NZK(K,2),K=341,510) /
31830      &    23,  14,   7,  13,  23,  13,  13,  23,  13,  23,
31831      &    14,  13,  14,  23,  14,  23,  13,  14,  23,  14,
31832      &    23,  16,  14,  23,  14,  23,  14,  13,  13,  23,
31833      &    13,  23,  14,  13,  23,  13,  23,  15,  13,  13,
31834      &    13,  23,  13,  13,  14,  14,  14,  14,  14,  23,
31835      &    13,  16,  25,  14,  15,  24,  23,  14,   7,  23,
31836      &     7,  13,  23,   7,  14,  23,   7,  23,   7,   7,
31837      &     7,   7,   7,  13,  23,  31,   3,  11,  14, 135,
31838      &     5, 134, 134, 134, 136,   6, 133, 133, 133,   0,
31839      &     0,   0,   0,  31,  95,  25,  15,  31,  95,  16,
31840      &    32,  32,  33,  35,  39,  39,  38,  25,  13,  39,
31841      &    32,  39,  38,  35,  32,  39,  13,  23,  14,   7,
31842      &     7,  25,  37,  32,  13,  25,  13,  25,  13,  25,
31843      &    13,  31,  95,  24,  16,  31,  24,  15,  34,  34,
31844      &    33,  35,  37,  37,  36,  24,  14,  37,  34,  37,
31845      &    36,  35,  34,  37,  14,  23,  13,   7,   7,  24,
31846      &    39,  34,  14,  24,  14,  24,  14,  24,  14,   7  /
31847       DATA (NZK(K,2),K=511,540) /
31848      &     7,   7,   7,   7,   7,   7,   7,   7,  25,  13,
31849      &    25,   7,   7,   7,   7,   7,   7,   7,   7,   7,
31850      &    24,  14,  24,  13,  14,  23,  13,  23,  14,  23  /
31851       DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
31852      & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
31853      & 14, 14, 23, 14, 16, 25,
31854      & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
31855      & 23, 13, 14, 23,  0 /
31856       DATA (NZK(K,3),K=  1,170) /
31857      &     0,   0,   0,   0,   0,   0,   0,   5,   6,   5,
31858      &     6,  23,  23,   5,   5,   0,   0,   0,   0,  14,
31859      &    23,   5,   5,   0,   0,  14,  23,   5,   5,   0,
31860      &     0,   5,   5,   0,   0,   5,   5,   0,   0,   0,
31861      &     0,   0,   0,   0,   3,   0,   7,  23,  23,   7,
31862      &     0,   0,   0,   0,  23,   0,   0,   0,   0,   0,
31863      &     110*0   /
31864       DATA (NZK(K,3),K=171,340) /
31865      &     80*0,
31866      &     0,   0,   0,   0,   0,   0,  23,  13,  14,  23,
31867      &    23,  14,  23,  23,  23,  14,  23,  13,  23,  14,
31868      &    13,  23,  13,  23,  14,  23,  14,  14,  23,  13,
31869      &    13,  23,  13,  14,  23,  23,  14,  23,  13,  23,
31870      &    14,  14,   0,   0,   0,   0,   0,   0,   0,   0,
31871      &     30*0,
31872      &    14,  23,   7,   0,   0,   0,  23,   0,   0,   0  /
31873       DATA (NZK(K,3),K=341,510) /
31874      &     30*0,
31875      &     0,   0,   0,   0,   0,   0,   0,   0,   0,  23,
31876      &    14,   0,  13,   0,  14,   0,   0,  23,  13,   0,
31877      &     0,  15,   0,   0,  16,   0,   0,   0,   0,   0,
31878      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31879      &     0,   0,   0,  14,  23,   0,   0,   0,  23, 134,
31880      &   134,   0,   0,   0, 133, 133,   0,   0,   0,   0,
31881      &     80*0  /
31882       DATA (NZK(K,3),K=511,540) /
31883      &     0,   0,   0,   0,   0,   0,   0,   0,  13,  13,
31884      &    25,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31885      &    14,  14,  24,   0,   0,   0,   0,   0,   0,   0  /
31886       DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
31887      & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
31888
31889       END
31890
31891 *$ CREATE DT_BDEVAP.FOR
31892 *COPY DT_BDEVAP
31893 *
31894 *=== bdevap ===========================================================*
31895 *
31896       BLOCK DATA DT_BDEVAP
31897
31898 C     INCLUDE '(DBLPRC)'
31899 * DBLPRC.ADD
31900       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31901       SAVE
31902 * (original name: GLOBAL)
31903       PARAMETER ( KALGNM = 2 )
31904       PARAMETER ( ANGLGB = 5.0D-16 )
31905       PARAMETER ( ANGLSQ = 2.5D-31 )
31906       PARAMETER ( AXCSSV = 0.2D+16 )
31907       PARAMETER ( ANDRFL = 1.0D-38 )
31908       PARAMETER ( AVRFLW = 1.0D+38 )
31909       PARAMETER ( AINFNT = 1.0D+30 )
31910       PARAMETER ( AZRZRZ = 1.0D-30 )
31911       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
31912       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
31913       PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
31914       PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
31915       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
31916       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
31917       PARAMETER ( CSNNRM = 2.0D-15 )
31918       PARAMETER ( DMXTRN = 1.0D+08 )
31919       PARAMETER ( ZERZER = 0.D+00 )
31920       PARAMETER ( ONEONE = 1.D+00 )
31921       PARAMETER ( TWOTWO = 2.D+00 )
31922       PARAMETER ( THRTHR = 3.D+00 )
31923       PARAMETER ( FOUFOU = 4.D+00 )
31924       PARAMETER ( FIVFIV = 5.D+00 )
31925       PARAMETER ( SIXSIX = 6.D+00 )
31926       PARAMETER ( SEVSEV = 7.D+00 )
31927       PARAMETER ( EIGEIG = 8.D+00 )
31928       PARAMETER ( ANINEN = 9.D+00 )
31929       PARAMETER ( TENTEN = 10.D+00 )
31930       PARAMETER ( HLFHLF = 0.5D+00 )
31931       PARAMETER ( ONETHI = ONEONE / THRTHR )
31932       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
31933       PARAMETER ( ONEFOU = ONEONE / FOUFOU )
31934       PARAMETER ( THRTWO = THRTHR / TWOTWO )
31935       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
31936       PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
31937       PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
31938       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
31939       PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
31940       PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
31941       PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
31942       PARAMETER ( EULERO = 0.577215664901532860606512      D+00 )
31943       PARAMETER ( EULEXP = 1.781072417990197985236504      D+00 )
31944       PARAMETER ( EULLOG =-0.5495393129816448223376619     D+00 )
31945       PARAMETER ( E1M2EU = 0.8569023337737540831433017     D+00 )
31946       PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
31947       PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
31948       PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
31949       PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
31950       PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
31951       PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
31952       PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
31953       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
31954       PARAMETER ( CLIGHT = 2.99792458         D+10 )
31955       PARAMETER ( AVOGAD = 6.0221367          D+23 )
31956       PARAMETER ( BOLTZM = 1.380658           D-23 )
31957       PARAMETER ( AMELGR = 9.1093897          D-28 )
31958       PARAMETER ( PLCKBR = 1.05457266         D-27 )
31959       PARAMETER ( ELCCGS = 4.8032068          D-10 )
31960       PARAMETER ( ELCMKS = 1.60217733         D-19 )
31961       PARAMETER ( AMUGRM = 1.6605402          D-24 )
31962       PARAMETER ( AMMUMU = 0.113428913        D+00 )
31963       PARAMETER ( AMPRMU = 1.007276470        D+00 )
31964       PARAMETER ( AMNEMU = 1.008664904        D+00 )
31965       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
31966       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
31967       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
31968       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
31969       PARAMETER ( PLABRC = 0.197327053        D+00 )
31970       PARAMETER ( AMELCT = 0.51099906         D-03 )
31971       PARAMETER ( AMUGEV = 0.93149432         D+00 )
31972       PARAMETER ( AMMUON = 0.105658389        D+00 )
31973       PARAMETER ( AMPRTN = 0.93827231         D+00 )
31974       PARAMETER ( AMNTRN = 0.93956563         D+00 )
31975       PARAMETER ( AMDEUT = 1.87561339         D+00 )
31976       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
31977      &                   * 1.D-09 )
31978       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
31979       PARAMETER ( BLTZMN = 8.617385           D-14 )
31980       PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
31981       PARAMETER ( GFOHB3 = 1.16639            D-05 )
31982       PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
31983       PARAMETER ( SIN2TW = 0.2319             D+00 )
31984       PARAMETER ( GEVMEV = 1.0                D+03 )
31985       PARAMETER ( EMVGEV = 1.0                D-03 )
31986       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
31987       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
31988       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
31989       LOGICAL LGBIAS, LGBANA
31990       COMMON /FKGLOB/ LGBIAS, LGBANA
31991 C     INCLUDE '(DIMPAR)'
31992 * DIMPAR.ADD
31993       PARAMETER ( MXXRGN = 5000 )
31994       PARAMETER ( MXXMDF = 82   )
31995       PARAMETER ( MXXMDE = 54   )
31996       PARAMETER ( MFSTCK = 1000 )
31997       PARAMETER ( MESTCK = 100  )
31998       PARAMETER ( NELEMX = 80   )
31999       PARAMETER ( MPDPDX = 8    )
32000       PARAMETER ( ICOMAX = 180  )
32001       PARAMETER ( NSTBIS = 304  )
32002       PARAMETER ( IDMAXP = 220  )
32003       PARAMETER ( IDMXDC = 640  )
32004       PARAMETER ( MKBMX1 = 1    )
32005       PARAMETER ( MKBMX2 = 1    )
32006 C     INCLUDE '(IOUNIT)'
32007 * IOUNIT.ADD
32008       PARAMETER ( LUNIN  =  5 )
32009       PARAMETER ( LUNOUT =  6 )
32010 **sr 19.5. set error output-unit from 15 to 6
32011       PARAMETER ( LUNERR = 6  )
32012       PARAMETER ( LUNBER = 14 )
32013       PARAMETER ( LUNECH =  8 )
32014       PARAMETER ( LUNFLU = 13 )
32015       PARAMETER ( LUNGEO = 16 )
32016       PARAMETER ( LUNPMF = 12 )
32017       PARAMETER ( LUNRAN =  2 )
32018       PARAMETER ( LUNXSC =  9 )
32019       PARAMETER ( LUNDET = 17 )
32020       PARAMETER ( LUNRAY = 10 )
32021       PARAMETER ( LUNRDB =  1 )
32022       PARAMETER ( LUNPGO =  7 )
32023       PARAMETER ( LUNPGS =  4 )
32024       PARAMETER ( LUNSCR =  3 )
32025 *
32026 *----------------------------------------------------------------------*
32027 *                                                                      *
32028 *     Block Data for the EVAPoration routines:                         *
32029 *                                                                      *
32030 *     Created on    20 may 1990    by    Alfredo Ferrari & Paola Sala  *
32031 *                                                   Infn - Milan       *
32032 *                                                                      *
32033 *     Modified from the original version of J.M.Zazula                 *
32034 *     and, for cookcm, from a LAHET block data kindly provided by      *
32035 *     R.E.Prael-LANL                                                   *
32036 *                                                                      *
32037 *     Last change on  20-feb-95    by    Alfredo Ferrari               *
32038 *                                                                      *
32039 *                                                                      *
32040 *----------------------------------------------------------------------*
32041 *
32042 * (original name: COOKCM)
32043       PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 )
32044       LOGICAL LDEFOZ, LDEFON
32045       PARAMETER ( INCOOK = 150, IZCOOK = 98 )
32046       COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN,
32047      &                SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK),
32048      &                PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK)
32049 * (original name: EVA0)
32050       COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
32051      *                FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
32052      *                CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
32053      *                T (4,7), RMASS (297), ALPH (297), BET (297),
32054      *                APRIME (250), IA (6), IZ (6)
32055 * (original name: HETTP)
32056       COMMON /FKHETP/  NHSTP,NBERTP,IOSUB,INSRS
32057 * (original name: HETC7)
32058       COMMON /FKHET7/ COSKS,SINKS, COSTH,SINTH, COSPHI,SINPHI
32059 * (original name: INPFLG)
32060       COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
32061 *
32062       DATA B0   / 8.D+00 /, Y0 / 1.5D+00 /
32063       DATA IANG / 1 /, IFISS / 1 /,  IB0 / 2 /, IGEOM / 0 /
32064       DATA ISTRAG /0/, KEYDK /0/
32065       DATA NBERTP /LUNBER/
32066       DATA COSTH /ONEONE/, SINTH /ZERZER/, COSPHI /ONEONE/,
32067      &     SINPHI/ZERZER/
32068 *  /cookcm/
32069        DATA ( PZCOOK(I),I =  1, IZCOOK ) /
32070      & 0.000D+00, 5.440D+00, 0.000D+00, 2.760D+00, 0.000D+00, 3.340D+00,
32071      & 0.000D+00, 2.700D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.460D+00,
32072      & 0.000D+00, 2.090D+00, 0.000D+00, 1.620D+00, 0.000D+00, 1.620D+00,
32073      & 0.000D+00, 1.830D+00, 0.000D+00, 1.730D+00, 0.000D+00, 1.350D+00,
32074      & 0.000D+00, 1.540D+00, 0.000D+00, 1.280D+00, 2.600D-01, 8.800D-01,
32075      & 1.900D-01, 1.350D+00,-5.000D-02, 1.520D+00,-9.000D-02, 1.170D+00,
32076      & 4.000D-02, 1.240D+00, 2.900D-01, 1.090D+00, 2.600D-01, 1.170D+00,
32077      & 2.300D-01, 1.150D+00,-8.000D-02, 1.350D+00, 3.400D-01, 1.050D+00,
32078      & 2.800D-01, 1.270D+00, 0.000D+00, 1.050D+00, 0.000D+00, 1.000D+00,
32079      & 9.000D-02, 1.200D+00, 2.000D-01, 1.400D+00, 9.300D-01, 1.000D+00,
32080      &-2.000D-01, 1.190D+00, 9.000D-02, 9.700D-01, 0.000D+00, 9.200D-01,
32081      & 1.100D-01, 6.800D-01, 5.000D-02, 6.800D-01,-2.200D-01, 7.900D-01,
32082      & 9.000D-02, 6.900D-01, 1.000D-02, 7.200D-01, 0.000D+00, 4.000D-01,
32083      & 1.600D-01, 7.300D-01, 0.000D+00, 4.600D-01, 1.700D-01, 8.900D-01,
32084      & 0.000D+00, 7.900D-01, 0.000D+00, 8.900D-01, 0.000D+00, 8.100D-01,
32085      &-6.000D-02, 6.900D-01,-2.000D-01, 7.100D-01,-1.200D-01, 7.200D-01,
32086      & 0.000D+00, 7.700D-01/
32087        DATA ( PNCOOK(I),I =  1, 90 ) /
32088      & 0.000D+00, 5.980D+00, 0.000D+00, 2.770D+00, 0.000D+00, 3.160D+00,
32089      & 0.000D+00, 3.010D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.670D+00,
32090      & 0.000D+00, 1.800D+00, 0.000D+00, 1.670D+00, 0.000D+00, 1.860D+00,
32091      & 0.000D+00, 2.040D+00, 0.000D+00, 1.640D+00, 0.000D+00, 1.440D+00,
32092      & 0.000D+00, 1.540D+00, 0.000D+00, 1.300D+00, 0.000D+00, 1.270D+00,
32093      & 0.000D+00, 1.290D+00, 8.000D-02, 1.410D+00,-8.000D-02, 1.500D+00,
32094      &-5.000D-02, 2.240D+00,-4.700D-01, 1.430D+00,-1.500D-01, 1.440D+00,
32095      & 6.000D-02, 1.560D+00, 2.500D-01, 1.570D+00,-1.600D-01, 1.460D+00,
32096      & 0.000D+00, 9.300D-01, 1.000D-02, 6.200D-01,-5.000D-01, 1.420D+00,
32097      & 1.300D-01, 1.520D+00,-6.500D-01, 8.000D-01,-8.000D-02, 1.290D+00,
32098      &-4.700D-01, 1.250D+00,-4.400D-01, 9.700D-01, 8.000D-02, 1.650D+00,
32099      &-1.100D-01, 1.260D+00,-4.600D-01, 1.060D+00, 2.200D-01, 1.550D+00,
32100      &-7.000D-02, 1.370D+00, 1.000D-01, 1.200D+00,-2.700D-01, 9.200D-01,
32101      &-3.500D-01, 1.190D+00, 0.000D+00, 1.050D+00,-2.500D-01, 1.610D+00,
32102      &-2.100D-01, 9.000D-01,-2.100D-01, 7.400D-01,-3.800D-01, 7.200D-01/
32103        DATA ( PNCOOK(I),I = 91, INCOOK ) /
32104      &-3.400D-01, 9.200D-01,-2.600D-01, 9.400D-01, 1.000D-02, 6.500D-01,
32105      &-3.600D-01, 8.300D-01, 1.100D-01, 6.700D-01, 5.000D-02, 1.000D+00,
32106      & 5.100D-01, 1.040D+00, 3.300D-01, 6.800D-01,-2.700D-01, 8.100D-01,
32107      & 9.000D-02, 7.500D-01, 1.700D-01, 8.600D-01, 1.400D-01, 1.100D+00,
32108      &-2.200D-01, 8.400D-01,-4.700D-01, 4.800D-01, 2.000D-02, 8.800D-01,
32109      & 2.400D-01, 5.200D-01, 2.700D-01, 4.100D-01,-5.000D-02, 3.800D-01,
32110      & 1.500D-01, 6.700D-01, 0.000D+00, 6.100D-01, 0.000D+00, 7.800D-01,
32111      & 0.000D+00, 6.700D-01, 0.000D+00, 6.700D-01, 0.000D+00, 7.900D-01,
32112      & 0.000D+00, 6.000D-01, 4.000D-02, 6.400D-01,-6.000D-02, 4.500D-01,
32113      & 5.000D-02, 2.600D-01,-2.200D-01, 3.900D-01, 0.000D+00, 3.900D-01/
32114        DATA ( SZCOOK(I),I =  1, 98) /
32115      & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
32116      & 0.000D+00, 0.000D+00,-1.100D-01,-8.100D-01,-2.910D+00,-4.170D+00,
32117      &-5.720D+00,-7.800D+00,-8.970D+00,-9.700D+00,-1.010D+01,-1.070D+01,
32118      &-1.138D+01,-1.207D+01,-1.255D+01,-1.324D+01,-1.393D+01,-1.471D+01,
32119      &-1.553D+01,-1.637D+01,-1.736D+01,-1.860D+01,-1.870D+01,-1.801D+01,
32120      &-1.787D+01,-1.708D+01,-1.660D+01,-1.675D+01,-1.650D+01,-1.635D+01,
32121      &-1.622D+01,-1.641D+01,-1.689D+01,-1.643D+01,-1.668D+01,-1.673D+01,
32122      &-1.745D+01,-1.729D+01,-1.744D+01,-1.782D+01,-1.862D+01,-1.827D+01,
32123      &-1.939D+01,-1.991D+01,-1.914D+01,-1.826D+01,-1.740D+01,-1.642D+01,
32124      &-1.577D+01,-1.437D+01,-1.391D+01,-1.310D+01,-1.311D+01,-1.143D+01,
32125      &-1.089D+01,-1.075D+01,-1.062D+01,-1.041D+01,-1.021D+01,-9.850D+00,
32126      &-9.470D+00,-9.030D+00,-8.610D+00,-8.130D+00,-7.460D+00,-7.480D+00,
32127      &-7.200D+00,-7.130D+00,-7.060D+00,-6.780D+00,-6.640D+00,-6.640D+00,
32128      &-7.680D+00,-7.890D+00,-8.410D+00,-8.490D+00,-7.880D+00,-6.300D+00,
32129      &-5.470D+00,-4.780D+00,-4.370D+00,-4.170D+00,-4.130D+00,-4.320D+00,
32130      &-4.550D+00,-5.040D+00,-5.280D+00,-6.060D+00,-6.280D+00,-6.870D+00,
32131      &-7.200D+00,-7.740D+00/
32132        DATA ( SNCOOK(I),I =  1, 90 ) /
32133      & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
32134      & 0.000D+00, 0.000D+00, 1.030D+01, 5.660D+00, 6.800D+00, 7.530D+00,
32135      & 7.550D+00, 7.210D+00, 7.440D+00, 8.070D+00, 8.940D+00, 9.810D+00,
32136      & 1.060D+01, 1.139D+01, 1.254D+01, 1.368D+01, 1.434D+01, 1.419D+01,
32137      & 1.383D+01, 1.350D+01, 1.300D+01, 1.213D+01, 1.260D+01, 1.326D+01,
32138      & 1.413D+01, 1.492D+01, 1.552D+01, 1.638D+01, 1.716D+01, 1.755D+01,
32139      & 1.803D+01, 1.759D+01, 1.903D+01, 1.871D+01, 1.880D+01, 1.899D+01,
32140      & 1.846D+01, 1.825D+01, 1.776D+01, 1.738D+01, 1.672D+01, 1.562D+01,
32141      & 1.438D+01, 1.288D+01, 1.323D+01, 1.381D+01, 1.490D+01, 1.486D+01,
32142      & 1.576D+01, 1.620D+01, 1.762D+01, 1.773D+01, 1.816D+01, 1.867D+01,
32143      & 1.969D+01, 1.951D+01, 2.017D+01, 1.948D+01, 1.998D+01, 1.983D+01,
32144      & 2.020D+01, 1.972D+01, 1.987D+01, 1.924D+01, 1.844D+01, 1.761D+01,
32145      & 1.710D+01, 1.616D+01, 1.590D+01, 1.533D+01, 1.476D+01, 1.354D+01,
32146      & 1.263D+01, 1.065D+01, 1.010D+01, 8.890D+00, 1.025D+01, 9.790D+00,
32147      & 1.139D+01, 1.172D+01, 1.243D+01, 1.296D+01, 1.343D+01, 1.337D+01/
32148        DATA ( SNCOOK(I),I = 91, INCOOK ) /
32149      & 1.296D+01, 1.211D+01, 1.192D+01, 1.100D+01, 1.080D+01, 1.042D+01,
32150      & 1.039D+01, 9.690D+00, 9.270D+00, 8.930D+00, 8.570D+00, 8.020D+00,
32151      & 7.590D+00, 7.330D+00, 7.230D+00, 7.050D+00, 7.420D+00, 6.750D+00,
32152      & 6.600D+00, 6.380D+00, 6.360D+00, 6.490D+00, 6.250D+00, 5.850D+00,
32153      & 5.480D+00, 4.530D+00, 4.300D+00, 3.390D+00, 2.350D+00, 1.660D+00,
32154      & 8.100D-01, 4.600D-01,-9.600D-01,-1.690D+00,-2.530D+00,-3.160D+00,
32155      &-1.870D+00,-4.100D-01, 7.100D-01, 1.660D+00, 2.620D+00, 3.220D+00,
32156      & 3.760D+00, 4.100D+00, 4.460D+00, 4.830D+00, 5.090D+00, 5.180D+00,
32157      & 5.170D+00, 5.100D+00, 5.010D+00, 4.970D+00, 5.090D+00, 5.030D+00,
32158      & 4.930D+00, 5.280D+00, 5.490D+00, 5.500D+00, 5.370D+00, 5.300D+00/
32159       DATA LDEFOZ / 53*.FALSE.,25*.TRUE.,7*.FALSE.,13*.TRUE. /
32160       DATA LDEFON / 85*.FALSE.,37*.TRUE.,7*.FALSE.,21*.TRUE. /
32161 *=== End of Block Data Bdevap =========================================*
32162       END
32163
32164 *$ CREATE DT_BDNOPT.FOR
32165 *COPY DT_BDNOPT
32166 *
32167 *=== bdnopt ===========================================================*
32168 *==                                                                    *
32169       BLOCK DATA DT_BDNOPT
32170
32171 C     INCLUDE '(DBLPRC)'
32172 * DBLPRC.ADD
32173       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32174       SAVE
32175 * (original name: GLOBAL)
32176       PARAMETER ( KALGNM = 2 )
32177       PARAMETER ( ANGLGB = 5.0D-16 )
32178       PARAMETER ( ANGLSQ = 2.5D-31 )
32179       PARAMETER ( AXCSSV = 0.2D+16 )
32180       PARAMETER ( ANDRFL = 1.0D-38 )
32181       PARAMETER ( AVRFLW = 1.0D+38 )
32182       PARAMETER ( AINFNT = 1.0D+30 )
32183       PARAMETER ( AZRZRZ = 1.0D-30 )
32184       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
32185       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
32186       PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
32187       PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
32188       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
32189       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
32190       PARAMETER ( CSNNRM = 2.0D-15 )
32191       PARAMETER ( DMXTRN = 1.0D+08 )
32192       PARAMETER ( ZERZER = 0.D+00 )
32193       PARAMETER ( ONEONE = 1.D+00 )
32194       PARAMETER ( TWOTWO = 2.D+00 )
32195       PARAMETER ( THRTHR = 3.D+00 )
32196       PARAMETER ( FOUFOU = 4.D+00 )
32197       PARAMETER ( FIVFIV = 5.D+00 )
32198       PARAMETER ( SIXSIX = 6.D+00 )
32199       PARAMETER ( SEVSEV = 7.D+00 )
32200       PARAMETER ( EIGEIG = 8.D+00 )
32201       PARAMETER ( ANINEN = 9.D+00 )
32202       PARAMETER ( TENTEN = 10.D+00 )
32203       PARAMETER ( HLFHLF = 0.5D+00 )
32204       PARAMETER ( ONETHI = ONEONE / THRTHR )
32205       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
32206       PARAMETER ( ONEFOU = ONEONE / FOUFOU )
32207       PARAMETER ( THRTWO = THRTHR / TWOTWO )
32208       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
32209       PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
32210       PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
32211       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
32212       PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
32213       PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
32214       PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
32215       PARAMETER ( EULERO = 0.577215664901532860606512      D+00 )
32216       PARAMETER ( EULEXP = 1.781072417990197985236504      D+00 )
32217       PARAMETER ( EULLOG =-0.5495393129816448223376619     D+00 )
32218       PARAMETER ( E1M2EU = 0.8569023337737540831433017     D+00 )
32219       PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
32220       PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
32221       PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
32222       PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
32223       PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
32224       PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
32225       PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
32226       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
32227       PARAMETER ( CLIGHT = 2.99792458         D+10 )
32228       PARAMETER ( AVOGAD = 6.0221367          D+23 )
32229       PARAMETER ( BOLTZM = 1.380658           D-23 )
32230       PARAMETER ( AMELGR = 9.1093897          D-28 )
32231       PARAMETER ( PLCKBR = 1.05457266         D-27 )
32232       PARAMETER ( ELCCGS = 4.8032068          D-10 )
32233       PARAMETER ( ELCMKS = 1.60217733         D-19 )
32234       PARAMETER ( AMUGRM = 1.6605402          D-24 )
32235       PARAMETER ( AMMUMU = 0.113428913        D+00 )
32236       PARAMETER ( AMPRMU = 1.007276470        D+00 )
32237       PARAMETER ( AMNEMU = 1.008664904        D+00 )
32238       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
32239       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
32240       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
32241       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
32242       PARAMETER ( PLABRC = 0.197327053        D+00 )
32243       PARAMETER ( AMELCT = 0.51099906         D-03 )
32244       PARAMETER ( AMUGEV = 0.93149432         D+00 )
32245       PARAMETER ( AMMUON = 0.105658389        D+00 )
32246       PARAMETER ( AMPRTN = 0.93827231         D+00 )
32247       PARAMETER ( AMNTRN = 0.93956563         D+00 )
32248       PARAMETER ( AMDEUT = 1.87561339         D+00 )
32249       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
32250      &                   * 1.D-09 )
32251       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
32252       PARAMETER ( BLTZMN = 8.617385           D-14 )
32253       PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
32254       PARAMETER ( GFOHB3 = 1.16639            D-05 )
32255       PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
32256       PARAMETER ( SIN2TW = 0.2319             D+00 )
32257       PARAMETER ( GEVMEV = 1.0                D+03 )
32258       PARAMETER ( EMVGEV = 1.0                D-03 )
32259       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
32260       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
32261       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
32262       LOGICAL LGBIAS, LGBANA
32263       COMMON /FKGLOB/ LGBIAS, LGBANA
32264 C     INCLUDE '(DIMPAR)'
32265 * DIMPAR.ADD
32266       PARAMETER ( MXXRGN = 5000 )
32267       PARAMETER ( MXXMDF = 82   )
32268       PARAMETER ( MXXMDE = 54   )
32269       PARAMETER ( MFSTCK = 1000 )
32270       PARAMETER ( MESTCK = 100  )
32271       PARAMETER ( NELEMX = 80   )
32272       PARAMETER ( MPDPDX = 8    )
32273       PARAMETER ( ICOMAX = 180  )
32274       PARAMETER ( NSTBIS = 304  )
32275       PARAMETER ( IDMAXP = 220  )
32276       PARAMETER ( IDMXDC = 640  )
32277       PARAMETER ( MKBMX1 = 1    )
32278       PARAMETER ( MKBMX2 = 1    )
32279 C     INCLUDE '(IOUNIT)'
32280 * IOUNIT.ADD
32281       PARAMETER ( LUNIN  =  5 )
32282       PARAMETER ( LUNOUT =  6 )
32283 **sr 19.5. set error output-unit from 15 to 6
32284       PARAMETER ( LUNERR = 6  )
32285       PARAMETER ( LUNBER = 14 )
32286       PARAMETER ( LUNECH =  8 )
32287       PARAMETER ( LUNFLU = 13 )
32288       PARAMETER ( LUNGEO = 16 )
32289       PARAMETER ( LUNPMF = 12 )
32290       PARAMETER ( LUNRAN =  2 )
32291       PARAMETER ( LUNXSC =  9 )
32292       PARAMETER ( LUNDET = 17 )
32293       PARAMETER ( LUNRAY = 10 )
32294       PARAMETER ( LUNRDB =  1 )
32295       PARAMETER ( LUNPGO =  7 )
32296       PARAMETER ( LUNPGS =  4 )
32297       PARAMETER ( LUNSCR =  3 )
32298 *
32299 *----------------------------------------------------------------------*
32300 *                                                                      *
32301 *   Created on  20 september 1989    by  Alfredo Ferrari - Infn Milan  *
32302 *                                                                      *
32303 *         Last change on 20-apr-95   by  Alfredo Ferrari               *
32304 *                                                                      *
32305 *----------------------------------------------------------------------*
32306 *
32307 C     INCLUDE '(BLNKCM)'
32308 * BLNKCM.ADD
32309 **sr 17.5. commented since not used here
32310 C     PARAMETER ( NBLNMX = 1100000 )
32311 C     DIMENSION GMSTOR ( NBLNMX ), BRMBRR ( NBLNMX ), BRMEXP ( NBLNMX ),
32312 C    &          BRMSIG ( NBLNMX ), SIGGTT ( KALGNM*NBLNMX ),
32313 C    &          COMSCO ( NBLNMX ), LBSTOR ( KALGNM*NBLNMX )
32314 C     REAL SIGGTT
32315 C     LOGICAL LBSTOR
32316 C     COMMON   NSTOR  ( KALGNM*NBLNMX )
32317 **
32318 **sr 18.5. commented since not used for evap.
32319 C     COMMON / ADDRCM / MBLNMX, KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST,
32320 C    &                  KISBGN, KISLST, KDTBGN, KDTLST, KUBBGN, KUBLST,
32321 C    &                  KUXBGN, KUXLST, KTCBGN, KTCLST, KRNBGN, KRNLST,
32322 C    &                  KYLBGN, KYLLST, KXSBGN, KXSLST, KIHBGN, KIHLST,
32323 C    &                  KINBGN, KINLST, KIEBGN, KIELST, KETBGN, KETLST,
32324 C    &                  KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST,
32325 C    &                  KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST,
32326 C    &                  KWLBGN, KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST,
32327 C    &                  KWSBGN, KWSLST, KNDBGN, KNDLST, KDPBGN, KDPLST,
32328 C    &                  KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN, KBRLST,
32329 C    &                  KTMBGN
32330 **
32331
32332 C     EQUIVALENCE ( NSTOR (1), GMSTOR (1) )
32333 C     EQUIVALENCE ( NSTOR (1), BRMBRR (1) )
32334 C     EQUIVALENCE ( NSTOR (1), BRMEXP (1) )
32335 C     EQUIVALENCE ( NSTOR (1), BRMSIG (1) )
32336 C     EQUIVALENCE ( NSTOR (1), COMSCO (1) )
32337 C     EQUIVALENCE ( NSTOR (1), SIGGTT (1) )
32338 C     EQUIVALENCE ( NSTOR (1), LBSTOR (1) )
32339 C     INCLUDE '(BLNTMP)'
32340 * BLNTMP.ADD
32341 **sr 18.5. commented since not used for evap.
32342 C     COMMON / BLNTMP / KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM,
32343 C    &                  KGCBTM, KGDWTM, KBDWTM, KWLOTM, KWHITM, KWMUTM,
32344 C    &                  KWSHTM, KEXTTM, KSTXTM, KSTNTM, KECTTM, KPCTTM,
32345 C    &                  KLPBTM, NXXRGN
32346 **
32347 C     INCLUDE '(CMMDNR)'
32348 * CMMDNR.ADD
32349 **sr 18.5. commented since not used for evap.
32350 C     LOGICAL LFLDNR
32351 C     COMMON / CMMDNR / DDNEAR, LFLDNR
32352 **
32353 C     INCLUDE '(CTITLE)'
32354 * CTITLE.ADD
32355 **sr 18.5. commented since not used for evap.
32356 C     CHARACTER RUNTIT*80, RUNTIM*32, RUNKEY*10
32357 C     COMMON / CTITLE / RUNTIT, RUNTIM, RUNKEY
32358 C     COMMON / CEXPCK / ITEXPI, ITEXMX
32359 **
32360 C     INCLUDE '(DETECT)'
32361 * DETECT.ADD
32362 **sr 18.5. commented since not used for evap.
32363 C     PARAMETER (NRGNMX = 10)
32364 C     PARAMETER (NDTCMX = 10)
32365 C     PARAMETER (NSCRMX = 10)
32366 C     PARAMETER (NDTBIN = 1024)
32367 C     CHARACTER*10 TITDET,TITSCO
32368 C     LOGICAL LDTCTR
32369 C     COMMON /DETCT/  EDTMIN(NDTCMX), EDTBIN(NDTCMX), EDTCUT(NDTCMX),
32370 C    &                KDTREG(NRGNMX,NDTCMX), KDTDET(NDTCMX,NSCRMX),
32371 C    &                NDTSCO, NDTDET, LDTCTR, IDTREG(MXXRGN),
32372 C    &                KDTSCD(NSCRMX)
32373 C     COMMON /DETCH/  TITDET(NDTCMX), TITSCO(NSCRMX)
32374 **
32375 C     INCLUDE '(DETLOC)'
32376 * DETLOC.ADD
32377 **sr 18.5. commented since not used for evap.
32378 C     PARAMETER (NDTCM2 = 10)
32379 C     COMMON /DETLOC/ ACCUMP (NDTCM2), ACCUMN (NDTCM2),
32380 C    &                ICOINC(NDTCM2), NCLAS
32381 **
32382 C     INCLUDE '(EMGTRN)'
32383 * EMGTRN.ADD
32384 **sr 18.5. commented since not used for evap.
32385 C     LOGICAL LMCSMG
32386 C     COMMON / EMGTRN / UMCSMG, VMCSMG, WMCSMG, LMCSMG
32387 **
32388 C     INCLUDE '(EMSHO)'
32389 * EMSHO.ADD
32390 **sr 18.5. commented since not used for evap.
32391 C     LOGICAL EMFLO, EMFHLO, EMFELO, LIMPRE, LEXPTE
32392 C     COMMON /EMSHO/ EMFETH, EMFPTH, EMFHET, EMFHPT, EMFBIA, EMFLO,
32393 C    &               EMFHLO, EMFELO, LIMPRE, LEXPTE
32394 **
32395 C     INCLUDE '(EPISOR)'
32396 * EPISOR.ADD
32397 **sr 18.5. commented since not used for evap.
32398 C     LOGICAL LUSSRC
32399 C     COMMON/EPISOR/TKESUM,LUSSRC
32400 **
32401 * (original name: FHEAVY,FHEAVC)
32402       PARAMETER ( MXHEAV = 100 )
32403       CHARACTER*8 ANHEAV
32404       COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
32405      &                CZHEAV (MXHEAV), TKHEAV (MXHEAV),
32406      &                PHEAVY (MXHEAV), WHEAVY (MXHEAV),
32407      &                AMHEAV  ( 12 ) , AMNHEA  ( 12 ) ,
32408      &                KHEAVY (MXHEAV), ICHEAV  ( 12 ) ,
32409      &                IBHEAV  ( 12 ) , NPHEAV
32410       COMMON /FKFHVC/ ANHEAV  ( 12 )
32411 * (original name: FINUC)
32412       PARAMETER (MXP=999)
32413       COMMON /FKFINU/ CXR    (MXP), CYR    (MXP), CZR    (MXP),
32414      &                CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
32415      &                TKI    (MXP), PLR    (MXP), WEI    (MXP),
32416      &                TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
32417      &                KPART  (MXP)
32418 C     INCLUDE '(GENTHR)'
32419 * GENTHR.ADD
32420 **sr 18.5. commented since not used for evap.
32421 C     COMMON / GENTHR / PEANCT, PEAPIT, PLDNCT, PTHRSH (NALLWP),
32422 C    &                  PTHDFF (NALLWP), IJNUCR (NALLWP)
32423 **
32424 C     INCLUDE '(LOWNEU)'
32425 * LOWNEU.ADD
32426 **sr 18.5. commented since not used for evap.
32427 C     PARAMETER ( MXGTHN =  15 )
32428 C     PARAMETER ( MXGLWN = 200 )
32429 C     PARAMETER ( MXSHPP =   5 )
32430 C     LOGICAL LCOMPN, LIMPRN, LBIASN, LDOWNN, LRECPR, LLOWWW, LLOWET
32431 C     CHARACTER*10 TITLOW
32432 C     COMMON / LOWNEU / ATOLOW (MXXMDF), WSHPLN (MXGLWN,MXSHPP), EXTWWL,
32433 C    &                  SHPIMP (MXGLWN), EXTETL (MXGLWN), WWAMFL,
32434 C    &                  VLLNTH (MXGTHN,MXXMDF), ABLNTH (MXGTHN,MXXMDF),
32435 C    &                  STLNTH (MXGTHN,MXXMDF), TMRTLN (MXXMDF),
32436 C    &                  TMNMLN (MXXMDF), ICHCPT (MXXMDF),
32437 C    &                  IGTMRT (MXXMDF), NEUMED (MXXMDF),
32438 C    &                  ID1MED (MXXMDF), ID2MED (MXXMDF),
32439 C    &                  ID3MED (MXXMDF), MGTMED (MXXMDF),
32440 C    &                  LCOMPN (MXXMDF), LRECPR (MXXMDF), KPRLOW, NMGP,
32441 C    &                  NMTG  , IGRTHN, LIMPRN, LBIASN, LDOWNN, LLOWWW,
32442 C    &                  LLOWET, ICLMED, IKRBGN, INABGN, IDWBGN, IETBGN,
32443 C    &                  I0XSEC, IDXSEC, ISENAV, ISVELN, ISPNAV, IWWLWB,
32444 C    &                  IWWLWT, IPXBGN, NPXSEC
32445 C     COMMON / CHLWNT / TITLOW (MXXMDF)
32446 **
32447 C     INCLUDE '(LTCLCM)'
32448 * LTCLCM.ADD
32449 **sr 18.5. commented since not used for evap.
32450 C     COMMON / LTCLCM / MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1
32451 **
32452 C     INCLUDE '(MULBOU)'
32453 * MULBOU.ADD
32454 **sr 18.5. commented since not used for evap.
32455 C     LOGICAL LLDA  , LAGAIN, LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR
32456 C     COMMON / MULBOU / UOLD  , VOLD  , WOLD  , UMAG  , VMAG  , WMAG  ,
32457 C    &                  UNORML, VNORML, WNORML, USENSE, VSENSE, WSENSE,
32458 C    &                  TSENSE, DDSENS, DSMALL, NSSENS, LLDA  , LAGAIN,
32459 C    &                  LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR
32460 **
32461 C     INCLUDE '(MULHD)'
32462 * MULHD.ADD
32463 **sr 18.5. commented since not used for evap.
32464 C     PARAMETER ( MXXPT1 = 1 )
32465 C     PARAMETER ( TIMESS = 2.00D+00 )
32466 C     PARAMETER ( TMSRLX = 1.50D+00 )
32467 C     PARAMETER ( EPSINS = 0.15D+00 )
32468 C     PARAMETER ( EPSRLX = 0.50D+00 )
32469 C     PARAMETER ( SQEPSN = 0.3872983346207417 D+00 )
32470 C     PARAMETER ( SQEPSR = 0.7071067811865475 D+00 )
32471 C     PARAMETER ( PARNSI = 1.732050807568877 D+00 * SQEPSN )
32472 C     PARAMETER ( PRNSR0 = 1.732050807568877 D+00 * SQEPSR )
32473 C     PARAMETER ( R0NCMS = 1.20 D+00 )
32474 C     LOGICAL LTOPT, LSRCRH, LNSCRH
32475 C     COMMON / MULHD / BLCC   ( MXXMDF ), BLCCRA ( MXXMDF ),
32476 C    &                 XCC    ( MXXMDF ), ZTILDE ( MXXMDF, 0:MXXPT1 ),
32477 C    &                 ALPZTL ( MXXMDF, 0:MXXPT1 ), RLDU   ( MXXMDF ),
32478 C    &                 ALPZT2 ( MXXMDF, 0:MXXPT1 ), TEFF0  ( MXXMDF ),
32479 C    &                 XR0    ( MXXMDF ), ECUTM  ( MXXMDF, 39, 2 ),
32480 C    &                 ESTEPF ( MXXMDF ), HTHNSZ ( MXXMDF, 39 ),
32481 C    &                 AE1O3  ( MXXMDF ), PARNSR ( MXXMDF ),
32482 C    &                 HEESLI ( MXXMDF ), THMSPR, THMSSC, HMSAMP,
32483 C    &                 HMREJE, LSRCRH ( MXXMDF ), LNSCRH ( MXXMDF ),
32484 C    &                 LTOPT  ( MXXMDF ), NFSCAT
32485 **
32486 * (original name: PAREVT)
32487       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
32488      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
32489       PARAMETER ( NALLWP = 39   )
32490       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
32491      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
32492      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
32493      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
32494 * (original name: RESNUC)
32495       LOGICAL LRNFSS, LFRAGM
32496       COMMON /FKRESN/  AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
32497      &                   ANOW,   ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
32498      &                   ERES,  EKRES, AMNRES, AMMRES,  PTRES,  PXRES,
32499      &                  PYRES,  PZRES, PTRES2,  KTARP,  KTARN, IGREYP,
32500      &                 IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
32501      &                  ICRES,  IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
32502      &                 IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
32503      &                  IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
32504      &                 LFRAGM
32505 C     INCLUDE '(SCOHLP)'
32506 * SCOHLP.ADD
32507 **sr 18.5. commented since not used for evap.
32508 C     LOGICAL LSCZER
32509 C     COMMON / SCOHLP / ISCRNG, JSCRNG, LSCZER
32510 **
32511 C     INCLUDE '(TRACKR)'
32512 * TRACKR.ADD
32513 **sr 18.5. commented since not used for evap.
32514 C     PARAMETER ( MXTRCK = 2500 )
32515 C     LOGICAL LFSSSC
32516 C     COMMON / TRACKR /  XTRACK ( 0:MXTRCK ), YTRACK ( 0:MXTRCK ),
32517 C    &                   ZTRACK ( 0:MXTRCK ), TTRACK   ( MXTRCK ),
32518 C    &                   DTRACK   ( MXTRCK ), ETRACK, PTRACK, WTRACK,
32519 C    &                   ATRACK, CTRACK, AKSHRT, AKLONG, WSCRNG,
32520 C    &                   NTRACK, MTRACK, JTRACK, KTRACK, MMTRCK,
32521 C    &                   LT1TRK, LT2TRK, LTRACK, LLOUSE, LFSSSC
32522 **
32523 C     INCLUDE '(USRBDX)'
32524 * USRBDX.ADD
32525 **sr 18.5. commented since not used for evap.
32526 C     PARAMETER ( MXUSBX = 600 )
32527 C     LOGICAL LUSBDX, LFUSBX, LWUSBX, LLNUSX
32528 C     CHARACTER*10 TITUSX
32529 C     COMMON /USRBX/  EBXLOW(MXUSBX), EBXHGH(MXUSBX), ABXLOW(MXUSBX),
32530 C    &                ABXHGH(MXUSBX), DEBXBN(MXUSBX), DABXBN(MXUSBX),
32531 C    &                AUSBDX(MXUSBX),
32532 C    &                NEBXBN(MXUSBX), NABXBN(MXUSBX), NR1USX(MXUSBX),
32533 C    &                NR2USX(MXUSBX), ITUSBX(MXUSBX), IDUSBX(MXUSBX),
32534 C    &                KBUSBX(MXUSBX), IPUSBX(MXUSBX), IGMUSX(MXUSBX),
32535 C    &                LFUSBX(MXUSBX), LWUSBX(MXUSBX), LLNUSX(MXUSBX),
32536 C    &                NUSRBX, LUSBDX
32537 C     COMMON /USXCH/  TITUSX(MXUSBX)
32538 **
32539 C     INCLUDE '(USRBIN)'
32540 * USRBIN.ADD
32541 **sr 18.5. commented since not used for evap.
32542 C     PARAMETER ( MXUSBN = 100 )
32543 C     LOGICAL LUSBIN, LEVTBN, LNTZER, LUSEVT, LUSTKB, LTRKBN
32544 C     CHARACTER*10 TITUSB
32545 C     COMMON /USRBN/  XLOW  (MXUSBN), XHIGH (MXUSBN), YLOW  (MXUSBN),
32546 C    &                YHIGH (MXUSBN), ZLOW  (MXUSBN), ZHIGH (MXUSBN),
32547 C    &                DXUSBN(MXUSBN), DYUSBN(MXUSBN), DZUSBN(MXUSBN),
32548 C    &                TCUSBN(MXUSBN), BKUSBN(MXUSBN), B2USBN(MXUSBN),
32549 C    &                NXBIN (MXUSBN), NYBIN (MXUSBN), NZBIN (MXUSBN),
32550 C    &                ITUSBN(MXUSBN), IDUSBN(MXUSBN), KBUSBN(MXUSBN),
32551 C    &                IPUSBN(MXUSBN), LEVTBN(MXUSBN), LNTZER(MXUSBN),
32552 C    &                LTRKBN(MXUSBN), NUSRBN, LUSBIN, LUSEVT, LUSTKB
32553 C     COMMON /USRCH/  TITUSB(MXUSBN)
32554 **
32555 C     INCLUDE '(USRSNC)'
32556 * USRSNC.ADD
32557 **sr 18.5. commented since not used for evap.
32558 C     PARAMETER ( MXRSNC = 400 )
32559 C     PARAMETER ( NMZMIN =  -5 )
32560 C     LOGICAL LURSNC
32561 C     CHARACTER*10 TIURSN
32562 C     COMMON /USRSNC/  VURSNC(MXRSNC), IZRHGH(MXRSNC), IMRHGH(MXRSNC),
32563 C    &                 NRURSN(MXRSNC), ITURSN(MXRSNC), KBURSN(MXRSNC),
32564 C    &                 IPURSN(MXRSNC), NURSNC, LURSNC
32565 C     COMMON /USRSCH/  TIURSN(MXRSNC)
32566 C     INCLUDE '(USRTRC)'
32567 * USRTRC.ADD
32568 **sr 18.5. commented since not used for evap.
32569 C     PARAMETER ( MXUSTC = 400 )
32570 C     LOGICAL LUSRTC, LUSTRK, LUSCLL, LLNUTC
32571 C     CHARACTER*10 TITUTC
32572 C     COMMON /USRTC/  ETCLOW(MXUSTC), ETCHGH(MXUSTC), DETCBN(MXUSTC),
32573 C    &                VUSRTC(MXUSTC),
32574 C    &                IUSTRK(MXUSTC), IUSCLL(MXUSTC), NETCBN(MXUSTC),
32575 C    &                NRUSTC(MXUSTC), ITUSTC(MXUSTC), IDUSTC(MXUSTC),
32576 C    &                KBUSTC(MXUSTC), IPUSTC(MXUSTC), IGMUTC(MXUSTC),
32577 C    &                LLNUTC(MXUSTC), NUSRTC, NUSTRK, NUSCLL, LUSRTC,
32578 C    &                LUSTRK, LUSCLL
32579 C     COMMON /USTCH/  TITUTC(MXUSTC)
32580 **
32581 C     INCLUDE '(USRYLD)'
32582 * USRYLD.ADD
32583 **sr 18.5. commented since not used for evap.
32584 C     PARAMETER ( MXUSYL = 500 )
32585 C     LOGICAL LUSRYL, LLNUYL, LSCUYL
32586 C     CHARACTER*10 TITUYL
32587 C     COMMON /USRYL/  EYLLOW(MXUSYL), EYLHGH(MXUSYL), DEYLBN(MXUSYL),
32588 C    &                USNRYL(MXUSYL), SGUSYL(MXUSYL), AYLLOW(MXUSYL),
32589 C    &                AYLHGH(MXUSYL), PUSRYL, UUSRYL, VUSRYL, WUSRYL,
32590 C    &                ETXUYL, ETYUYL, ETZUYL, GAMUYL, SQSUYL, UCMUYL,
32591 C    &                VCMUYL, WCMUYL, IJUSYL, JTUSYL,
32592 C    &                NEYLBN(MXUSYL), NR1UYL(MXUSYL), NR2UYL(MXUSYL),
32593 C    &                IXUSYL(MXUSYL), ITUSYL(MXUSYL), IDUSYL(MXUSYL),
32594 C    &                KBUSYL(MXUSYL), IPUSYL(MXUSYL), IGMUYL(MXUSYL),
32595 C    &                IEUSYL(MXUSYL), IAUSYL(MXUSYL), LLNUYL(MXUSYL),
32596 C    &                NUSRYL, LUSRYL, LSCUYL
32597 C     COMMON /USYCH/  TITUYL(MXUSYL)
32598 **
32599 C     INCLUDE '(WWINDW)'
32600 * WWINDW.ADD
32601 **sr 18.5. commented since not used for evap.
32602 C     PARAMETER ( MXWWSP = 3 )
32603 C     PARAMETER ( WWSPMX = 50.D+00 )
32604 C     LOGICAL LWWNDW, LWWPRM
32605 C     COMMON / WWINDW / ETHWW1 (NALLWP), ETHWW2 (NALLWP),
32606 C    &                  WWEXWD (NALLWP), EXTWWN (NALLWP),
32607 C    &                  IWLBGN, IWHBGN, IWMBGN, LWWNDW, LWWPRM
32608 **
32609
32610 * /blnkcm/
32611 * *** If blank common dimension has to be superseded substitute in the
32612 * *** following two lines the new dimension in real*8 units to Nblnmx
32613 **sr 18.5. commented since not used for evap.
32614 C     PARAMETER (MXDUMM = KALGNM * NBLNMX)
32615 C     DATA KTMBGN / NBLNMX /
32616 C     DATA MBLNMX / MXDUMM /
32617 C     DATA KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST, KISBGN, KISLST,
32618 C    &     KDTBGN, KDTLST, KUBBGN, KUBLST, KUXBGN, KUXLST, KTCBGN,
32619 C    &     KTCLST, KRNBGN, KRNLST, KYLBGN, KYLLST, KXSBGN, KXSLST,
32620 C    &     KIHBGN, KIHLST, KINBGN, KINLST, KIEBGN, KIELST, KETBGN,
32621 C    &     KETLST, KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST,
32622 C    &     KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST, KWLBGN,
32623 C    &     KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST, KWSBGN, KWSLST,
32624 C    &     KDPBGN, KDPLST, KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN,
32625 C    &     KBRLST / 57*0 /
32626
32627 * /blntmp/
32628 **sr 18.5. commented since not used for evap.
32629 C     DATA KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM, KGDWTM,
32630 C    &     KBDWTM, KGCBTM, KWLOTM, KWHITM, KWMUTM, KWSHTM, KEXTTM,
32631 C    &     KSTXTM, KSTNTM, KECTTM, KPCTTM, KLPBTM / 19*0 /
32632
32633 * /cmmdnr/
32634 **sr 18.5. commented since not used for evap.
32635 C     DATA DDNEAR / 0.D+00 /, LFLDNR / .FALSE. /
32636
32637 * /ctitle/
32638 **sr 18.5. commented since not used for evap.
32639 C     DATA RUNTIT (1:40) / '****************************************' /
32640 C     DATA RUNTIT(41:80) / '****************************************' /
32641 C     DATA ITEXPI, ITEXMX / 100000000, 150 /
32642 * /detect/
32643 **sr 18.5. commented since not used for evap.
32644 C     PARAMETER (NNN1 = NRGNMX*NDTCMX)
32645 C     PARAMETER (NNN2 = NSCRMX*NDTCMX)
32646 C     DATA LDTCTR /.FALSE./, NDTSCO /0/, NDTDET /0/
32647 C     DATA EDTMIN/NDTCMX*0.D0/, EDTBIN/NDTCMX*0.D0/, EDTCUT/NDTCMX*0.D0/
32648 C     DATA KDTREG/NNN1*0/, KDTDET/NNN2*0/, KDTSCD/NSCRMX*0/
32649 C     DATA TITDET/NDTCMX*'          '/, TITSCO/NSCRMX*'          '/
32650
32651 * /detloc/
32652 **sr 18.5. commented since not used for evap.
32653 C     DATA ACCUMP /NDTCM2*0.D0/, ACCUMN /NDTCM2*0.D0/, ICOINC /NDTCM2*0/
32654 C     DATA NCLAS /0/
32655
32656 * /emgtrn/
32657 **sr 18.5. commented since not used for evap.
32658 C     DATA LMCSMG / .FALSE. /
32659
32660 * /emsho/
32661 **sr 18.5. commented since not used for evap.
32662 C     DATA LIMPRE, LEXPTE / 2 * .FALSE. /
32663
32664 * /episor/
32665 **sr 18.5. commented since not used for evap.
32666 C     DATA TKESUM / 0.D+00 /, LUSSRC / .FALSE. /
32667
32668 * /fheavy/
32669       DATA AMHEAV / 12 * 0.D+00 /
32670       DATA ANHEAV / 'NEUTRON ', 'PROTON  ', 'DEUTERON', '3-H     ',
32671      &              '3-He    ', '4-He    ', 'H-FRAG-1', 'H-FRAG-2',
32672      &              'H-FRAG-3', 'H-FRAG-4', 'H-FRAG-5', 'H-FRAG-6'/
32673       DATA ICHEAV / 0, 1, 1, 1, 2, 2, 6*0 /,
32674      &     IBHEAV / 1, 1, 2, 3, 3, 4, 6*0 /
32675       DATA NPHEAV / 0 /
32676
32677 * /finuc/
32678       DATA NP / 0 /, TV / 0.D+00 /, TVCMS / 0.D+00 /, TVRECL / 0.D+00/,
32679      &     TVHEAV / 0.D+00 /, TVBIND / 0.D+00 /
32680
32681 * /genthr/
32682 * Up to 20-apr-'95
32683 *     DATA PEANCT, PEAPIT / 2*1.D+00 /
32684 *     DATA PTHRSH / 16*5.D+00,2*2.5D+00,5.D+00,3*2.5D+00,8*5.D+00,
32685 *    &              9*2.5D+00 /
32686 *     DATA PTHDFF / 39*5.D+00 /
32687 *    &              9*2.5D+00 /
32688 * New values:
32689 **sr 18.5. commented since not used for evap.
32690 C     DATA PEANCT, PEAPIT / 1.3D+00, 1.1D+00 /
32691 C     DATA PTHRSH / 12*5.D+00, 2*3.5D+00, 2*5.D+00, 2*2.5D+00, 5.D+00,
32692 C    &              3*2.5D+00, 3.5D+00, 2*5.D+00, 3.5D+00, 4*5.D+00,
32693 C    &              9*2.5D+00 /
32694 C     DATA PTHDFF / 12*5.D+00, 2*3.5D+00, 8*5.D+00, 3.5D+00, 2*5.D+00,
32695 C    &              3.5D+00, 13*5.D+00 /
32696 C     DATA PLDNCT / 0.26D+00 /
32697 C     DATA IJNUCR / 16*1, 2*0, 1, 3*0, 8*1, 9*0 /
32698
32699 * /lowneu/
32700 **sr 18.5. commented since not used for evap.
32701 C     DATA WWAMFL / 10.D+00 /, EXTWWL / 1.D+00 /
32702 C     DATA IWWLWB, IWWLWT / 2 * 100000000 /
32703 C     DATA ICLMED, INABGN, IDWBGN, IETBGN / 4*0 /
32704 C     DATA IGRTHN / 1 /
32705 C     DATA LIMPRN / .FALSE. /, LBIASN / .FALSE. /, LDOWNN / .FALSE. /,
32706 C    &     LLOWWW / .FALSE. /, LLOWET / .FALSE. /
32707
32708 * /ltclcm/
32709 **sr 18.5. commented since not used for evap.
32710 C     DATA MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1 / 6*0 /
32711
32712 * /mulbou/
32713 **sr 18.5. commented since not used for evap.
32714 C     DATA LLDA, LAGAIN, LSTNEW, LARTEF, LSENSE, LNORML, LMGNOR
32715 C    &     / 7 * .FALSE. /
32716 C     DATA TSENSE / AINFNT /, NSSENS / -1 /
32717 C     DATA DSMALL / ANGLGB /
32718
32719 * /mulhd/
32720 **sr 18.5. commented since not used for evap.
32721 C     DATA LTOPT  / MXXMDF * .FALSE. /, NFSCAT / 0 /
32722 C     DATA ESTEPF / MXXMDF * 0.1D+00 /
32723 C     DATA LSRCRH / MXXMDF * .FALSE. /, LNSCRH / MXXMDF * .FALSE. /
32724 C     DATA THMSPR / 0.02D+00 /, THMSSC / 1.D+00 /
32725
32726 * /parevt/
32727       DATA DPOWER /-13.D+00 /, FSPRD0 / 0.6D+00 /, FSHPFN / 0.0D+00 /,
32728      &     RN1GSC /-1.0D+00 /, RN2GSC /-1.0D+00 /
32729       DATA LDIFFR /  .TRUE., .TRUE., 6 * .TRUE., .TRUE., 8 * .TRUE.,
32730      &               .TRUE., 4 * .TRUE., .TRUE., 3 * .TRUE.,
32731      &              4 * .FALSE., 9 * .TRUE./
32732 **sr 17.5.95
32733 * default value for LEVPRT changed (reset sr 25.7.97)
32734 * default value for LHEAVY changed 25.7.97
32735 C     DATA LPOWER / .TRUE.  /, LINCTV / .TRUE.  /, LEVPRT / .TRUE.  /,
32736 C    &     LHEAVY / .FALSE. /, LDEEXG / .TRUE.  /, LGDHPR / .TRUE.  /,
32737 C    &     LPREEX / .TRUE.  /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /,
32738 C    &     LPARWV / .TRUE.  /, LSNGCH / .TRUE.  /, LSCHDF / .TRUE.  /
32739       DATA LPOWER / .TRUE.  /, LINCTV / .TRUE.  /, LEVPRT / .TRUE.  /,
32740      &     LHEAVY / .TRUE.  /, LDEEXG / .TRUE.  /, LGDHPR / .TRUE.  /,
32741      &     LPREEX / .TRUE.  /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /,
32742      &     LPARWV / .TRUE.  /, LSNGCH / .TRUE.  /, LSCHDF / .TRUE.  /
32743 **
32744 **sr 27.5.97
32745 * default value for ILVMOD changed
32746 C     DATA ILVMOD / 0 /, JLVMOD / 1 /, LLVMOD / .TRUE. /
32747       DATA ILVMOD / 1 /, JLVMOD / 1 /, LLVMOD / .TRUE. /
32748 **
32749
32750 * /resnuc/
32751       DATA IPREEH / 0 /, IPRTRI / 0 /, IPRDEU / 0 /, IPR3HE / 0 /,
32752      &     IPR4HE / 0 /
32753       DATA IEVAPL / 0 /, IEVAPH / 0 /, IEVNEU / 0 /, IEVPRO / 0 /,
32754      &     IEVTRI / 0 /, IEVDEU / 0 /, IEV3HE / 0 /, IEV4HE / 0 /,
32755      &     IDEEXG / 0 /
32756       DATA LRNFSS / .FALSE. /
32757
32758 * /scohlp/
32759 **sr 18.5. commented since not used for evap.
32760 C     DATA ISCRNG, JSCRNG / 2*0 /, LSCZER / .FALSE. /
32761
32762 * /trackr/
32763 **sr 18.5. commented since not used for evap.
32764 C     DATA ETRACK /0.D+00/, WTRACK /0.D+00/, ATRACK /0.D+00/,
32765 C    &     CTRACK /0.D+00/, NTRACK /0/, MTRACK /0/, JTRACK /0/
32766
32767 * /usrbin/
32768 **sr 18.5. commented since not used for evap.
32769 C     DATA LUSBIN, LUSEVT, LUSTKB /3*.FALSE./, NUSRBN /0/
32770
32771 * /usrbdx/
32772 **sr 18.5. commented since not used for evap.
32773 C     DATA LUSBDX /.FALSE./, NUSRBX /0/
32774
32775 * /usrsnc/
32776 **sr 18.5. commented since not used for evap.
32777 C     DATA LURSNC /.FALSE./, NURSNC /0/
32778
32779 * /usrtrc/
32780 **sr 18.5. commented since not used for evap.
32781 C     DATA LUSRTC, LUSTRK, LUSCLL / 3*.FALSE. /
32782 C     DATA NUSRTC, NUSTRK, NUSCLL / 3*0 /
32783
32784 * /usryld/
32785 **sr 18.5. commented since not used for evap.
32786 C     DATA LUSRYL / .FALSE./, LSCUYL / .FALSE. /, NUSRYL /0/,
32787 C    &     IJUSYL /0/, JTUSYL /0/
32788 C     DATA PUSRYL, UUSRYL, VUSRYL, WUSRYL / 4*ZERZER /
32789
32790 * /wwindw/
32791 **sr 18.5. commented since not used for evap.
32792 C     DATA IWLBGN, IWHBGN, IWMBGN / 3*0 /
32793 C     DATA LWWPRM / .TRUE. /
32794
32795 *=                                               end*block.bdnopt      *
32796       END
32797
32798 *$ CREATE DT_BDPREE.FOR
32799 *COPY DT_BDPREE
32800 *
32801 *=== bdpree ===========================================================*
32802 *
32803       BLOCK DATA DT_BDPREE
32804
32805 C     INCLUDE '(DBLPRC)'
32806 * DBLPRC.ADD
32807       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32808       SAVE
32809 * (original name: GLOBAL)
32810       PARAMETER ( KALGNM = 2 )
32811       PARAMETER ( ANGLGB = 5.0D-16 )
32812       PARAMETER ( ANGLSQ = 2.5D-31 )
32813       PARAMETER ( AXCSSV = 0.2D+16 )
32814       PARAMETER ( ANDRFL = 1.0D-38 )
32815       PARAMETER ( AVRFLW = 1.0D+38 )
32816       PARAMETER ( AINFNT = 1.0D+30 )
32817       PARAMETER ( AZRZRZ = 1.0D-30 )
32818       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
32819       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
32820       PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
32821       PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
32822       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
32823       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
32824       PARAMETER ( CSNNRM = 2.0D-15 )
32825       PARAMETER ( DMXTRN = 1.0D+08 )
32826       PARAMETER ( ZERZER = 0.D+00 )
32827       PARAMETER ( ONEONE = 1.D+00 )
32828       PARAMETER ( TWOTWO = 2.D+00 )
32829       PARAMETER ( THRTHR = 3.D+00 )
32830       PARAMETER ( FOUFOU = 4.D+00 )
32831       PARAMETER ( FIVFIV = 5.D+00 )
32832       PARAMETER ( SIXSIX = 6.D+00 )
32833       PARAMETER ( SEVSEV = 7.D+00 )
32834       PARAMETER ( EIGEIG = 8.D+00 )
32835       PARAMETER ( ANINEN = 9.D+00 )
32836       PARAMETER ( TENTEN = 10.D+00 )
32837       PARAMETER ( HLFHLF = 0.5D+00 )
32838       PARAMETER ( ONETHI = ONEONE / THRTHR )
32839       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
32840       PARAMETER ( ONEFOU = ONEONE / FOUFOU )
32841       PARAMETER ( THRTWO = THRTHR / TWOTWO )
32842       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
32843       PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
32844       PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
32845       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
32846       PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
32847       PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
32848       PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
32849       PARAMETER ( EULERO = 0.577215664901532860606512      D+00 )
32850       PARAMETER ( EULEXP = 1.781072417990197985236504      D+00 )
32851       PARAMETER ( EULLOG =-0.5495393129816448223376619     D+00 )
32852       PARAMETER ( E1M2EU = 0.8569023337737540831433017     D+00 )
32853       PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
32854       PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
32855       PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
32856       PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
32857       PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
32858       PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
32859       PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
32860       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
32861       PARAMETER ( CLIGHT = 2.99792458         D+10 )
32862       PARAMETER ( AVOGAD = 6.0221367          D+23 )
32863       PARAMETER ( BOLTZM = 1.380658           D-23 )
32864       PARAMETER ( AMELGR = 9.1093897          D-28 )
32865       PARAMETER ( PLCKBR = 1.05457266         D-27 )
32866       PARAMETER ( ELCCGS = 4.8032068          D-10 )
32867       PARAMETER ( ELCMKS = 1.60217733         D-19 )
32868       PARAMETER ( AMUGRM = 1.6605402          D-24 )
32869       PARAMETER ( AMMUMU = 0.113428913        D+00 )
32870       PARAMETER ( AMPRMU = 1.007276470        D+00 )
32871       PARAMETER ( AMNEMU = 1.008664904        D+00 )
32872       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
32873       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
32874       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
32875       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
32876       PARAMETER ( PLABRC = 0.197327053        D+00 )
32877       PARAMETER ( AMELCT = 0.51099906         D-03 )
32878       PARAMETER ( AMUGEV = 0.93149432         D+00 )
32879       PARAMETER ( AMMUON = 0.105658389        D+00 )
32880       PARAMETER ( AMPRTN = 0.93827231         D+00 )
32881       PARAMETER ( AMNTRN = 0.93956563         D+00 )
32882       PARAMETER ( AMDEUT = 1.87561339         D+00 )
32883       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
32884      &                   * 1.D-09 )
32885       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
32886       PARAMETER ( BLTZMN = 8.617385           D-14 )
32887       PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
32888       PARAMETER ( GFOHB3 = 1.16639            D-05 )
32889       PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
32890       PARAMETER ( SIN2TW = 0.2319             D+00 )
32891       PARAMETER ( GEVMEV = 1.0                D+03 )
32892       PARAMETER ( EMVGEV = 1.0                D-03 )
32893       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
32894       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
32895       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
32896       LOGICAL LGBIAS, LGBANA
32897       COMMON /FKGLOB/ LGBIAS, LGBANA
32898 C     INCLUDE '(DIMPAR)'
32899 * DIMPAR.ADD
32900       PARAMETER ( MXXRGN = 5000 )
32901       PARAMETER ( MXXMDF = 82   )
32902       PARAMETER ( MXXMDE = 54   )
32903       PARAMETER ( MFSTCK = 1000 )
32904       PARAMETER ( MESTCK = 100  )
32905       PARAMETER ( NALLWP = 39   )
32906       PARAMETER ( NELEMX = 80   )
32907       PARAMETER ( MPDPDX = 8    )
32908       PARAMETER ( ICOMAX = 180  )
32909       PARAMETER ( NSTBIS = 304  )
32910       PARAMETER ( IDMAXP = 220  )
32911       PARAMETER ( IDMXDC = 640  )
32912       PARAMETER ( MKBMX1 = 1    )
32913       PARAMETER ( MKBMX2 = 1    )
32914 C     INCLUDE '(IOUNIT)'
32915 * IOUNIT.ADD
32916       PARAMETER ( LUNIN  =  5 )
32917       PARAMETER ( LUNOUT =  6 )
32918 **sr 19.5. set error output-unit from 15 to 6
32919       PARAMETER ( LUNERR = 6  )
32920       PARAMETER ( LUNBER = 14 )
32921       PARAMETER ( LUNECH =  8 )
32922       PARAMETER ( LUNFLU = 13 )
32923       PARAMETER ( LUNGEO = 16 )
32924       PARAMETER ( LUNPMF = 12 )
32925       PARAMETER ( LUNRAN =  2 )
32926       PARAMETER ( LUNXSC =  9 )
32927       PARAMETER ( LUNDET = 17 )
32928       PARAMETER ( LUNRAY = 10 )
32929       PARAMETER ( LUNRDB =  1 )
32930       PARAMETER ( LUNPGO =  7 )
32931       PARAMETER ( LUNPGS =  4 )
32932       PARAMETER ( LUNSCR =  3 )
32933 *
32934 *----------------------------------------------------------------------*
32935 *                                                                      *
32936 *     Created on 16 september 1991 by    Alfredo Ferrari & Paola Sala  *
32937 *                                                   Infn - Milan       *
32938 *                                                                      *
32939 *     Last change on 03-feb-94     by    Alfredo Ferrari               *
32940 *                                                                      *
32941 *                                                                      *
32942 *----------------------------------------------------------------------*
32943 *
32944 * (original name: CMPISG,CHPISG)
32945       PARAMETER ( TPPPI0 = 0.279656044337515D+00 )
32946       PARAMETER ( TNNPI0 = 0.279642680857450D+00 )
32947       PARAMETER ( TPPPIP = 0.292295207182790D+00 )
32948       PARAMETER ( TPPDEP = 0.287514778898469D+00 )
32949       PARAMETER ( TNNPIM = 0.286723140900975D+00 )
32950       PARAMETER ( TNNDEM = 0.281949292916434D+00 )
32951       PARAMETER ( TPNPI0 = 0.279456888147740D+00 )
32952       PARAMETER ( TPNDE0 = 0.274693916135245D+00 )
32953       PARAMETER ( TPNPIP = 0.292086756473890D+00 )
32954       PARAMETER ( TNPPI0 = 0.279842093144975D+00 )
32955       PARAMETER ( TNPDE0 = 0.275072555824202D+00 )
32956       PARAMETER ( TNPPIP = 0.292489370554958D+00 )
32957       PARAMETER ( PIRSMX = 1.2D+00 )
32958       PARAMETER ( NPIREA = 10 )
32959       PARAMETER ( NPIRTA = 68 )
32960       PARAMETER ( NPIRLN = 21 )
32961       PARAMETER ( NPIRLG = NPIRTA - NPIRLN )
32962       PARAMETER ( NPISIS = NPIRLN + 20 )
32963       PARAMETER ( NPISEX = NPIRLN + 21 )
32964       PARAMETER ( NPIIMN = 14 )
32965       PARAMETER ( NPIIRC =  6 )
32966       PARAMETER ( DELWLL = 0.035D+00 )
32967       CHARACTER CHPIRE*8
32968       LOGICAL LDLRES
32969       COMMON /FKCMPI/ PMNPIS, PMMPIS, PISPIS, PEXPIS, PMXPIS, DPPISG,
32970      &                RTPISG, AMNPIS, AMMPIS, AISPIS, AEXPIS, AMXPIS,
32971      &                ARPISG, BPISLO (NPIRLN:NPIRTA,NPIREA),
32972      &                CPISLO (NPIRLN:NPIRTA,NPIREA), PPITHR (NPIREA),
32973      &                SPISLO (NPIRLN:NPIRTA,NPIREA), APITHR (NPIREA),
32974      &                SGPIIN (NPIIMN:NPIRTA,NPIIRC), RHPICR (1:5)   ,
32975      &                SGPICU (0:20,NPIRTA,NPIREA)  , SGRTRS (NPIREA),
32976      &                SGPIDF (0:20,NPIRTA,NPIREA)  , BRREIN (NPIREA),
32977      &                SGPIIS (NPIRTA,NPIREA)       , BRREOU (NPIREA),
32978      &                BRD3OU (2,2,-1:2), BRDEOU (2,-1:2),
32979      &                SGABSR (2,2,4)   , PRRSDL,
32980      &                IPIREA (2,2,3:5) , IPIINE (2,3:5)    , NPIRVR ,
32981      &                KPIIRE (2,NPIREA), KPIORE (2,NPIREA) ,
32982      &                JSTOKP (5), KPTOJS (23), ITTRRS (3:5), LDLRES
32983       COMMON /FKCHPI/ CHPIRE (NPIREA)
32984       DIMENSION SG2BRS (2,2), SGABSW (2,2), SG3BRS (2,2,2)
32985       EQUIVALENCE ( SG2BRS   (1,1), SGABSR (1,1,1) )
32986       EQUIVALENCE ( SGABSW   (1,1), SGABSR (1,1,2) )
32987       EQUIVALENCE ( SG3BRS (1,1,1), SGABSR (1,1,3) )
32988 * (original name: FRBKCM)
32989       PARAMETER ( MXFFBK =     6 )
32990       PARAMETER ( MXZFBK =     9 )
32991       PARAMETER ( MXNFBK =    10 )
32992       PARAMETER ( MXAFBK =    16 )
32993       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
32994       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
32995       PARAMETER ( NXAFBK = MXAFBK + 1 )
32996       PARAMETER ( MXPSST =   300 )
32997       PARAMETER ( MXPSFB = 41000 )
32998       LOGICAL LFRMBK, LNCMSS
32999       COMMON /FKFRBK/  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
33000      &          EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
33001      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
33002      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
33003      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
33004      &          IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
33005      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
33006      &          IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
33007      &          IFBFRB, NBUFBK, LFRMBK, LNCMSS
33008 * (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII)
33009       PARAMETER ( PI     = PIPIPI )
33010       PARAMETER ( PISQ   = PIPISQ )
33011       PARAMETER ( SKTOHL = 0.5456645846610345D+00 )
33012       PARAMETER ( RZNUCL = 1.12        D+00 )
33013       PARAMETER ( RMSPRO = 0.8         D+00 )
33014       PARAMETER ( R0PROT = RMSPRO / SQRT12  )
33015       PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT
33016      &          / R0PROT )
33017       PARAMETER ( RLLE04 = RZNUCL )
33018       PARAMETER ( RLLE16 = RZNUCL )
33019       PARAMETER ( RLGT16 = RZNUCL )
33020       PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 )
33021       PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 )
33022       PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 )
33023       PARAMETER ( SKLE04 = 1.4D+00 )
33024       PARAMETER ( SKLE16 = 1.9D+00 )
33025       PARAMETER ( SKGT16 = 2.4D+00 )
33026       PARAMETER ( HLLE04 = SKTOHL * SKLE04 )
33027       PARAMETER ( HLLE16 = SKTOHL * SKLE16 )
33028       PARAMETER ( HLGT16 = SKTOHL * SKGT16 )
33029       PARAMETER ( ALPHA0 = 0.1D+00 )
33030       PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 )
33031       PARAMETER ( GAMSK0 = 0.9D+00 )
33032       PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 )
33033       PARAMETER ( POTME0 = 0.6666666666666667D+00 )
33034       PARAMETER ( POTBA0 = 1.D+00 )
33035       PARAMETER ( PNFRAT = 1.533D+00 )
33036       PARAMETER ( RADPIM = 0.035D+00 )
33037       PARAMETER ( RDPMHL = 14.D+00   )
33038       PARAMETER ( APMRST = 4.D+00 / 44.D+00 )
33039       PARAMETER ( APMPRO = 1.D+00 / 6.D+00 )
33040       PARAMETER ( APPPRO = 5.D+00 / 6.D+00 )
33041       PARAMETER ( AP0PFS = 0.5D+00 )
33042       PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 )
33043       PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 )
33044       PARAMETER ( XPAUCO = 1.88495407241652 D+00 )
33045       PARAMETER ( MXSCIN = 50     )
33046       LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY,
33047      &        LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC
33048       COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260),
33049      &                RADTAB (2:260), SKITAB (2:260), HALTAB (2:260),
33050      &                SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260),
33051      &                CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260),
33052      &                PFRTAB (2:260)
33053       COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP,
33054      &                ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO,
33055      &                RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR,
33056      &                YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN,
33057      &                RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM,
33058      &                PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2,
33059      &                PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT,
33060      &                BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2,
33061      &                YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3,
33062      &                XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC,
33063      &                SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ,
33064      &                R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE,
33065      &                PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY,
33066      &                EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ,
33067      &                PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM,
33068      &                EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3,
33069      &                PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM,
33070      &                BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN
33071       COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2),
33072      &                RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN,
33073      &                EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF,
33074      &                BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC,
33075      &                WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES,
33076      &                POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND,
33077      &                BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4),
33078      &                SIGPAB (3), SIGNAB (3), HHLP   (2), FORTOT (2),
33079      &                FPNBLC, DPNBLC, FFTFLG, IFTFLG,
33080      &                IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2,
33081      &                KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3,
33082      &                NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM,
33083      &                IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ,
33084      &                LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC
33085       COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT
33086       COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN),
33087      &                YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN),
33088      &                AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX,
33089      &                NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN),
33090      &                NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN),
33091      &                ISCTYP (0:MXSCIN), NUSCIN, NEXPEM,
33092      &                LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH,
33093      &                LNCDCY, LNUSCT
33094       DIMENSION AWSTAB (2:260), SIGMAB (3)
33095       EQUIVALENCE ( DEFPRO, DEFNUC (1) )
33096       EQUIVALENCE ( DEFNEU, DEFNUC (2) )
33097       EQUIVALENCE ( RHOIPP, RHONCP (1) )
33098       EQUIVALENCE ( RHOINP, RHONCP (2) )
33099       EQUIVALENCE ( RHOIP2, RHONC2 (1) )
33100       EQUIVALENCE ( RHOIN2, RHONC2 (2) )
33101       EQUIVALENCE ( RHOIP3, RHONC3 (1) )
33102       EQUIVALENCE ( RHOIN3, RHONC3 (2) )
33103       EQUIVALENCE ( RHOIPT, RHONCT (1) )
33104       EQUIVALENCE ( RHOINT, RHONCT (2) )
33105       EQUIVALENCE ( OMALHL, SK3PAR )
33106       EQUIVALENCE ( ALPHAL, HABPAR )
33107       EQUIVALENCE ( ALPTAB (2), AWSTAB (2) )
33108       EQUIVALENCE ( SIGMPE, SIGMPR (1) )
33109       EQUIVALENCE ( SIGMPC, SIGMPR (2) )
33110       EQUIVALENCE ( SIGMPI, SIGMPR (3) )
33111       EQUIVALENCE ( SIGMPA, SIGMPR (4) )
33112       EQUIVALENCE ( SIGMNE, SIGMNU (1) )
33113       EQUIVALENCE ( SIGMNC, SIGMNU (2) )
33114       EQUIVALENCE ( SIGMNI, SIGMNU (3) )
33115       EQUIVALENCE ( SIGMNA, SIGMNU (4) )
33116       EQUIVALENCE ( SIGMA2, SIGPAB (1) )
33117       EQUIVALENCE ( SIGMA3, SIGPAB (2) )
33118       EQUIVALENCE ( SIGMAS, SIGPAB (3) )
33119       EQUIVALENCE ( SIGPAB (1), SIGMAB (1) )
33120 * (original name: NUCLEV)
33121       LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL
33122       COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2),
33123      &                DEFMAG (2), ENNCLV (160,2), RANCLV (160,2),
33124      &                CUMRAD (0:160,2), RUSNUC (2),
33125      &                ENPLVL (114), ENNLVL(164), JUSNUC (160,2),
33126      &                NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2),
33127      &                NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2),
33128      &                JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8),
33129      &                MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2),
33130      &                NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL,
33131      &                LFLVSL, LRLVSL, LEQSBL
33132       DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8),
33133      &          MGSSPR (19) , MGSSNE (25)
33134       EQUIVALENCE ( RUSNUC (1), RUSPRO )
33135       EQUIVALENCE ( RUSNUC (2), RUSNEU )
33136       EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) )
33137       EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) )
33138       EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) )
33139       EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) )
33140       EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) )
33141       EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) )
33142       EQUIVALENCE ( NTANUC (1), NTAPRO )
33143       EQUIVALENCE ( NTANUC (2), NTANEU )
33144       EQUIVALENCE ( NAVNUC (1), NAVPRO )
33145       EQUIVALENCE ( NAVNUC (2), NAVNEU )
33146       EQUIVALENCE ( NLSNUC (1), NLSPRO )
33147       EQUIVALENCE ( NLSNUC (2), NLSNEU )
33148       EQUIVALENCE ( NCONUC (1), NCOPRO )
33149       EQUIVALENCE ( NCONUC (2), NCONEU )
33150       EQUIVALENCE ( NSKNUC (1), NSKPRO )
33151       EQUIVALENCE ( NSKNUC (2), NSKNEU )
33152       EQUIVALENCE ( NHANUC (1), NHAPRO )
33153       EQUIVALENCE ( NHANUC (2), NHANEU )
33154       EQUIVALENCE ( NUSNUC (1), NUSPRO )
33155       EQUIVALENCE ( NUSNUC (2), NUSNEU )
33156       EQUIVALENCE ( NACNUC (1), NACPRO )
33157       EQUIVALENCE ( NACNUC (2), NACNEU )
33158       EQUIVALENCE ( JMXNUC (1), JMXPRO )
33159       EQUIVALENCE ( JMXNUC (2), JMXNEU )
33160       EQUIVALENCE ( MAGNUC (1), MAGPRO )
33161       EQUIVALENCE ( MAGNUC (2), MAGNEU )
33162 * (original name: PARNUC)
33163       PARAMETER ( PIGRK  = PIPIPI )
33164       PARAMETER ( ALEVEL = 8.D-03 )
33165       PARAMETER ( RCNUCL = 1.12D+00 )
33166       PARAMETER ( R0SIG  = 1.3D+00 )
33167       PARAMETER ( R0SIGK = 1.5D+00 )
33168       PARAMETER ( RCOULB = 1.5D+00 )
33169       PARAMETER ( COULBH = 0.88235D-03 )
33170       PARAMETER ( RHONU0 = 0.75D+00 / PIGRK / RCNUCL / RCNUCL / RCNUCL )
33171       PARAMETER ( TAUFO0 = 10.0D+00 )
33172       PARAMETER ( EKEEXP = 0.03D+00 )
33173       PARAMETER ( EKREXP = 0.05D+00 )
33174       PARAMETER ( EKEMNM = 0.01D+00 )
33175       PARAMETER ( NCPMX = 120 )
33176       COMMON /FKPARN/ EKORI , PXORI , PYORI , PZORI , PTORI , TAUFOR,
33177      &                ENNUC  (NCPMX), PNUCL  (NCPMX), EKFNUC (NCPMX),
33178      &                XSTNUC (NCPMX), YSTNUC (NCPMX), ZSTNUC (NCPMX),
33179      &                PXNUCL (NCPMX), PYNUCL (NCPMX), PZNUCL (NCPMX),
33180      &                RSTNUC (NCPMX), FREEPA (NCPMX), CRRPAN (NCPMX),
33181      &                CRRPAP (NCPMX), BSTNUC (NCPMX), AGENUC (NCPMX),
33182      &                TAUFPA (NCPMX), RHNUCL(NCPMX,2), BNDGAV, DEFMIN,
33183      &                KPNUCL (NCPMX), KRFNUC (NCPMX), ILINUC (NCPMX),
33184      &                INUCTS (NCPMX), ISFNUC (NCPMX), KPORI , IBORI ,
33185      &                IBNUCL, NPNUC , NNUCTS
33186 *
33187       DATA LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH / 6*.FALSE. /
33188       DATA POTBAR / POTBA0 /, POTMES / POTME0 /, WLLRES / 0.D+00 /
33189       DATA JUSNUC / 320 * 0 /, INUCLV / 1 /, IEVPRE / 0 /
33190       DATA MAGNUM / 2, 8, 20, 28, 50, 82, 126, 160 /
33191       DATA LPREEQ / .FALSE. /
33192 * /cmpisg/
33193       DATA JSTOKP / 1, 8, 13, 14, 23 /
33194       DATA KPTOJS / 1, 6*0, 2, 4*0, 3, 4, 8*0, 5 /
33195       DATA CHPIRE / 'PI+PPI+P','PI-PPI-P','PI-PPI0N','PI0PPI0P',
33196      &              'PI0PPI+N','PI-NPI-N','PI+NPI+N','PI+NPI0P',
33197      &              'PI0NPI0N','PI0NPI-P' /
33198       DATA KPIIRE / 13, 1, 14, 1, 14, 1, 23, 1, 23, 1, 14, 8,
33199      &              13, 8, 13, 8, 23, 8, 23, 8 /
33200       DATA KPIORE / 13, 1, 14, 1, 23, 8, 23, 1, 13, 8, 14, 8,
33201      &              13, 8, 23, 1, 23, 8, 14, 1 /
33202       DATA IPIREA / 1, 0, 7, 8, 2, 3, 6, 0, 4, 5, 9, 10 /
33203       DATA IPIINE / 1, 2, 3, 4, 5, 6 /
33204 * /frbkcm/
33205       DATA LFRMBK / .FALSE. /
33206       DATA NBUFBK /   500  /
33207       DATA EXMXFB / 80.0 D+00 /
33208       DATA R0FRBK / 1.18 D+00 /
33209       DATA R0CFBK / 2.173D+00 /
33210       DATA C1CFBK / 6.103D-03 /
33211       DATA C2CFBK / 9.443D-03 /
33212 * /parnuc/
33213       DATA TAUFOR / TAUFO0 /
33214 *=== End of Block Data Bdpree =========================================*
33215       END
33216
33217 *$ CREATE DT_XHOINI.FOR
33218 *COPY DT_XHOINI
33219 *
33220 *====phoini============================================================*
33221 *
33222       SUBROUTINE DT_XHOINI
33223 C     SUBROUTINE DT_PHOINI
33224
33225       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33226       SAVE
33227       PARAMETER ( LINP = 10 ,
33228      &            LOUT = 6 ,
33229      &            LDAT = 9 )
33230
33231       RETURN
33232       END
33233
33234 *$ CREATE DT_XVENTB.FOR
33235 *COPY DT_XVENTB
33236 *
33237 *====eventb============================================================*
33238 *
33239       SUBROUTINE DT_XVENTB(NCSY,IREJ)
33240 C     SUBROUTINE DT_EVENTB(NCSY,IREJ)
33241
33242       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33243       SAVE
33244       PARAMETER ( LINP = 10 ,
33245      &            LOUT = 6 ,
33246      &            LDAT = 9 )
33247
33248       WRITE(LOUT,1000)
33249  1000 FORMAT(1X,'EVENTB:   PHOJET-package requested but not linked!')
33250       STOP
33251
33252       END
33253
33254 *$ CREATE DT_XVENT.FOR
33255 *COPY DT_XVENT
33256 *
33257 *===event==============================================================*
33258 *
33259       SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
33260 C     SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
33261
33262       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33263       SAVE
33264
33265       DIMENSION PP(4),PT(4)
33266
33267       RETURN
33268       END
33269
33270 *$ CREATE DT_XOHISX.FOR
33271 *COPY DT_XOHISX
33272 *
33273 *===pohisx=============================================================*
33274 *
33275       SUBROUTINE DT_XOHISX(I,X)
33276 C     SUBROUTINE POHISX(I,X)
33277
33278       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33279       SAVE
33280
33281       RETURN
33282       END
33283
33284 *$ CREATE PHO_LHIST.FOR
33285 *COPY PHO_LHIST
33286 *
33287 *===poluhi=============================================================*
33288 *
33289       SUBROUTINE PHO_LHIST(I,X)
33290 **
33291
33292       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33293       SAVE
33294
33295       RETURN
33296       END
33297
33298 *$ CREATE PDFSET.FOR
33299 *COPY PDFSET
33300 *
33301 C**********************************************************************
33302 C
33303 C   dummy subroutines, remove to link PDFLIB
33304 C
33305 C**********************************************************************
33306       SUBROUTINE PDFSET(PARAM,VALUE)
33307       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33308       DIMENSION PARAM(20),VALUE(20)
33309       CHARACTER*20 PARAM
33310       END
33311
33312 *$ CREATE STRUCTM.FOR
33313 *COPY STRUCTM
33314 *
33315       SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
33316       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33317       END
33318
33319 *$ CREATE STRUCTP.FOR
33320 *COPY STRUCTP
33321 *
33322       SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
33323       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33324       END
33325
33326 *$ CREATE DT_DIQBRK.FOR
33327 *COPY DT_DIQBRK
33328 *
33329 *===diqbrk=============================================================*
33330 *
33331       SUBROUTINE DT_XIQBRK
33332 C     SUBROUTINE DT_DIQBRK
33333
33334       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33335       SAVE
33336
33337       STOP 'diquark-breaking not implemeted !'
33338
33339       RETURN
33340       END
33341
33342 *$ CREATE DT_ELHAIN.FOR
33343 *COPY DT_ELHAIN
33344 *
33345 *===elhain=============================================================*
33346 *
33347       SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
33348
33349 ************************************************************************
33350 * Elastic hadron-hadron scattering.                                    *
33351 * This is a revised version of the original.                           *
33352 * This version dated 03.04.98 is written by S. Roesler                 *
33353 ************************************************************************
33354
33355       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33356       SAVE
33357       PARAMETER ( LINP = 10 ,
33358      &            LOUT = 6 ,
33359      &            LDAT = 9 )
33360       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
33361      &           TINY10=1.0D-10)
33362
33363       PARAMETER (ENNTHR = 3.5D0)
33364       PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
33365      &           BLOWB=0.05D0,BHIB=0.2D0,
33366      &           BLOWM=0.1D0, BHIM=2.0D0)
33367
33368 * particle properties (BAMJET index convention)
33369       CHARACTER*8  ANAME
33370       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33371      &                IICH(210),IIBAR(210),K1(210),K2(210)
33372 * final state from HADRIN interaction
33373       PARAMETER (MAXFIN=10)
33374       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
33375      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
33376
33377 C     DATA TSLOPE /10.0D0/
33378
33379       IREJ = 0
33380
33381     1 CONTINUE
33382
33383       PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
33384       EKIN = ELAB-AAM(IP)
33385 *   kinematical quantities in cms of the hadrons
33386       AMP2 = AAM(IP)**2
33387       AMT2 = AAM(IT)**2
33388       S    = AMP2+AMT2+TWO*ELAB*AAM(IT)
33389       ECM  = SQRT(S)
33390       ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
33391       PCM  = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
33392
33393 * nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
33394       IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
33395      &     ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
33396 *   TSAMCS treats pp and np only, therefore change pn into np and
33397 *   nn into pp
33398          IF (IT.EQ.1) THEN
33399             KPROJ = IP
33400          ELSE
33401             KPROJ = 8
33402             IF (IP.EQ.8) KPROJ = 1
33403          ENDIF
33404          CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
33405          T = TWO*PCM**2*(CTCMS-ONE)
33406
33407 * very crude treatment otherwise: sample t from exponential dist.
33408       ELSE
33409 *   momentum transfer t
33410          TMAX = TWO*TWO*PCM**2
33411          RR = (PLAB-PLOWH)/(PHIH-PLOWH)
33412          IF (IIBAR(IP).NE.0) THEN
33413             TSLOPE = BLOWB+RR*(BHIB-BLOWB)
33414          ELSE
33415             TSLOPE = BLOWM+RR*(BHIM-BLOWM)
33416          ENDIF
33417          FMAX = EXP(-TSLOPE*TMAX)-ONE
33418          R = DT_RNDM(RR)
33419          T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
33420          IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
33421       ENDIF
33422
33423 *   target hadron in Lab after scattering
33424       ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
33425       PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
33426       IF (PLRH(2).LE.TINY10) THEN
33427 C        WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
33428          GOTO 1
33429       ENDIF
33430 *   projectile hadron in Lab after scattering
33431       ELRH(1) = ELAB+AAM(IT)-ELRH(2)
33432       PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
33433 *   scattering angle of projectile in Lab
33434       CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
33435       STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
33436       CALL DT_DSFECF(SPLABP,CPLABP)
33437 *   direction cosines of projectile in Lab
33438       CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
33439      &                          CXRH(1),CYRH(1),CZRH(1))
33440 *   scattering angle of target in Lab
33441       PLLABT = PLAB-CTLABP*PLRH(1)
33442       CTLABT = PLLABT/PLRH(2)
33443       STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
33444 *   direction cosines of target in Lab
33445       CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
33446      &                            CXRH(2),CYRH(2),CZRH(2))
33447 *   fill /HNFSPA/
33448       IRH = 2
33449       ITRH(1) = IP
33450       ITRH(2) = IT
33451
33452       RETURN
33453       END
33454
33455 *$ CREATE DT_TSAMCS.FOR
33456 *COPY DT_TSAMCS
33457 *
33458 *===tsamcs=============================================================*
33459 *
33460       SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
33461
33462 ************************************************************************
33463 * Sampling of cos(theta) for nucleon-proton scattering according to    *
33464 * hetkfa2/bertini parametrization.                                     *
33465 * This is a revised version of the original (HJM 24/10/88)             *
33466 * This version dated 28.10.95 is written by S. Roesler                 *
33467 ************************************************************************
33468
33469       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33470       SAVE
33471       PARAMETER ( LINP = 10 ,
33472      &            LOUT = 6 ,
33473      &            LDAT = 9 )
33474       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
33475      &           TINY10=1.0D-10)
33476
33477       DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
33478       DIMENSION PDCI(60),PDCH(55)
33479
33480       DATA (DCLIN(I),I=1,80) /
33481      &     5.000D-01,  1.000D+00,  0.000D+00,  1.000D+00,  0.000D+00,
33482      &     4.993D-01,  9.881D-01,  5.963D-02,  9.851D-01,  5.945D-02,
33483      &     4.936D-01,  8.955D-01,  5.224D-01,  8.727D-01,  5.091D-01,
33484      &     4.889D-01,  8.228D-01,  8.859D-01,  7.871D-01,  8.518D-01,
33485      &     4.874D-01,  7.580D-01,  1.210D+00,  7.207D-01,  1.117D+00,
33486      &     4.912D-01,  6.969D-01,  1.516D+00,  6.728D-01,  1.309D+00,
33487      &     5.075D-01,  6.471D-01,  1.765D+00,  6.667D-01,  1.333D+00,
33488      &     5.383D-01,  6.054D-01,  1.973D+00,  7.059D-01,  1.176D+00,
33489      &     5.397D-01,  5.990D-01,  2.005D+00,  7.023D-01,  1.191D+00,
33490      &     5.336D-01,  6.083D-01,  1.958D+00,  6.959D-01,  1.216D+00,
33491      &     5.317D-01,  6.075D-01,  1.962D+00,  6.897D-01,  1.241D+00,
33492      &     5.300D-01,  6.016D-01,  1.992D+00,  6.786D-01,  1.286D+00,
33493      &     5.281D-01,  6.063D-01,  1.969D+00,  6.786D-01,  1.286D+00,
33494      &     5.280D-01,  5.960D-01,  2.020D+00,  6.667D-01,  1.333D+00,
33495      &     5.273D-01,  5.920D-01,  2.040D+00,  6.604D-01,  1.358D+00,
33496      &     5.273D-01,  5.862D-01,  2.069D+00,  6.538D-01,  1.385D+00/
33497       DATA (DCLIN(I),I=81,160) /
33498      &     5.223D-01,  5.980D-01,  2.814D+00,  6.538D-01,  1.385D+00,
33499      &     5.202D-01,  5.969D-01,  2.822D+00,  6.471D-01,  1.412D+00,
33500      &     5.183D-01,  5.881D-01,  2.883D+00,  6.327D-01,  1.469D+00,
33501      &     5.159D-01,  5.866D-01,  2.894D+00,  6.250D-01,  1.500D+00,
33502      &     5.133D-01,  5.850D-01,  2.905D+00,  6.170D-01,  1.532D+00,
33503      &     5.106D-01,  5.833D-01,  2.917D+00,  6.087D-01,  1.565D+00,
33504      &     5.084D-01,  5.801D-01,  2.939D+00,  6.000D-01,  1.600D+00,
33505      &     5.063D-01,  5.763D-01,  2.966D+00,  5.909D-01,  1.636D+00,
33506      &     5.036D-01,  5.730D-01,  2.989D+00,  5.814D-01,  1.674D+00,
33507      &     5.014D-01,  5.683D-01,  3.022D+00,  5.714D-01,  1.714D+00,
33508      &     4.986D-01,  5.641D-01,  3.051D+00,  5.610D-01,  1.756D+00,
33509      &     4.964D-01,  5.580D-01,  3.094D+00,  5.500D-01,  1.800D+00,
33510      &     4.936D-01,  5.573D-01,  3.099D+00,  5.431D-01,  1.827D+00,
33511      &     4.909D-01,  5.509D-01,  3.144D+00,  5.313D-01,  1.875D+00,
33512      &     4.885D-01,  5.512D-01,  3.142D+00,  5.263D-01,  1.895D+00,
33513      &     4.857D-01,  5.437D-01,  3.194D+00,  5.135D-01,  1.946D+00/
33514       DATA (DCLIN(I),I=161,195) /
33515      &     4.830D-01,  5.353D-01,  3.253D+00,  5.000D-01,  2.000D+00,
33516      &     4.801D-01,  5.323D-01,  3.274D+00,  4.915D-01,  2.034D+00,
33517      &     4.770D-01,  5.228D-01,  3.341D+00,  4.767D-01,  2.093D+00,
33518      &     4.738D-01,  5.156D-01,  3.391D+00,  4.643D-01,  2.143D+00,
33519      &     4.701D-01,  5.010D-01,  3.493D+00,  4.444D-01,  2.222D+00,
33520      &     4.672D-01,  4.990D-01,  3.507D+00,  4.375D-01,  2.250D+00,
33521      &     4.634D-01,  4.856D-01,  3.601D+00,  4.194D-01,  2.323D+00/
33522
33523       DATA PDCI /
33524      &     4.400D+02,  1.896D-01,  1.931D-01,  1.982D-01,  1.015D-01,
33525      &     1.029D-01,  4.180D-02,  4.228D-02,  4.282D-02,  4.350D-02,
33526      &     2.204D-02,  2.236D-02,  5.900D+02,  1.433D-01,  1.555D-01,
33527      &     1.774D-01,  1.000D-01,  1.128D-01,  5.132D-02,  5.600D-02,
33528      &     6.158D-02,  6.796D-02,  3.660D-02,  3.820D-02,  6.500D+02,
33529      &     1.192D-01,  1.334D-01,  1.620D-01,  9.527D-02,  1.141D-01,
33530      &     5.283D-02,  5.952D-02,  6.765D-02,  7.878D-02,  4.796D-02,
33531      &     6.957D-02,  8.000D+02,  4.872D-02,  6.694D-02,  1.152D-01,
33532      &     9.348D-02,  1.368D-01,  6.912D-02,  7.953D-02,  9.577D-02,
33533      &     1.222D-01,  7.755D-02,  9.525D-02,  1.000D+03,  3.997D-02,
33534      &     5.456D-02,  9.804D-02,  8.084D-02,  1.208D-01,  6.520D-02,
33535      &     8.233D-02,  1.084D-01,  1.474D-01,  9.328D-02,  1.093D-01/
33536
33537       DATA PDCH /
33538      &     1.000D+03,  9.453D-02,  9.804D-02,  8.084D-02,  1.208D-01,
33539      &     6.520D-02,  8.233D-02,  1.084D-01,  1.474D-01,  9.328D-02,
33540      &     1.093D-01,  1.400D+03,  1.072D-01,  7.450D-02,  6.645D-02,
33541      &     1.136D-01,  6.750D-02,  8.580D-02,  1.110D-01,  1.530D-01,
33542      &     1.010D-01,  1.350D-01,  2.170D+03,  4.004D-02,  3.013D-02,
33543      &     2.664D-02,  5.511D-02,  4.240D-02,  7.660D-02,  1.364D-01,
33544      &     2.300D-01,  1.670D-01,  2.010D-01,  2.900D+03,  1.870D-02,
33545      &     1.804D-02,  1.320D-02,  2.970D-02,  2.860D-02,  5.160D-02,
33546      &     1.020D-01,  2.400D-01,  2.250D-01,  3.370D-01,  4.400D+03,
33547      &     1.196D-03,  8.784D-03,  1.517D-02,  2.874D-02,  2.488D-02,
33548      &     4.464D-02,  8.330D-02,  2.008D-01,  2.360D-01,  3.567D-01/
33549
33550       DATA (DCHN(I),I=1,90) /
33551      &     4.770D-01,  4.750D-01,  4.715D-01,  4.685D-01,  4.650D-01,
33552      &     4.610D-01,  4.570D-01,  4.550D-01,  4.500D-01,  4.450D-01,
33553      &     4.405D-01,  4.350D-01,  4.300D-01,  4.250D-01,  4.200D-01,
33554      &     4.130D-01,  4.060D-01,  4.000D-01,  3.915D-01,  3.840D-01,
33555      &     3.760D-01,  3.675D-01,  3.580D-01,  3.500D-01,  3.400D-01,
33556      &     3.300D-01,  3.200D-01,  3.100D-01,  3.000D-01,  2.900D-01,
33557      &     2.800D-01,  2.700D-01,  2.600D-01,  2.500D-01,  2.400D-01,
33558      &     2.315D-01,  2.240D-01,  2.150D-01,  2.060D-01,  2.000D-01,
33559      &     1.915D-01,  1.850D-01,  1.780D-01,  1.720D-01,  1.660D-01,
33560      &     1.600D-01,  1.550D-01,  1.500D-01,  1.450D-01,  1.400D-01,
33561      &     1.360D-01,  1.320D-01,  1.280D-01,  1.250D-01,  1.210D-01,
33562      &     1.180D-01,  1.150D-01,  1.120D-01,  1.100D-01,  1.070D-01,
33563      &     1.050D-01,  1.030D-01,  1.010D-01,  9.900D-02,  9.700D-02,
33564      &     9.550D-02,  9.480D-02,  9.400D-02,  9.200D-02,  9.150D-02,
33565      &     9.100D-02,  9.000D-02,  8.990D-02,  8.900D-02,  8.850D-02,
33566      &     8.750D-02,  8.700D-02,  8.650D-02,  8.550D-02,  8.500D-02,
33567      &     8.499D-02,  8.450D-02,  8.350D-02,  8.300D-02,  8.250D-02,
33568      &     8.150D-02,  8.100D-02,  8.030D-02,  8.000D-02,  7.990D-02/
33569       DATA (DCHN(I),I=91,143) /
33570      &     7.980D-02,  7.950D-02,  7.900D-02,  7.860D-02,  7.800D-02,
33571      &     7.750D-02,  7.650D-02,  7.620D-02,  7.600D-02,  7.550D-02,
33572      &     7.530D-02,  7.500D-02,  7.499D-02,  7.498D-02,  7.480D-02,
33573      &     7.450D-02,  7.400D-02,  7.350D-02,  7.300D-02,  7.250D-02,
33574      &     7.230D-02,  7.200D-02,  7.100D-02,  7.050D-02,  7.020D-02,
33575      &     7.000D-02,  6.999D-02,  6.995D-02,  6.993D-02,  6.991D-02,
33576      &     6.990D-02,  6.870D-02,  6.850D-02,  6.800D-02,  6.780D-02,
33577      &     6.750D-02,  6.700D-02,  6.650D-02,  6.630D-02,  6.600D-02,
33578      &     6.550D-02,  6.525D-02,  6.510D-02,  6.500D-02,  6.499D-02,
33579      &     6.498D-02,  6.496D-02,  6.494D-02,  6.493D-02,  6.490D-02,
33580      &     6.488D-02,  6.485D-02,  6.480D-02/
33581
33582       DATA DCHNA /
33583      &     6.300D+02,  7.810D-02,  1.421D-01,  1.979D-01,  2.479D-01,
33584      &     3.360D-01,  5.400D-01,  7.236D-01,  1.000D+00,  1.540D+03,
33585      &     2.225D-01,  3.950D-01,  5.279D-01,  6.298D-01,  7.718D-01,
33586      &     9.405D-01,  9.835D-01,  1.000D+00,  2.560D+03,  2.625D-01,
33587      &     4.550D-01,  5.963D-01,  7.020D-01,  8.380D-01,  9.603D-01,
33588      &     9.903D-01,  1.000D+00,  3.520D+03,  4.250D-01,  6.875D-01,
33589      &     8.363D-01,  9.163D-01,  9.828D-01,  1.000D+00,  1.000D+00,
33590      &     1.000D+00/
33591
33592       DATA DCHNB /
33593      &     6.300D+02,  3.800D-02,  7.164D-02,  1.275D-01,  2.171D-01,
33594      &     3.227D-01,  4.091D-01,  5.051D-01,  6.061D-01,  7.074D-01,
33595      &     8.434D-01,  1.000D+00,  2.040D+03,  1.200D-01,  2.115D-01,
33596      &     3.395D-01,  5.295D-01,  7.251D-01,  8.511D-01,  9.487D-01,
33597      &     9.987D-01,  1.000D+00,  1.000D+00,  1.000D+00,  2.200D+03,
33598      &     1.344D-01,  2.324D-01,  3.754D-01,  5.674D-01,  7.624D-01,
33599      &     8.896D-01,  9.808D-01,  1.000D+00,  1.000D+00,  1.000D+00,
33600      &     1.000D+00,  2.850D+03,  2.330D-01,  4.130D-01,  6.610D-01,
33601      &     9.010D-01,  9.970D-01,  1.000D+00,  1.000D+00,  1.000D+00,
33602      &     1.000D+00,  1.000D+00,  1.000D+00,  3.500D+03,  3.300D-01,
33603      &     5.450D-01,  7.950D-01,  1.000D+00,  1.000D+00,  1.000D+00,
33604      &     1.000D+00,  1.000D+00,  1.000D+00,  1.000D+00,  1.000D+00/
33605
33606       CST = ONE
33607       IF (EKIN.GT.3.5D0) RETURN
33608 C
33609       IF(KPROJ.EQ.8) GOTO 101
33610       IF(KPROJ.EQ.1) GOTO 102
33611 C*                                             INVALID REACTION
33612       WRITE(LOUT,'(A,I5/A)')
33613      &        ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
33614      &        ' COS(THETA) = 1D0 RETURNED'
33615       RETURN
33616 C-------------------------------- NP ELASTIC SCATTERING----------
33617 101   CONTINUE
33618       IF (EKIN.GT.0.740D0)GOTO 1000
33619       IF (EKIN.LT.0.300D0)THEN
33620 C                                 EKIN .LT. 300 MEV
33621          IDAT=1
33622       ELSE
33623 C                                 300 MEV < EKIN < 740 MEV
33624          IDAT=6
33625       END IF
33626 C
33627       ENER=EKIN
33628       IE=INT(ABS(ENER/0.020D0))
33629       UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
33630 C                                            FORWARD/BACKWARD DECISION
33631       K=IDAT+5*IE
33632       BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
33633       IF (DT_RNDM(CST).LT.BWFW)THEN
33634          VALUE2=-1D0
33635          K=K+1
33636       ELSE
33637          VALUE2=1D0
33638          K=K+3
33639       END IF
33640 C
33641       COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
33642       RND=DT_RNDM(COEF)
33643 C
33644       IF(RND.LT.COEF)THEN
33645          CST=DT_RNDM(RND)
33646          CST=CST*VALUE2
33647       ELSE
33648          R1=DT_RNDM(CST)
33649          R2=DT_RNDM(R1)
33650          R3=DT_RNDM(R2)
33651          R4=DT_RNDM(R3)
33652 C
33653          IF(VALUE2.GT.0.0)THEN
33654             CST=MAX(R1,R2,R3,R4)
33655             GOTO 1500
33656          ELSE
33657             R5=DT_RNDM(R4)
33658 C
33659             IF (IDAT.EQ.1)THEN
33660                CST=-MAX(R1,R2,R3,R4,R5)
33661             ELSE
33662                R6=DT_RNDM(R5)
33663                R7=DT_RNDM(R6)
33664                CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
33665             END IF
33666 C
33667          END IF
33668 C
33669       END IF
33670 C
33671       GOTO 1500
33672 C
33673 C********                                EKIN  .GT.  0.74 GEV
33674 C
33675 1000  ENER=EKIN - 0.66D0
33676 C     IE=ABS(ENER/0.02)
33677       IE=INT(ENER/0.02D0)
33678       EMEV=EKIN*1D3
33679 C
33680       UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
33681       K=IE
33682       BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
33683       RND=DT_RNDM(BWFW)
33684 C                                        FORWARD NEUTRON
33685       IF (RND.GE.BWFW)THEN
33686          DO 1200 K=10,36,9
33687            IF (DCHNA(K).GT.EMEV) THEN
33688               UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
33689               UNIV=DT_RNDM(UNIVE)
33690               DO 1100 I=1,8
33691                  II=K+I
33692                  P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
33693 C
33694                  IF (P.GT.UNIV)THEN
33695                     UNIV=DT_RNDM(UNIVE)
33696                     FLTI=DBLE(I)-UNIV
33697                     GOTO(290,290,290,290,330,340,350,360) I
33698                  END IF
33699  1100         CONTINUE
33700            END IF
33701  1200    CONTINUE
33702 C
33703       ELSE
33704 C                                        BACKWARD NEUTRON
33705          DO 1400 K=13,60,12
33706             IF (DCHNB(K).GT.EMEV) THEN
33707                UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
33708                UNIV=DT_RNDM(UNIVE)
33709                DO 1300 I=1,11
33710                  II=K+I
33711                  P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
33712 C
33713                  IF (P.GT.UNIV)THEN
33714                    UNIV=DT_RNDM(P)
33715                    FLTI=DBLE(I)-UNIV
33716                    GOTO(120,120,140,150,160,160,180,190,200,210,220) I
33717                  END IF
33718  1300          CONTINUE
33719             END IF
33720  1400    CONTINUE
33721       END IF
33722 C
33723 120   CST=1.0D-2*FLTI-1.0D0
33724       GOTO 1500
33725 140   CST=2.0D-2*UNIV-0.98D0
33726       GOTO 1500
33727 150   CST=4.0D-2*UNIV-0.96D0
33728       GOTO 1500
33729 160   CST=6.0D-2*FLTI-1.16D0
33730       GOTO 1500
33731 180   CST=8.0D-2*UNIV-0.80D0
33732       GOTO 1500
33733 190   CST=1.0D-1*UNIV-0.72D0
33734       GOTO 1500
33735 200   CST=1.2D-1*UNIV-0.62D0
33736       GOTO 1500
33737 210   CST=2.0D-1*UNIV-0.50D0
33738       GOTO 1500
33739 220   CST=3.0D-1*(UNIV-1.0D0)
33740       GOTO 1500
33741 C
33742 290   CST=1.0D0-2.5d-2*FLTI
33743       GOTO 1500
33744 330   CST=0.85D0+0.5D-1*UNIV
33745       GOTO 1500
33746 340   CST=0.70D0+1.5D-1*UNIV
33747       GOTO 1500
33748 350   CST=0.50D0+2.0D-1*UNIV
33749       GOTO 1500
33750 360   CST=0.50D0*UNIV
33751 C
33752 1500  RETURN
33753 C
33754 C-----------------------------------  PP ELASTIC SCATTERING -------
33755 C
33756  102  CONTINUE
33757       EMEV=EKIN*1D3
33758 C
33759       IF (EKIN.LE.0.500D0) THEN
33760          RND=DT_RNDM(EMEV)
33761          CST=2.0D0*RND-1.0D0
33762          RETURN
33763 C
33764       ELSEIF (EKIN.LT.1.0D0) THEN
33765          DO 2200 K=13,60,12
33766             IF (PDCI(K).GT.EMEV) THEN
33767                UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
33768                UNIV=DT_RNDM(UNIVE)
33769                SUM=0
33770                DO 2100 I=1,11
33771                  II=K+I
33772                  SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
33773 C
33774                  IF (UNIV.LT.SUM)THEN
33775                    UNIV=DT_RNDM(SUM)
33776                    FLTI=DBLE(I)-UNIV
33777                    GOTO(55,55,55,60,60,65,65,65,65,70,70) I
33778                  END IF
33779  2100          CONTINUE
33780             END IF
33781  2200    CONTINUE
33782       ELSE
33783          DO 2400 K=12,55,11
33784             IF (PDCH(K).GT.EMEV) THEN
33785               UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
33786               UNIV=DT_RNDM(UNIVE)
33787               SUM=0.0D0
33788               DO 2300 I=1,10
33789                 II=K+I
33790                 SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
33791 C
33792                 IF (UNIV.LT.SUM)THEN
33793                   UNIV=DT_RNDM(SUM)
33794                   FLTI=UNIV+DBLE(I)
33795                   GOTO(50,55,60,60,65,65,65,65,70,70) I
33796                 END IF
33797  2300         CONTINUE
33798             END IF
33799  2400    CONTINUE
33800       END IF
33801 C
33802 50    CST=0.4D0*UNIV
33803       GOTO 2500
33804 55    CST=0.2D0*FLTI
33805       GOTO 2500
33806 60    CST=0.3D0+0.1D0*FLTI
33807       GOTO 2500
33808 65    CST=0.6D0+0.04D0*FLTI
33809       GOTO 2500
33810 70    CST=0.78D0+0.02D0*FLTI
33811 C
33812 2500  CONTINUE
33813       IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
33814 C
33815       RETURN
33816       END
33817
33818 *$ CREATE DT_DHADRI.FOR
33819 *COPY DT_DHADRI
33820 *
33821 *===dhadri=============================================================*
33822 *
33823       SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
33824
33825       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33826       SAVE
33827
33828       PARAMETER ( LINP = 10 ,
33829      &            LOUT = 6 ,
33830      &            LDAT = 9 )
33831 C
33832 C-----------------------------
33833 C*** INPUT VARIABLES LIST:
33834 C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
33835 C*** GEV/C LABORATORY MOMENTUM REGION
33836 C*** N    - PROJECTILE HADRON INDEX
33837 C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
33838 C*** ELAB - LABORATORY ENERGY OF N (GEV)
33839 C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
33840 C*** ITTA - TARGET NUCLEON INDEX
33841 C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
33842 C  IR COUNTS THE NUMBER OF PRODUCED PARTICLES
33843 C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
33844 C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
33845 C*** RESPECT., UNITS (GEV/C AND GEV)
33846 C----------------------------
33847
33848       COMMON /HNGAMR/ REDU,AMO,AMM(15)
33849       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33850       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33851      &                NRK(2,268),NURE(30,2)
33852 * particle properties (BAMJET index convention),
33853 * (dublicate of DTPART for HADRIN)
33854       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33855      &                K1H(110),K2H(110)
33856       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33857       COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
33858      &                ITS(149),IS
33859       COMMON /HNDRUN/ RUNTES,EFTES
33860 * particle properties (BAMJET index convention)
33861       CHARACTER*8  ANAME
33862       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33863      &                IICH(210),IIBAR(210),K1(210),K2(210)
33864 * final state from HADRIN interaction
33865       PARAMETER (MAXFIN=10)
33866       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
33867      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
33868
33869       DIMENSION ITPRF(110)
33870       DATA NNN/0/
33871       DATA UMODA/0./
33872       DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
33873       LOWP=0
33874       IF (N.LE.0.OR.N.GE.111)N=1
33875       IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
33876         GOTO 280
33877 *       WRITE (6,1000)
33878 *    +  ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
33879 *       STOP
33880 *1000   FORMAT (3(5H ****/),A,2I4,3(5H ****/))
33881 *    +  45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
33882       ENDIF
33883       IATMPT=0
33884       IF (ABS(PLAB-5.0D0).LT.4.99999D0)                        GO TO 20
33885 C     IF(IPRI.GE.1) WRITE (6,1010) PLAB
33886 C     STOP
33887  1010 FORMAT ( '  PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
33888      + ALLOWED REGION, PLAB=',1E15.5)
33889
33890    20 CONTINUE
33891       UMODAT=N*1.11111D0+ITTA*2.19291D0
33892       IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
33893       UMODA=UMODAT
33894    30 IATMPT=0
33895       LOWP=LOWP+1
33896    40 CONTINUE
33897       IMACH=0
33898       REDU=2.0D0
33899       IF (LOWP.GT.20) THEN
33900 C        WRITE(LOUT,*) ' jump 1'
33901          GO TO 280
33902       ENDIF
33903       NNN=N
33904       IF (NNN.EQ.N)                                             GO TO 50
33905       RUNTES=0.0D0
33906       EFTES=0.0D0
33907    50 CONTINUE
33908       IS=1
33909       IRH=0
33910       IST=1
33911       NSTAB=23
33912       IRE=NURE(N,1)
33913       IF(ITTA.GT.1) IRE=NURE(N,2)
33914 C
33915 C-----------------------------
33916 C*** IE,AMT,ECM,SI DETERMINATION
33917 C----------------------------
33918       CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
33919       IANTH=-1
33920 **sr
33921 C     IF (AMH(1).NE.0.93828D0) IANTH=1
33922       IF (AMH(1).NE.0.9383D0) IANTH=1
33923 **
33924       IF (IANTH.GE.0) SI=1.0D0
33925       ECMMH=ECM
33926 C
33927 C-----------------------------
33928 C    ENERGY INDEX
33929 C  IRE CHARACTERIZES THE REACTION
33930 C  IE IS THE ENERGY INDEX
33931 C----------------------------
33932       IF (SI.LT.1.D-6) THEN
33933 C        WRITE(LOUT,*) ' jump 2'
33934          GO TO 280
33935       ENDIF
33936       IF (N.LE.NSTAB)                                           GO TO 60
33937       RUNTES=RUNTES+1.0D0
33938       IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
33939  1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
33940       IF(IBARH(N).EQ.1) N=8
33941       IF(IBARH(N).EQ.-1)  N=9
33942    60 CONTINUE
33943       IMACH=IMACH+1
33944 **sr 19.2.97: loop for direct channel suppression
33945 C     IF (IMACH.GT.10) THEN
33946       IF (IMACH.GT.1000) THEN
33947 **
33948 C        WRITE(LOUT,*) ' jump 3'
33949          GO TO 280
33950       ENDIF
33951       ECM =ECMMH
33952       AMN2=AMN**2
33953       AMT2=AMT**2
33954       ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM    )
33955       IF(ECMN.LE.AMN) ECMN=AMN
33956       PCMN=SQRT(ECMN**2-AMN2)
33957       GAM=(ELAB+AMT)/ECM
33958       BGAM=PLAB/ECM
33959       IF (IANTH.GE.0) ECM=2.1D0
33960 C
33961 C-----------------------------
33962 C*** RANDOM CHOICE OF REACTION CHANNEL
33963 C----------------------------
33964       IST=0
33965       VV=DT_RNDM(AMN2)
33966       VV=VV-1.D-17
33967 C
33968 C-----------------------------
33969 C***  PLACE REDUCED VERSION
33970 C----------------------------
33971       IIEI=IEII(IRE)
33972       IDWK=IEII(IRE+1)-IIEI
33973       IIWK=IRII(IRE)
33974       IIKI=IKII(IRE)
33975 C
33976 C-----------------------------
33977 C***  SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
33978 C----------------------------
33979       HECM=ECM
33980       HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
33981       IF (HUMO.LT.ECM) ECM=HUMO
33982 C
33983 C-----------------------------
33984 C*** INTERPOLATION PREPARATION
33985 C----------------------------
33986       ECMO=UMO(IE)
33987       ECM1=UMO(IE-1)
33988       DECM=ECMO-ECM1
33989       DEC=ECMO-ECM
33990 C
33991 C-----------------------------
33992 C*** RANDOM LOOP
33993 C----------------------------
33994       IK=0
33995       WKK=0.0D0
33996       WICOR=0.0D0
33997    70 IK=IK+1
33998       IWK=IIWK+(IK-1)*IDWK+IE-IIEI
33999       WOK=WK(IWK)
34000       WDK=WOK-WK(IWK-1)
34001 C
34002 C-----------------------------
34003 C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
34004 C    GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
34005 C    CONTRIBUTE
34006 C----------------------------
34007       IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
34008       WICO=WOK*1.23459876D0+WDK*1.735218469D0
34009       IF (WICO.EQ.WICOR)                                        GO TO 70
34010       IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
34011       WICOR=WICO
34012 C
34013 C-----------------------------
34014 C*** INTERPOLATION IN CHANNEL WEIGHTS
34015 C----------------------------
34016       EKLIM=-THRESH(IIKI+IK)
34017       IELIM=IDT_IEFUND(EKLIM,IRE)
34018       DELIM=UMO(IELIM)+EKLIM
34019      *+1.D-16
34020       DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
34021       IF (DELIM*DELIM-DETE*DETE) 90,90,80
34022    80 DECC=DELIM
34023                                                                GO TO 100
34024    90 DECC=DECM
34025   100 CONTINUE
34026       WKK=WOK-WDK*DEC/(DECC+1.D-9)
34027 C
34028 C-----------------------------
34029 C*** RANDOM CHOICE
34030 C----------------------------
34031 C
34032       IF (VV.GT.WKK)                                            GO TO 70
34033 C
34034 C***IK IS THE REACTION CHANNEL
34035 C----------------------------
34036       INRK=IKII(IRE)+IK
34037       ECM=HECM
34038       I1001 =0
34039 C
34040   110 CONTINUE
34041       IT1=NRK(1,INRK)
34042       AM1=DT_DAMG(IT1)
34043       IT2=NRK(2,INRK)
34044       AM2=DT_DAMG(IT2)
34045       AMS=AM1+AM2
34046       I1001=I1001+1
34047       IF (I1001.GT.50)                                          GO TO 60
34048 C
34049       IF (IT2*AMS.GT.IT2*ECM)                                  GO TO 110
34050       IT11=IT1
34051       IT22=IT2
34052       IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
34053       AM11=AM1
34054       AM22=AM2
34055       IF (IT2.GT.0)                                            GO TO 120
34056 **sr 19.2.97: supress direct channel for pp-collisions
34057       IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
34058          RR = DT_RNDM(AM11)
34059          IF (RR.LE.0.75D0) GOTO 60
34060       ENDIF
34061 **
34062 C
34063 C-----------------------------
34064 C  INCLUSION OF DIRECT RESONANCES
34065 C  RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE  IT1
34066 C------------------------
34067       KZ1=K1H(IT1)
34068       IST=IST+1
34069       IECO=0
34070       ECO=ECM
34071       GAM=(ELAB+AMT)/ECO
34072       BGAM=PLAB/ECO
34073       CXS(1)=CX
34074       CYS(1)=CY
34075       CZS(1)=CZ
34076                                                                GO TO 170
34077   120 CONTINUE
34078       WW=DT_RNDM(ECO)
34079       IF(WW.LT. 0.5D0)                                         GO TO 130
34080       IT1=IT22
34081       IT2=IT11
34082       AM1=AM22
34083       AM2=AM11
34084   130 CONTINUE
34085 C
34086 C-----------------------------
34087 C   THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
34088       IBN=IBARH(N)
34089       IB1=IBARH(IT1)
34090       IT11=IT1
34091       IT22=IT2
34092       AM11=AM1
34093       AM22=AM2
34094       IF(IB1.EQ.IBN)                                           GO TO 140
34095       IT1=IT22
34096       IT2=IT11
34097       AM1=AM22
34098       AM2=AM11
34099   140 CONTINUE
34100 C-----------------------------
34101 C***IT1,IT2 ARE THE CREATED PARTICLES
34102 C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
34103 C------------------------
34104       CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
34105      *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
34106       IST=IST+1
34107       ITS(IST)=IT1
34108       AMM(IST)=AM1
34109 C
34110 C-----------------------------
34111 C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
34112 C----------------------------
34113       CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
34114      &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34115       IST=IST+1
34116       ITS(IST)=IT2
34117       AMM(IST)=AM2
34118       CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
34119      *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34120   150 CONTINUE
34121 C
34122 C-----------------------------
34123 C***TEST   STABLE OR UNSTABLE
34124 C----------------------------
34125       IF(ITS(IST).GT.NSTAB)                                    GO TO 160
34126       IRH=IRH+1
34127 C
34128 C-----------------------------
34129 C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
34130 C----------------------------
34131 C*    IF (REDU.LT.0.D0) GO TO 1009
34132       ITRH(IRH)=ITS(IST)
34133       PLRH(IRH)=PLS(IST)
34134       CXRH(IRH)=CXS(IST)
34135       CYRH(IRH)=CYS(IST)
34136       CZRH(IRH)=CZS(IST)
34137       ELRH(IRH)=ELS(IST)
34138       IST=IST-1
34139       IF(IST.GE.1)                                             GO TO 150
34140                                                                GO TO 260
34141   160 CONTINUE
34142 C
34143 C  RANDOM CHOICE OF DECAY CHANNELS
34144 C----------------------------
34145 C
34146       IT=ITS(IST)
34147       ECO=AMM(IST)
34148       GAM=ELS(IST)/ECO
34149       BGAM=PLS(IST)/ECO
34150       IECO=0
34151       KZ1=K1H(IT)
34152   170 CONTINUE
34153       IECO=IECO+1
34154       VV=DT_RNDM(GAM)
34155       VV=VV-1.D-17
34156       IIK=KZ1-1
34157   180 IIK=IIK+1
34158       IF (VV.GT.WTI(IIK))                                      GO TO 180
34159 C
34160 C  IIK IS THE DECAY CHANNEL
34161 C----------------------------
34162       IT1=NZKI(IIK,1)
34163       I310=0
34164   190 CONTINUE
34165       I310=I310+1
34166       AM1=DT_DAMG(IT1)
34167       IT2=NZKI(IIK,2)
34168       AM2=DT_DAMG(IT2)
34169       IF (IT2-1.LT.0)                                          GO TO 240
34170       IT3=NZKI(IIK,3)
34171       AM3=DT_DAMG(IT3)
34172       AMS=AM1+AM2+AM3
34173 C
34174 C  IF  IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
34175 C----------------------------
34176       IF (IECO.LE.10)                                          GO TO 200
34177       IATMPT=IATMPT+1
34178       IF(IATMPT.GT.3) THEN
34179 C        WRITE(LOUT,*) ' jump 4'
34180          GO TO 280
34181       ENDIF
34182                                                                 GO TO 40
34183   200 CONTINUE
34184       IF (I310.GT.50)                                          GO TO 170
34185       IF (AMS.GT.ECO)                                          GO TO 190
34186 C
34187 C  FOR THE DECAY CHANNEL
34188 C  IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM  IT
34189 C----------------------------
34190       IF (REDU.LT.0.D0)                                        GO TO 30
34191       ITWTHC=0
34192       REDU=2.0D0
34193       IF(IT3.EQ.0)                                             GO TO 220
34194   210 CONTINUE
34195       ITWTH=1
34196       CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
34197      *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
34198                                                                GO TO 230
34199   220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
34200      &COD2,COF2,SIF2,AM1,AM2)
34201       ITWTH=-1
34202       IT3=0
34203   230 CONTINUE
34204       ITWTHC=ITWTHC+1
34205       IF (REDU.GT.0.D0)                                        GO TO 240
34206       REDU=2.0D0
34207       IF (ITWTHC.GT.100)                                        GO TO 30
34208       IF (ITWTH) 220,220,210
34209   240 CONTINUE
34210       ITS(IST  )=IT1
34211       IF (IT2-1.LT.0)                                          GO TO 250
34212       ITS(IST+1)  =IT2
34213       ITS(IST+2)=IT3
34214       RX=CXS(IST)
34215       RY=CYS(IST)
34216       RZ=CZS(IST)
34217       AMM(IST)=AM1
34218       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
34219      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34220       IST=IST+1
34221       AMM(IST)=AM2
34222       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
34223      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34224       IF (IT3.LE.0)                                            GO TO 250
34225       IST=IST+1
34226       AMM(IST)=AM3
34227       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
34228      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34229   250 CONTINUE
34230                                                                GO TO 150
34231   260 CONTINUE
34232   270 CONTINUE
34233       RETURN
34234   280 CONTINUE
34235 C
34236 C----------------------------
34237 C
34238 C   ZERO CROSS SECTION CASE
34239 C----------------------------
34240 C
34241       IRH=1
34242       ITRH(1)=N
34243       CXRH(1)=CX
34244       CYRH(1)=CY
34245       CZRH(1)=CZ
34246       ELRH(1)=ELAB
34247       PLRH(1)=PLAB
34248       RETURN
34249       END
34250
34251 *$ CREATE DT_RUNTT.FOR
34252 *COPY DT_RUNTT
34253 *
34254 *===runtt==============================================================*
34255 *
34256       BLOCK DATA DT_RUNTT
34257
34258       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34259       SAVE
34260
34261       COMMON /HNDRUN/ RUNTES,EFTES
34262
34263       DATA RUNTES,EFTES /100.D0,100.D0/
34264
34265       END
34266
34267 *$ CREATE DT_NONAME.FOR
34268 *COPY DT_NONAME
34269 *
34270 *===noname=============================================================*
34271 *
34272       BLOCK DATA DT_NONAME
34273
34274       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34275       SAVE
34276
34277 * slope parameters for HADRIN interactions
34278       COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
34279       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34280
34281 C     DATAS     DATAS    DATAS      DATAS     DATAS
34282 C******          *********
34283       DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
34284      &           207, 224, 241, 252, 268 /
34285       DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
34286      &           220, 241, 262, 279, 296 /
34287       DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
34288      &           3364, 3507, 4011, 4368, 4725, 4912, 5184/
34289
34290 C
34291 C     MASSES FOR THE SLOPE B(M) IN GEV
34292 C     SLOPE B(M) FOR AN MESONIC SYSTEM
34293 C     SLOPE B(M) FOR A BARYONIC SYSTEM
34294
34295 *
34296       DATA SM,BBM,BBB/  0.8D0, 0.85D0,  0.9D0, 0.95D0, 1.D0,
34297      &     1.05D0,  1.1D0, 1.15D0,  1.2D0, 1.25D0,
34298      &      1.3D0,  1.35D0, 1.4D0,  1.45D0,  1.5D0,
34299      &     1.55D0,  1.6D0,  1.65D0, 1.7D0,   1.75D0,
34300      &      1.8D0,  1.85D0, 1.9D0,  1.95D0,  2.D0,
34301      &     15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
34302      &    12.35D0, 11.7D0, 10.85D0, 10.D0,  9.15D0,
34303      &      8.3D0,  7.8D0,  7.3D0,  7.25D0,  7.2D0,
34304      &     6.95D0,  6.7D0,  6.6D0,  6.5D0,   6.3D0,
34305      &      6.1D0,  5.85D0, 5.6D0,  5.35D0,  5.1D0,
34306      &      15.D0,   15.D0, 15.D0,  15.D0,   15.D0, 15.D0, 15.D0,
34307      &     14.2D0,  13.4D0, 12.6D0,
34308      &     11.8D0, 11.2D0, 10.6D0,  9.8D0,    9.D0,
34309      &     8.25D0,  7.5D0, 6.25D0,  5.D0,    4.5D0, 5*4.D0 /
34310 *
34311       END
34312
34313 *$ CREATE DT_DAMG.FOR
34314 *COPY DT_DAMG
34315 *
34316 *===damg===============================================================*
34317 *
34318       DOUBLE PRECISION FUNCTION DT_DAMG(IT)
34319
34320       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34321       SAVE
34322
34323 * particle properties (BAMJET index convention),
34324 * (dublicate of DTPART for HADRIN)
34325       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34326      &                K1H(110),K2H(110)
34327
34328       DIMENSION GASUNI(14)
34329       DATA GASUNI/
34330      *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
34331      *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
34332       DATA GAUNO/2.352D0/
34333       DATA GAUNON/2.4D0/
34334       DATA IO/14/
34335       DATA NSTAB/23/
34336
34337       I=1
34338       IF (IT.LE.0)                                              GO TO 30
34339       IF (IT.LE.NSTAB)                                          GO TO 20
34340       DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
34341       VV=DT_RNDM(DGAUNI)
34342       VV=VV*2.0D0-1.0D0+1.D-16
34343    10 CONTINUE
34344       VO=GASUNI(I)
34345       I=I+1
34346       V1=GASUNI(I)
34347       IF (VV.GT.V1)                                             GO TO 10
34348       UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
34349      &      (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
34350       DAM=GAH(IT)*UNIGA/GAUNO
34351       AAM=AMH(IT)+DAM
34352       DT_DAMG=AAM
34353       RETURN
34354    20 CONTINUE
34355       DT_DAMG=AMH(IT)
34356       RETURN
34357    30 CONTINUE
34358       DT_DAMG=0.0D0
34359       RETURN
34360       END
34361
34362 *$ CREATE DT_DCALUM.FOR
34363 *COPY DT_DCALUM
34364 *
34365 *===dcalum=============================================================*
34366 *
34367       SUBROUTINE DT_DCALUM(N,ITTA)
34368
34369       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34370       SAVE
34371
34372 C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
34373
34374 * particle properties (BAMJET index convention),
34375 * (dublicate of DTPART for HADRIN)
34376       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34377      &                K1H(110),K2H(110)
34378       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34379       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34380       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34381      &                NRK(2,268),NURE(30,2)
34382
34383       IRE=NURE(N,ITTA/8+1)
34384       IEO=IEII(IRE)+1
34385       IEE=IEII(IRE +1)
34386       AM1=AMH(N   )
34387       AM12=AM1**2
34388       AM2=AMH(ITTA)
34389       AM22=AM2**2
34390       DO 10 IE=IEO,IEE
34391         PLAB2=PLABF(IE)**2
34392         ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
34393         UMO(IE)=ELAB
34394    10 CONTINUE
34395       IKO=IKII(IRE)+1
34396       IKE=IKII(IRE +1)
34397       UMOO=UMO(IEO)
34398       DO 30 IK=IKO,IKE
34399         IF(NRK(2,IK).GT.0)                                      GO TO 30
34400         IKI=NRK(1,IK)
34401         AMSS=5.0D0
34402         K11=K1H(IKI)
34403         K22=K2H(IKI)
34404         DO 20 IK1=K11,K22
34405           IN=NZKI(IK1,1)
34406           AMS=AMH(IN)
34407           IN=NZKI(IK1,2)
34408           IF(IN.GT.0)AMS=AMS+AMH(IN)
34409           IN=NZKI(IK1,3)
34410           IF(IN.GT.0) AMS=AMS+AMH(IN)
34411           IF (AMS.LT.AMSS) AMSS=AMS
34412    20   CONTINUE
34413         IF(UMOO.LT.AMSS) UMOO=AMSS
34414         THRESH(IK)=UMOO
34415    30 CONTINUE
34416       RETURN
34417       END
34418
34419 *$ CREATE DT_DCHANH.FOR
34420 *COPY DT_DCHANH
34421 *
34422 *===dchanh=============================================================*
34423 *
34424       SUBROUTINE DT_DCHANH
34425
34426       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34427       SAVE
34428
34429       PARAMETER ( LINP = 10 ,
34430      &            LOUT = 6 ,
34431      &            LDAT = 9 )
34432 * particle properties (BAMJET index convention),
34433 * (dublicate of DTPART for HADRIN)
34434       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34435      &                K1H(110),K2H(110)
34436       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34437       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34438       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34439      &                NRK(2,268),NURE(30,2)
34440
34441       DIMENSION HWT(460),HWK(40),SI(5184)
34442       EQUIVALENCE (WK(1),SI(1))
34443 C--------------------
34444 C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
34445 C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
34446 C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
34447 C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
34448 C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
34449 C--------------------------
34450       IREG=16
34451       DO 90 IRE=1,IREG
34452         IWKO=IRII(IRE)
34453         IEE=IEII(IRE+1)-IEII(IRE)
34454         IKE=IKII(IRE+1)-IKII(IRE)
34455         IEO=IEII(IRE)+1
34456         IIKA=IKII(IRE)
34457 *   modifications to suppress elestic scattering  24/07/91
34458         DO 80 IE=1,IEE
34459           SIS=1.D-14
34460           SINORC=0.0D0
34461           DO 10 IK=1,IKE
34462             IWK=IWKO+IEE*(IK-1)+IE
34463             IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
34464             SIS=SIS+SI(IWK)*SINORC
34465    10     CONTINUE
34466           SIIN(IEO+IE-1)=SIS
34467           SIO=0.D0
34468           IF (SIS.GE.1.D-12)                                    GO TO 20
34469           SIS=1.D0
34470           SIO=1.D0
34471    20     CONTINUE
34472           SINORC=0.0D0
34473           DO 30 IK=1,IKE
34474             IWK=IWKO+IEE*(IK-1)+IE
34475             IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
34476             SIO=SIO+SI(IWK)*SINORC/SIS
34477             HWK(IK)=SIO
34478    30     CONTINUE
34479           DO 40 IK=1,IKE
34480             IWK=IWKO+IEE*(IK-1)+IE
34481    40     WK(IWK)=HWK(IK)
34482           IIKI=IKII(IRE)
34483           DO 70 IK=1,IKE
34484             AM111=0.D0
34485             INRK1=NRK(1,IIKI+IK)
34486             IF (INRK1.GT.0) AM111=AMH(INRK1)
34487             AM222=0.D0
34488             INRK2=NRK(2,IIKI+IK)
34489             IF (INRK2.GT.0) AM222=AMH(INRK2)
34490             THRESH(IIKI+IK)=AM111 +AM222
34491             IF (INRK2-1.GE.0)                                   GO TO 60
34492             INRKK=K1H(INRK1)
34493             AMSS=5.D0
34494             INRKO=K2H(INRK1)
34495             DO 50 INRK1=INRKK,INRKO
34496               INZK1=NZKI(INRK1,1)
34497               INZK2=NZKI(INRK1,2)
34498               INZK3=NZKI(INRK1,3)
34499               IF (INZK1.LE.0.OR.INZK1.GT.110)                   GO TO 50
34500               IF (INZK2.LE.0.OR.INZK2.GT.110)                   GO TO 50
34501               IF (INZK3.LE.0.OR.INZK3.GT.110)                   GO TO 50
34502 C     WRITE (6,310)INRK1,INZK1,INZK2,INZK3
34503  1000 FORMAT (4I10)
34504               AMS=AMH(INZK1)+AMH(INZK2)
34505               IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
34506               IF (AMSS.GT.AMS) AMSS=AMS
34507    50       CONTINUE
34508             AMS=AMSS
34509             IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
34510             THRESH(IIKI+IK)=AMS
34511    60       CONTINUE
34512    70     CONTINUE
34513    80   CONTINUE
34514    90 CONTINUE
34515       DO 100 J=1,460
34516   100 HWT(J)=0.D0
34517       DO 120 I=1,110
34518         IK1=K1H(I)
34519         IK2=K2H(I)
34520         HV=0.D0
34521         IF (IK2.GT.460)IK2=460
34522         IF (IK1.LE.0)IK1=1
34523         DO 110 J=IK1,IK2
34524           HV=HV+WTI(J)
34525           HWT(J)=HV
34526           JI=J
34527   110   CONTINUE
34528         IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
34529  1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
34530   120 CONTINUE
34531       DO 130 J=1,460
34532   130 WTI(J)=HWT(J)
34533       RETURN
34534       END
34535
34536 *$ CREATE DT_DHADDE.FOR
34537 *COPY DT_DHADDE
34538 *
34539 *===dhadde=============================================================*
34540 *
34541       SUBROUTINE DT_DHADDE
34542
34543       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34544       SAVE
34545
34546 * particle properties (BAMJET index convention)
34547       CHARACTER*8  ANAME
34548       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
34549      &                IICH(210),IIBAR(210),K1(210),K2(210)
34550 * HADRIN: decay channel information
34551       PARAMETER (IDMAX9=602)
34552       CHARACTER*8 ZKNAME
34553       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
34554 * particle properties (BAMJET index convention),
34555 * (dublicate of DTPART for HADRIN)
34556       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34557      &                K1H(110),K2H(110)
34558       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34559 * decay channel information for HADRIN
34560       COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
34561      &                K1Z(16),K2Z(16),WTZ(153),II22,
34562      &                NZK1(153),NZK2(153),NZK3(153)
34563
34564       DATA IRETUR/0/
34565
34566       IRETUR=IRETUR+1
34567       AMH(31)=0.48D0
34568       IF (IRETUR.GT.1) RETURN
34569       DO 10 I=1,94
34570         AMH(I)   = AAM(I)
34571         GAH(I)   = GA(I)
34572         TAUH(I)  = TAU(I)
34573         ICHH(I)  = IICH(I)
34574         IBARH(I) = IIBAR(I)
34575         K1H(I)   = K1(I)
34576         K2H(I)   = K2(I)
34577    10 CONTINUE
34578 **sr
34579 C     AMH(1)=0.93828D0
34580       AMH(1)=0.9383D0
34581 **
34582       AMH(2)=AMH(1)
34583       DO 20 I=26,30
34584         K1H(I)=452
34585         K2H(I)=452
34586    20 CONTINUE
34587       DO 30 I=1,307
34588         WTI(I)    = WT(I)
34589         NZKI(I,1) = NZK(I,1)
34590         NZKI(I,2) = NZK(I,2)
34591         NZKI(I,3) = NZK(I,3)
34592    30 CONTINUE
34593       DO 40 I=1,16
34594         L=I+94
34595         AMH(L)=AMZ(I)
34596         GAH( L)=GAZ(I)
34597         TAUH( L)=TAUZ(I)
34598         ICHH( L)=ICHZ(I)
34599         IBARH( L)=IBARZ(I)
34600         K1H( L)=K1Z(I)
34601         K2H( L)=K2Z(I)
34602    40 CONTINUE
34603       DO 50 I=1,153
34604         L=I+307
34605         WTI(L)    = WTZ(I)
34606         NZKI(L,3) = NZK3(I)
34607         NZKI(L,2) = NZK2(I)
34608         NZKI(L,1) = NZK1(I)
34609    50 CONTINUE
34610       RETURN
34611       END
34612
34613 *$ CREATE IDT_IEFUND.FOR
34614 *COPY IDT_IEFUND
34615 *
34616 *===iefund=============================================================*
34617 *
34618       INTEGER FUNCTION IDT_IEFUND(PL,IRE)
34619
34620       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34621       SAVE
34622
34623 C*****IEFUN CALCULATES A MOMENTUM INDEX
34624
34625       PARAMETER ( LINP = 10 ,
34626      &            LOUT = 6 ,
34627      &            LDAT = 9 )
34628       COMMON /HNDRUN/ RUNTES,EFTES
34629       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34630       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34631      &                NRK(2,268),NURE(30,2)
34632
34633       IPLA=IEII(IRE)+1
34634      *+1
34635       IPLE=IEII(IRE+1)
34636       IF (PL.LT.0.)                                             GO TO 30
34637       DO 10 I=IPLA,IPLE
34638         J=I-IPLA+1
34639         IF (PL.LE.PLABF(I))                                     GO TO 60
34640    10 CONTINUE
34641       I=IPLE
34642       IF ( EFTES.GT.40.D0)                                      GO TO 20
34643       EFTES=EFTES+1.0D0
34644       WRITE(LOUT,1000)PL,J
34645    20 CONTINUE
34646                                                                 GO TO 70
34647    30 CONTINUE
34648       DO 40 I=IPLA,IPLE
34649         J=I-IPLA+1
34650         IF (-PL.LE.UMO(I))                                      GO TO 60
34651    40 CONTINUE
34652       I=IPLE
34653       IF ( EFTES.GT.40.D0)                                      GO TO 50
34654       EFTES=EFTES+1.0D0
34655       WRITE(LOUT,1000)PL,I
34656    50 CONTINUE
34657    60 CONTINUE
34658    70 CONTINUE
34659       IDT_IEFUND=I
34660       RETURN
34661  1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
34662      +7H IEFUN=,I5)
34663       END
34664
34665 *$ CREATE DT_DSIGIN.FOR
34666 *COPY DT_DSIGIN
34667 *
34668 *===dsigin=============================================================*
34669 *
34670       SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
34671
34672       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34673       SAVE
34674
34675 * particle properties (BAMJET index convention),
34676 * (dublicate of DTPART for HADRIN)
34677       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34678      &                K1H(110),K2H(110)
34679       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34680       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34681      &                NRK(2,268),NURE(30,2)
34682
34683       IE=IDT_IEFUND(PLAB,IRE)
34684       IF (IE.LE.IEII(IRE)) IE=IE+1
34685       AMT=AMH(ITAR)
34686       AMN=AMH(N)
34687       AMN2=AMN*AMN
34688       AMT2=AMT*AMT
34689       ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
34690 C*** INTERPOLATION PREPARATION
34691       ECMO=UMO(IE)
34692       ECM1=UMO(IE-1)
34693       DECM=ECMO-ECM1
34694       DEC=ECMO-ECM
34695       IIKI=IKII(IRE)+1
34696       EKLIM=-THRESH(IIKI)
34697       WOK=SIIN(IE)
34698       WDK=WOK-SIIN(IE-1)
34699       IF (ECM.GT.ECMO) WDK=0.0D0
34700 C*** INTERPOLATION IN CHANNEL WEIGHTS
34701       IELIM=IDT_IEFUND(EKLIM,IRE)
34702       DELIM=UMO(IELIM)+EKLIM
34703      *+1.D-16
34704       DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
34705       IF (DELIM*DELIM-DETE*DETE) 20,20,10
34706    10 DECC=DELIM
34707                                                                 GO TO 30
34708    20 DECC=DECM
34709    30 CONTINUE
34710       WKK=WOK-WDK*DEC/(DECC+1.D-9)
34711       IF (WKK.LT.0.0D0) WKK=0.0D0
34712       SI=WKK+1.D-12
34713       IF (-EKLIM.GT.ECM) SI=1.D-14
34714       RETURN
34715       END
34716
34717 *$ CREATE DT_DTCHOI.FOR
34718 *COPY DT_DTCHOI
34719 *
34720 *===dtchoi=============================================================*
34721 *
34722       SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
34723
34724       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34725       SAVE
34726
34727 C     ****************************
34728 C     TCHOIC CALCULATES A RANDOM VALUE
34729 C     FOR THE FOUR-MOMENTUM-TRANSFER T
34730 C     ****************************
34731
34732 * particle properties (BAMJET index convention),
34733 * (dublicate of DTPART for HADRIN)
34734       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34735      &                K1H(110),K2H(110)
34736 * slope parameters for HADRIN interactions
34737       COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
34738
34739       AMA=AM1
34740       AMB=AM2
34741       IF (I.GT.30.AND.II.GT.30)                                 GO TO 20
34742       III=II
34743       AM3=AM2
34744       IF (I.LE.30)                                              GO TO 10
34745       III=I
34746       AM3=AM1
34747    10 CONTINUE
34748                                                                 GO TO 30
34749    20 CONTINUE
34750       III=II
34751       AM3=AM2
34752       IF (AMA.LE.AMB)                                           GO TO 30
34753       III=I
34754       AM3=AM1
34755    30 CONTINUE
34756       IB=IBARH(III)
34757       AMA=AM3
34758       K=INT((AMA-0.75D0)/0.05D0)
34759       IF (K-2.LT.0) K=1
34760       IF (K-26.GE.0) K=25
34761       IF (IB)50,40,50
34762    40 BM=BBM(K)
34763                                                                 GO TO 60
34764    50 BM=BBB(K)
34765    60 CONTINUE
34766 C     NORMALIZATION
34767       TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1  **2
34768       TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1  **2
34769       VB=DT_RNDM(TMIN)
34770 **sr test
34771 C     IF (VB.LT.0.2D0) BM=BM*0.1
34772 C    **0.5
34773       BM = BM*5.05D0
34774 **
34775       TMI=BM*TMIN
34776       TMA=BM*TMAX
34777       ETMA=0.D0
34778       IF (ABS(TMA).GT.120.D0)                                   GO TO 70
34779       ETMA=EXP(TMA)
34780    70 CONTINUE
34781       AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
34782 C*** RANDOM CHOICE OF THE T - VALUE
34783       R=DT_RNDM(TMI)
34784       T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
34785       RETURN
34786       END
34787
34788 *$ CREATE DT_DTWOPA.FOR
34789 *COPY DT_DTWOPA
34790 *
34791 *===dtwopa=============================================================*
34792 *
34793       SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
34794      &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
34795
34796       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34797       SAVE
34798
34799 C     ******************************************************
34800 C     QUASI TWO PARTICLE PRODUCTION
34801 C     TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
34802 C     FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
34803 C     IN THE CM - SYSTEM
34804 C     COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
34805 C     SPHERICAL COORDINATES
34806 C     ******************************************************
34807
34808 * particle properties (BAMJET index convention),
34809 * (dublicate of DTPART for HADRIN)
34810       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34811      &                K1H(110),K2H(110)
34812
34813       AMA=AM1
34814       AMB=AM2
34815       AMA2=AMA*AMA
34816       E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
34817       E2=UMOO - E1
34818       IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
34819       AMTE=(E1-AMA)*(E1+AMA)
34820       AMTE=AMTE+1.D-18
34821       P1=SQRT(AMTE)
34822       P2=P1
34823 C     / P2 / = / P1 /  BUT OPPOSITE DIRECTIONS
34824 C     DETERMINATION  OF  THE ANGLES
34825 C     COS(THETA1)=COD1      COS(THETA2)=COD2
34826 C     SIN(PHI1)=SIF1        SIN(PHI2)=SIF2
34827 C     COS(PHI1)=COF1        COS(PHI2)=COF2
34828 C     PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
34829       CALL DT_DSFECF(COF1,SIF1)
34830       COF2=-COF1
34831       SIF2=-SIF1
34832 C     CALCULATION OF THETA1
34833       CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
34834       COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
34835       IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
34836       COD2=-COD1
34837       RETURN
34838       END
34839
34840 *$ CREATE DT_ZK.FOR
34841 *COPY DT_ZK
34842 *
34843 *===zk=================================================================*
34844 *
34845       BLOCK DATA DT_ZK
34846
34847       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34848       SAVE
34849
34850 * decay channel information for HADRIN
34851       COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
34852      &                K1Z(16),K2Z(16),WTZ(153),II22,
34853      &                NZK1(153),NZK2(153),NZK3(153)
34854 * decay channel information for HADRIN
34855       CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
34856       COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
34857
34858 *     Particle masses in GeV                                           *
34859       DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
34860      &          2*1.7D0, 3*0.D0/
34861 *     Resonance width Gamma in GeV                                     *
34862       DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
34863 *     Mean life time in seconds                                        *
34864       DATA TAUZ / 16*0.D0 /
34865 *     Charge of particles and resonances                               *
34866       DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
34867 *     Baryonic charge                                                  *
34868       DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
34869 *     First number of decay channels used for resonances               *
34870 *     and decaying particles                                           *
34871       DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
34872      &          3*460/
34873 *     Last number of decay channels used for resonances                *
34874 *     and decaying particles                                           *
34875       DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
34876      &          3*460/
34877 *     Weight of decay channel                                          *
34878       DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
34879      & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
34880      & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
34881      & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
34882      & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
34883      & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
34884      & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
34885      & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
34886      & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
34887      & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
34888      & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
34889      & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
34890      & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
34891      & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
34892      & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
34893      & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
34894      & .05D0, .65D0, 9*1.D0 /
34895 *     Particle numbers in decay channel                                *
34896       DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
34897      & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
34898      & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
34899      & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
34900      & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
34901      & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
34902      & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
34903      & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
34904       DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
34905      & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
34906      & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
34907      & 4*33, 32, 3*35,  2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
34908      & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
34909      & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
34910      & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
34911      & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
34912      & 1, 8, 1, 8, 1, 9*0 /
34913       DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
34914      & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
34915      & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
34916      & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
34917      & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
34918      & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
34919 *     Particle  names                                                  *
34920       DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS  ',' PAP  ',' PAN  ',
34921      & 'APN', 'DEO   ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
34922      & 3*'BLANK' /
34923 *     Name of decay channel                                            *
34924       DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
34925      & 'ANNPI0','APPPI0','ANPPI-'/
34926       DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K-  ','K0AK0 ',
34927      & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET  ','&0R0  ','P-R+  ',
34928      & 'P+R-  ','POOM  ',' ETET ','ETSP0 ','R0ET  ',' R0R0 ','R+R-  ',
34929      & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
34930      & 'P+R-R0','R0OM  ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
34931      & 'P+R-OM','OMOM  ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
34932      & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
34933      & 'OMOMOM',
34934      & ' P+PO ','P+POPO','P+P+P-','P+ET  ','P0R+  ','P+R0  ','ETSP+ ',
34935      & 'R+ET  ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
34936      & 'P+R-R+','R+OM  ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
34937      & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
34938      & 'P-PO  ','P-POPO','P-P-P+','P-ET  ','POR-  ','P-R0  ','ETSP- ',
34939      & 'R-ET  ','R-R0  ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
34940       DATA ZKNAM6/'P+R-R-','R-OM  ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
34941      & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
34942      & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO  ','LPI+  ',
34943      & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
34944      & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
34945      & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
34946      & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
34947      & 9*'BLANK'/
34948 *=                                               end*block.zk      *
34949       END
34950
34951 *$ CREATE DT_BLKD43.FOR
34952 *COPY DT_BLKD43
34953 *
34954 *===blkd43=============================================================*
34955 *
34956       BLOCK DATA DT_BLKD43
34957
34958       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34959       SAVE
34960
34961 *
34962 *=== reac =============================================================*
34963 *
34964 *----------------------------------------------------------------------*
34965 *                                                                      *
34966 *     Created on 10 december 1991  by    Alfredo Ferrari & Paola Sala  *
34967 *                                                   Infn - Milan       *
34968 *                                                                      *
34969 *     Last change on 10-dec-91     by    Alfredo Ferrari               *
34970 *                                                                      *
34971 *     This is the original common reac of Hadrin                       *
34972 *                                                                      *
34973 *----------------------------------------------------------------------*
34974 *
34975       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34976      &                NRK(2,268),NURE(30,2)
34977
34978       DIMENSION
34979      & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
34980      & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
34981      & SPIKP1(315), SPIKPU(278), SPIKPV(372),
34982      & SPIKPW(278), SPIKPX(372), SPIKP4(315),
34983      & SPIKP5(187), SPIKP6(289),
34984      & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
34985      & SPIKP9(143), SPIKP0(169), SPKPV(143),
34986      & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
34987      & SANPEL(84) , SPIKPF(273),
34988      & SPKP15(187), SPKP16(272),
34989      & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
34990      & NURELN(60)
34991 *
34992        DIMENSION NRKLIN(532)
34993        EQUIVALENCE (NRK(1,1), NRKLIN(1))
34994        EQUIVALENCE (   UMO(  1),  UMOPI(1)), (   UMO( 93),  UMOKC(1))
34995        EQUIVALENCE (   UMO(161),   UMOP(1)), (   UMO(200),   UMON(1))
34996        EQUIVALENCE (   UMO(263),  UMOK0(1))
34997        EQUIVALENCE ( PLABF(  1),  PLAPI(1)), ( PLABF( 93),  PLAKC(1))
34998        EQUIVALENCE ( PLABF(161),   PLAP(1)), ( PLABF(200),   PLAN(1))
34999        EQUIVALENCE ( PLABF(263),  PLAK0(1))
35000        EQUIVALENCE (   WK(   1), SPIKP1(1)), (   WK( 316), SPIKPU(1))
35001        EQUIVALENCE (   WK( 594), SPIKPV(1)), (   WK( 966), SPIKPW(1))
35002        EQUIVALENCE (   WK(1244), SPIKPX(1)), (   WK(1616), SPIKP4(1))
35003        EQUIVALENCE (   WK(1931), SPIKP5(1)), (   WK(2118), SPIKP6(1))
35004        EQUIVALENCE (   WK(2407), SKMPEL(1)), (   WK(2509), SPIKP7(1))
35005        EQUIVALENCE (   WK(2798), SKMNEL(1)), (   WK(2866), SPIKP8(1))
35006        EQUIVALENCE (   WK(3053), SPIKP9(1)), (   WK(3196), SPIKP0(1))
35007        EQUIVALENCE (   WK(3365),  SPKPV(1)), (   WK(3508), SAPPEL(1))
35008        EQUIVALENCE (   WK(3613), SPIKPE(1)), (   WK(4012), SAPNEL(1))
35009        EQUIVALENCE (   WK(4096), SPIKPZ(1)), (   WK(4369), SANPEL(1))
35010        EQUIVALENCE (   WK(4453), SPIKPF(1)), (   WK(4726), SPKP15(1))
35011        EQUIVALENCE (   WK(4913), SPKP16(1))
35012        EQUIVALENCE (NRK(1,1), NRKLIN(1))
35013        EQUIVALENCE (NRKLIN(   1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
35014        EQUIVALENCE (NRKLIN( 297),  NRKP(1)), (NRKLIN( 367),  NRKN(1))
35015        EQUIVALENCE (NRKLIN( 483), NRKK0(1))
35016        EQUIVALENCE (NURE(1,1), NURELN(1))
35017 *
35018 **** pi- p data                                                        *
35019 **** pi+ n data                                                        *
35020       DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
35021      & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
35022      & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
35023      & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
35024      & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
35025      & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
35026      & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
35027      & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
35028      & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
35029      & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
35030       DATA PLAKC /
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      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35038      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35039      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35040      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35041      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35042      & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
35043       DATA PLAK0 /
35044      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35045      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35046      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35047      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35048      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35049      & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
35050 *                 pp   pn   np   nn                                    *
35051       DATA PLAP /
35052      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35053      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35054      &   0.D0, 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      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35057      & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
35058 *    app   apn   anp   ann                                             *
35059       DATA PLAN /
35060      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
35061      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35062      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35063      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
35064      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35065      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35066      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
35067      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35068      & 3.43D0, 3.75D0, 4.07D0, 4.43D0  /
35069       DATA SIIN / 296*0.D0 /
35070       DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
35071      & 1.557D0,1.615D0,1.6435D0,
35072      & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
35073      & 2.286D0,2.366D0,2.482D0,2.56D0,
35074      & 2.735D0,2.90D0,
35075      &             1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
35076      & 1.496D0,1.527D0,1.557D0,
35077      & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
35078      & 2.071D0,2.159D0,2.286D0,2.366D0,
35079      & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
35080      &             1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
35081      & 1.496D0,1.527D0,1.557D0,
35082      & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
35083      & 2.071D0,2.159D0,2.286D0,2.366D0,
35084      & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
35085      &                   1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
35086      & 1.557D0,1.615D0,1.6435D0,
35087      & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
35088      & 2.286D0,2.366D0,2.482D0,2.56D0,
35089      &  2.735D0, 2.90D0/
35090       DATA UMOKC/ 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,1.44D0,
35097      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35098      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35099      & 3.1D0,1.44D0,
35100      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35101      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35102      &  3.1D0/
35103       DATA UMOK0/ 1.44D0,
35104      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35105      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35106      & 3.1D0,1.44D0,
35107      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35108      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35109      &  3.1D0/
35110 *                 pp   pn   np   nn                                    *
35111       DATA UMOP/
35112      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35113      & 3.D0,3.1D0,3.2D0,
35114      & 1.88D0,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      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35117      & 3.D0,3.1D0,3.2D0/
35118 *    app   apn   anp   ann                                             *
35119       DATA UMON /
35120      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35121      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35122      & 3.D0,3.1D0,3.2D0,
35123      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35124      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35125      & 3.D0,3.1D0,3.2D0,
35126      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35127      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35128      &  3.D0,3.1D0,3.2D0/
35129 **** reaction channel state particles                                  *
35130       DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
35131      & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
35132      & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
35133      & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
35134      & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
35135      & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
35136      & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
35137      & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
35138      & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
35139      & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
35140       DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
35141      & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
35142      & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
35143      & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
35144      & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
35145      & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
35146      & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
35147      & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
35148 *                                                                      *
35149 *   k0 p   k0 n   ak0 p   ak/ n                                        *
35150 *                                                                      *
35151       DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
35152      & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13,   22, 13, 21, 23,
35153      & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
35154      & 53, 47, 1, 103, 0, 93, 0/
35155 *   pp  pn   np   nn                                                   *
35156       DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
35157      & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
35158      & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
35159      & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
35160 *     app   apn   anp   ann                                            *
35161       DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
35162      & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
35163      & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
35164      & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
35165      & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
35166      & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
35167      & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
35168 **** channel cross section                                             *
35169       DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
35170      & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
35171      & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
35172      & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
35173      & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
35174      &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
35175      & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
35176      & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
35177      &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
35178      & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
35179      & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
35180      & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
35181      & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
35182      & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
35183      & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
35184      & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
35185      & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
35186      & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
35187      & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
35188      & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
35189 **** pi+ n data                                                        *
35190       DATA SPIKPU/   0.D0, 25.D0, 13.D0,  11.D0, 10.5D0, 14.D0,  20.D0,
35191      & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
35192      & 10.D0, 10.D0, 9.5D0,  9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
35193      & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0,   5.5D0,  4.8D0,
35194      & 4.2D0, 7.5D0, 3.4D0,  2.5D0, 2.5D0, 2.1D0, 1.4D0,   1.D0,   .8D0,
35195      &  .6D0, .46D0,  .3D0, .2D0, .15D0, .13D0, 11*0.D0,  .95D0,  .65D0,
35196      & .48D0, .35D0,  .2D0, .18D0, .17D0, .16D0,  .15D0,   .1D0,  .09D0,
35197      & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0,  .2D0,   .1D0,
35198      & .08D0, .06D0, .045D0,   .03D0, .02D0, .01D0,      .005D0, .003D0,
35199      & 12*0.D0, .3D0, .24D0,   .18D0, .15D0, .13D0,  .12D0, .11D0, .1D0,
35200      & .09D0,  .08D0, .05D0,   .04D0, .03D0,  0.D0, 0.16D0, .7D0, 1.3D0,
35201      & 3.1D0,  4.5D0,  2.D0, 18*0.D0, 3*.0D0,  0.D0, 0.D0, 4.0D0, 11.D0,
35202      & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0,  1.5D0, .9D0, .55D0,
35203      &  .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0,   2.25D0, 3.3D0,
35204      & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
35205      & .64D0,  1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0,  4.4D0,   3.D0, 1.8D0,
35206      &  .9D0, .53D0, .28D0,      10*0.D0, 2*0.D0,  .25D0,  .82D0,
35207      & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0,  5.7D0, 3.9D0, 2.35D0, 1.15D0,
35208      & .69D0, .37D0, 10*0.D0,     7*0.D0,   .0D0, .34D0,  1.5D0, 3.47D0,
35209      & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0,  .3D0,  .15D0, 6*0.D0/
35210 *
35211       DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
35212      & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
35213      & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
35214      & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
35215      & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
35216      & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
35217      & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
35218      & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
35219      & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
35220      & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
35221      & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
35222      & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
35223      & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
35224      & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
35225      & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
35226      & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
35227      & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
35228      & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
35229      & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
35230      & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
35231 **** pi- p data                                                        *
35232       DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
35233      & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
35234      & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
35235      & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
35236      & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
35237      & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
35238      & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
35239      & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
35240      & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
35241      & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
35242      & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
35243      & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
35244      & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
35245      & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
35246      & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
35247      & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
35248      & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
35249      & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
35250      & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
35251 *
35252       DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
35253      & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
35254      & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
35255      & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
35256      & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
35257      & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
35258      & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
35259      & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
35260      & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
35261      & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
35262      & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
35263      & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
35264      & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
35265      & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
35266      & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
35267      & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
35268      & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
35269      & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
35270      & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
35271      & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
35272 **** pi- n data                                                        *
35273       DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
35274      & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
35275      & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
35276      & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
35277      & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
35278      & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
35279      & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
35280      & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
35281      & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
35282      & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
35283      & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
35284      & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
35285      & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
35286      & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
35287      & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
35288      & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
35289      & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
35290      & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
35291      & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
35292      & 3.3D0, 5.4D0, 7.D0 /
35293 **** k+  p data                                                        *
35294       DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
35295      & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
35296      & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
35297      & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
35298      & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
35299      & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35300      & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
35301      & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
35302      & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
35303      & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
35304      & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0,
35305      & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0,
35306      & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
35307 **** k+  n data                                                        *
35308       DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
35309      & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
35310      & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
35311      & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
35312      & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
35313      & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
35314      & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
35315      & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
35316      & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
35317      & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
35318      & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
35319      & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
35320      & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
35321      & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
35322      & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
35323      & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
35324      & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
35325      & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
35326      & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
35327 **** k-  p data                                                        *
35328       DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
35329      &     7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
35330      &    0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
35331      &    .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
35332      &    0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
35333      &    .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
35334      &    0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
35335      &    .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
35336      &    0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
35337      &    .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
35338      &    0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
35339      &    .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
35340       DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
35341      & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
35342      & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
35343      & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
35344      & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,  3*0.D0, 1.0D0, 3.03D0,
35345      & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
35346      & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
35347      & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
35348      & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
35349      & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
35350      & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
35351      & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
35352      & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
35353      & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
35354      & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
35355      & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
35356      & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
35357      & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
35358      & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
35359      & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
35360      & 10*0.D0/
35361 ***** k- n data                                                        *
35362       DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
35363      &        3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
35364      &        0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
35365      &        1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
35366      &        0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
35367      &        .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
35368      &        0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
35369      &       .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
35370       DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
35371      &  14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
35372      &  1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
35373      &  3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
35374      &  1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
35375      &  3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
35376      &  1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
35377      &  7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
35378      &  .39D0, .22D0, .07D0, 0.D0,
35379      &  6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
35380      &  4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
35381      &  10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
35382      &  13*0.D0, .1D0, .3D0, .7D0, 1.D0,
35383      &  13*0.D0, .1D0, .3D0, .7D0, 1.D0,
35384      &  9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
35385      &  5.10D0, 5.44D0, 5.3D0,
35386      &  4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
35387 *****  p p data                                                        *
35388       DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35389      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35390      &              0.D0, 3.6D0, 1.7D0, 10*0.D0,
35391      &              .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
35392      &              11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
35393      &              .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
35394      &              2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
35395      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35396      &              16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
35397      &              10*0.D0, 4.3D0, 7.6D0, 9.D0,
35398      &              10*0.D0, 1.7D0, 2.6D0, 3.D0,
35399      &              6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
35400      &              6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
35401      &              1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
35402      &              10*0.D0, 1.9D0, 4.1D0, 5.2D0/
35403 *****  p n data                                                        *
35404       DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35405      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35406      &              0.D0, 1.8D0, .2D0,  12*0.D0,
35407      &              3.2D0, 6.05D0, 9.9D0, 5.1D0,
35408      &              3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
35409      &              2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
35410      &              3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
35411      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35412      &              16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
35413      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35414      &              16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
35415      &              10*0.D0, .7D0, 5.1D0, 8.D0,
35416      &              10*0.D0, .7D0, 5.1D0, 8.D0,
35417      &              10*.0D0, .3D0, 2.8D0, 4.7D0,
35418      &              10*.0D0, .3D0, 2.8D0, 4.7D0,
35419      &              7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
35420      &              7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
35421      &              5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
35422 *   nn - data                                                          *
35423 *                                                                      *
35424       DATA SPKPV/  0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35425      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35426      &              0.D0, 3.6D0, 1.7D0, 12*0.D0,
35427      &              8.7D0, 17.7D0, 18.8D0, 15.9D0,
35428      &              11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
35429      &              .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
35430      &              2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
35431      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
35432      &              11.D0, 5.5D0, 3.5D0,
35433      &              10*0.D0, 4.3D0, 7.6D0, 9.D0,
35434      &              10*0.D0, 1.7D0, 2.6D0, 3.D0,
35435      &              6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
35436      &              6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
35437      &              1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
35438      &              10*0.D0, 1.9D0, 4.1D0, 5.2D0/
35439 ****************   ap - p - data                                       *
35440       DATA SAPPEL/ 0.D0,  176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
35441      &  50.D0,  50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
35442      &  25.D0,  22.D0, 21.D0, 20.D0, 18.D0, 17.D0,  11*0.D0,
35443      &  .05D0,  .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
35444      &  0.D0,  1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
35445      &  .1D0,  .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
35446      &  0.D0,  55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
35447      &  10.D0,  7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
35448      &  1.55D0,  1.3D0, .95D0, .75D0,
35449      &  0.D0,  3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
35450      &  .25D0,  .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35451      & .01D0,  .008D0, .006D0, .005D0/
35452       DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35453      & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35454      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
35455      & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
35456      & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
35457      & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
35458      & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
35459      & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
35460      & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
35461      & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0,
35462      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35463      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35464      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35465      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
35466      & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
35467      & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
35468      & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
35469      & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
35470      & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
35471      & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
35472 ****************   ap - n - data                                       *
35473       DATA SAPNEL/
35474      & 0.D0,  176.D0, 160.D0, 105.D0, 75.D0,  68.D0, 65.D0,
35475      & 50.D0, 50.D0,  43.D0,  42.D0,  40.5D0, 35.D0, 30.D0,  28.D0,
35476      & 25.D0, 22.D0,  21.D0,  20.D0,  18.D0,  17.D0, 11*0.D0,
35477      & .05D0, .15D0, .18D0,  .2D0,    .2D0,  .3D0,  .4D0,   .6D0,  .7D0,
35478      & .85D0,  0.D0,  1.D0,  .9D0,    .46D0, .3D0,  .23D0, .18D0, .16D0,
35479      & .14D0,  .1D0, .08D0, .05D0,    .02D0, .015D0, 4*.011D0, 3*.005D0,
35480      & 0.D0,  3.3D0,  3.D0, 1.5D0,     1.D0, .7D0,  .4D0,  .35D0, .4D0,
35481      & .25D0, .18D0, .08D0, .04D0,    .03D0, .023D0, .016D0, .014D0,
35482      & .01D0, .008D0, .006D0, .005D0 /
35483        DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35484      &  84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35485      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
35486      & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35487      & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
35488      & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
35489      & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
35490      & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35491      & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35492      & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35493      & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
35494      & 4.9D0, 8.5D0,  15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
35495      & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
35496      & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
35497 *                                                                      *
35498 *                                                                      *
35499 ****************   an - p - data                                       *
35500 *                                                                      *
35501       DATA SANPEL/
35502      & 0.D0,  176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
35503      & 50.D0, 43.D0,  42.D0,  40.5D0, 35.D0, 30.D0, 28.D0,
35504      & 25.D0, 22.D0,  21.D0,  20.D0,  18.D0, 17.D0, 11*0.D0, .05D0,
35505      & .15D0, .18D0,   .2D0,   .2D0,   .3D0,  .4D0, .6D0,   .7D0, .85D0,
35506      & 0.D0,   1.D0,   .9D0,  .46D0,  .3D0,  .23D0, .18D0, .16D0, .14D0,
35507      & .1D0,  .08D0,  .05D0,  .02D0, .015D0, 4*.011D0, 3*.005D0,
35508      & 0.D0,  3.3D0,  3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
35509      & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35510      & .01D0, .008D0, .006D0, .005D0 /
35511       DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35512      & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35513      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
35514      & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35515      & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
35516      & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
35517      & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
35518      & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35519      & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35520      & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35521      & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
35522      & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
35523      & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
35524      & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
35525 ****  ko - n - data                                                    *
35526       DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
35527      &      6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
35528      &      0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
35529      &    3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
35530      &     1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35531      &    3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
35532      &     1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35533      &    4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
35534      &     1.4D0, 1.2D0, 1.05D0, .9D0, .66D0,  .5D0,
35535      &    7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
35536      &   11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
35537      &    4.85D0, 4.9D0,
35538      &   10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
35539      &    6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
35540      &    2.85D0, 2.35D0, 2.01D0, 1.8D0,
35541      &   12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
35542      &   12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0  /
35543 **** ako - p - data                                                    *
35544       DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
35545      & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
35546      & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
35547      & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
35548      & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
35549      & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
35550      & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
35551      & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
35552      & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
35553      & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
35554      & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
35555      & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
35556      & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
35557      & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
35558      & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
35559      & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
35560      & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
35561      & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
35562      & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
35563      & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
35564      & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
35565       DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
35566      & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
35567 *=                                               end*block.blkdt3      *
35568       END
35569
35570 *$ CREATE DT_QEL_POL.FOR
35571 *COPY DT_QEL_POL
35572 *
35573 *===qel_pol============================================================*
35574 *
35575       SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
35576
35577       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35578       SAVE
35579
35580       CALL DT_MASS_INI
35581       CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
35582
35583       RETURN
35584       END
35585
35586 *$ CREATE DT_GEN_QEL.FOR
35587 *COPY DT_GEN_QEL
35588 C==================================================================
35589 C   Generation of  a Quasi-Elastic neutrino scattering
35590 C==================================================================
35591 *
35592 *===gen_qel============================================================*
35593 *
35594       SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
35595
35596 C...Generate a quasi-elastic   neutrino/antineutrino
35597 C.  Interaction on a nuclear target
35598 C.  INPUT  : LTYP = neutrino type (1,...,6)
35599 C.           ENU (GeV) = neutrino energy
35600 C----------------------------------------------------
35601
35602       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35603       SAVE
35604
35605       PARAMETER ( LINP = 10 ,
35606      &            LOUT = 6 ,
35607      &            LDAT = 9 )
35608       PARAMETER (MAXLND=4000)
35609       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
35610 * nuclear potential
35611       LOGICAL LFERMI
35612       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
35613      &                EBINDP(2),EBINDN(2),EPOT(2,210),
35614      &                ETACOU(2),ICOUL,LFERMI
35615 * steering flags for qel neutrino scattering modules
35616       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
35617 **sr - removed (not needed)
35618 C     COMMON /CBAD/  LBAD, NBAD
35619 C     COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
35620 **
35621
35622       DIMENSION PI(3),PO(3)
35623 CJR+
35624       DATA ININU/0/
35625 CJR-
35626 C     REAL*8 DBETA(3)
35627 C     REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
35628       DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
35629       DATA AMN  /0.93827231D0, 0.93956563D0/
35630       DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
35631       DATA INIPRI/0/
35632
35633 C     DATA PFERMI/0.22D0/
35634 CGB+...Binding Energy
35635       DATA EBIND/0.008D0/
35636 CGB-...
35637
35638       ININU=ININU+1
35639       IF(ININU.EQ.1)NDSIG=0
35640       LBAD = 0
35641       enu0=enu
35642 c      write(*,*) enu0
35643 C...Lepton mass
35644       AML = AML0(LTYP)       !  massa leptoni
35645       AML2 = AML**2          !  massa leptoni **2
35646 C...Particle labels (LUND)
35647       N = 5
35648       K(1,1) = 21
35649       K(2,1) = 21
35650       K(3,1) = 21
35651       K(3,3) = 1
35652       K(4,1) = 1
35653       K(4,3) = 1
35654       K(5,1) = 1
35655       K(5,3) = 2
35656       K0 = (LTYP-1)/2          !  2
35657       K1 = LTYP/2              !  2
35658       KA = 12 + 2*K0           !  16
35659       IS = -1 + 2*LTYP - 4*K1  !  -1 +10 -8 = 1
35660       K(1,2) = IS*KA
35661       K(4,2) = IS*(KA-1)
35662       K(3,2) = IS*24
35663       LNU = 2 - LTYP + 2*K1    !  2 - 5 + 2 = - 1
35664       IF (LNU .EQ. 2)  THEN
35665         K(2,2) = 2212
35666         K(5,2) = 2112
35667         AMI = AMN(1)
35668         AMF = AMN(2)
35669 CJR+
35670         PFERMI=PFERMN(2)
35671 CJR-
35672       ELSE
35673         K(2,2) = 2112
35674         K(5,2) = 2212
35675         AMI = AMN(2)
35676         AMF = AMN(1)
35677 CJR+
35678         PFERMI=PFERMP(2)
35679 CJR-
35680       ENDIF
35681       AMI2 = AMI**2
35682       AMF2 = AMF**2
35683
35684       DO IGB=1,5
35685         P(3,IGB) = 0.
35686         P(4,IGB) = 0.
35687         P(5,IGB) = 0.
35688       END DO
35689
35690       NTRY = 0
35691 CGB+...
35692       EFMAX  = SQRT(PFERMI**2 + AMI2) -AMI             ! max. Fermi Energy
35693       ENWELL = EFMAX + EBIND ! depth of nuclear potential well
35694 CGB-...
35695
35696   100 CONTINUE
35697
35698 C...4-momentum initial lepton
35699       P(1,5) = 0.     ! massa
35700       P(1,4) = ENU0    ! energia
35701       P(1,1) = 0.     ! px
35702       P(1,2) = 0.     ! py
35703       P(1,3) = ENU0    ! pz
35704
35705 C     PF = PFERMI*PYR(0)**(1./3.)
35706 c       write(23,*) PYR(0)
35707 c      write(*,*) 'Pfermi=',PF
35708 c      PF = 0.
35709       NTRY=NTRY+1
35710 C     IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
35711       IF (NTRY .GT. 500)  THEN
35712         LBAD = 1
35713         WRITE (LOUT,1001)  NBAD, ENU
35714         RETURN
35715       ENDIF
35716 C     CT = -1. + 2.*PYR(0)
35717 c      CT = -1.
35718 C     ST =  SQRT(1.-CT*CT)
35719 C     F = 2.*3.1415926*PYR(0)
35720 c      F = 0.
35721
35722 C     P(2,4) = SQRT(PF*PF + MI2) - EBIND  ! energia
35723 C     P(2,1) = PF*ST*COS(F)               ! px
35724 C     P(2,2) = PF*ST*SIN(F)               ! py
35725 C     P(2,3) = PF*CT                      ! pz
35726 C     P(2,5) = SQRT(P(2,4)**2-PF*PF)      ! massa
35727        P(2,1) = P21
35728        P(2,2) = P22
35729        P(2,3) = P23
35730        P(2,4) = P24
35731        P(2,5) = P25
35732       beta1=-p(2,1)/p(2,4)
35733       beta2=-p(2,2)/p(2,4)
35734       beta3=-p(2,3)/p(2,4)
35735       N=2
35736 C      WRITE(6,*)' before transforming into target rest frame'
35737       CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
35738 C      print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
35739       N=5
35740
35741       phi11=atan(p(1,2)/p(1,3))
35742       pi(1)=p(1,1)
35743       pi(2)=p(1,2)
35744       pi(3)=p(1,3)
35745
35746       CALL DT_TESTROT(PI,Po,PHI11,1)
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       phi12=atan(p(1,1)/p(1,3))
35755
35756       pi(1)=p(1,1)
35757       pi(2)=p(1,2)
35758       pi(3)=p(1,3)
35759       CALL DT_TESTROT(Pi,Po,PHI12,2)
35760       DO ll=1,3
35761         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35762       END DO
35763 c        WRITE(*,*) po
35764       p(1,1)=po(1)
35765       p(1,2)=po(2)
35766       p(1,3)=po(3)
35767
35768       enu=p(1,4)
35769
35770 C...Kinematical limits in Q**2
35771 c      S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) !            ????
35772       S = P(2,5)**2 + 2.*ENU*P(2,5)
35773       SQS = SQRT(S)                          ! E centro massa
35774       IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
35775       ELF = (S-AMF2+AML2)/(2.*SQS)           ! energia leptone finale p
35776       PSTAR = (S-P(2,5)**2)/(2.*SQS)       ! p* neutrino nel c.m.
35777       PLF = SQRT(ELF**2-AML2)               ! 3-momento leptone finale
35778       Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)    ! + o -
35779       Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)    ! according con cos(theta)
35780       IF (Q2MIN .LT. 0.)   Q2MIN = 0.      ! ??? non fisico
35781
35782 C...Generate Q**2
35783       DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
35784   200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
35785       DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
35786       IF (DSIG .LT.  DSIGMAX*PYR(0)) GOTO 200
35787       CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
35788       NDSIG=NDSIG+1
35789 C     WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
35790 C    &Q2,Q2min,Q2MAX,DSIGEV
35791
35792 C...c.m. frame. Neutrino along z axis
35793       DETOT = (P(1,4)) + (P(2,4)) ! e totale
35794       DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
35795       DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
35796       DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
35797 c      WRITE(*,*)
35798 c      WRITE(*,*)
35799 C      WRITE(*,*) 'Input values laboratory frame'
35800       N=2
35801
35802       CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
35803
35804       N=5
35805 c      STHETA = ULANGL(P(1,3),P(1,1))
35806 c      write(*,*) 'stheta' ,stheta
35807 c      stheta=0.
35808 c      CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
35809 c      WRITE(*,*)
35810 c      WRITE(*,*)
35811 C      WRITE(*,*) 'Output values cm frame'
35812 C...Kinematic in c.m. frame
35813       CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
35814       STSTAR = SQRT(1.-CTSTAR**2)
35815       PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
35816       P(4,5) = AML                  ! massa leptone
35817       P(4,4) = ELF                 ! e leptone
35818       P(4,3) = PLF*CTSTAR          ! px
35819       P(4,1) = PLF*STSTAR*COS(PHI) ! py
35820       P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
35821
35822       P(5,5) = AMF                  ! barione
35823       P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
35824       P(5,3) = -P(4,3)             ! px
35825       P(5,1) = -P(4,1)             ! py
35826       P(5,2) = -P(4,2)             ! pz
35827
35828       P(3,5) = -Q2
35829       P(3,1) = P(1,1)-P(4,1)
35830       P(3,2) = P(1,2)-P(4,2)
35831       P(3,3) = P(1,3)-P(4,3)
35832       P(3,4) = P(1,4)-P(4,4)
35833
35834 C...Transform back to laboratory  frame
35835 C      WRITE(*,*) 'before going back to nucl rest frame'
35836 c      CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
35837       N=5
35838
35839       CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
35840
35841 C      WRITE(*,*) 'Now back in nucl rest frame'
35842       IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
35843
35844 c********************************************
35845
35846       DO kw=1,5
35847         pi(1)=p(kw,1)
35848         pi(2)=p(kw,2)
35849         pi(3)=p(kw,3)
35850         CALL DT_TESTROT(Pi,Po,PHI12,3)
35851         DO ll=1,3
35852           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35853         END DO
35854         p(kw,1)=po(1)
35855         p(kw,2)=po(2)
35856         p(kw,3)=po(3)
35857       END DO
35858 c********************************************
35859
35860       DO kw=1,5
35861         pi(1)=p(kw,1)
35862         pi(2)=p(kw,2)
35863         pi(3)=p(kw,3)
35864         CALL DT_TESTROT(Pi,Po,PHI11,4)
35865         DO ll=1,3
35866           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35867         END DO
35868         p(kw,1)=po(1)
35869         p(kw,2)=po(2)
35870         p(kw,3)=po(3)
35871       END DO
35872
35873 c********************************************
35874
35875 C      WRITE(*,*) 'Now back in lab frame'
35876
35877       CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
35878
35879 CGB+...
35880 C...test (on final momentum of nucleon) if Fermi-blocking
35881 C...is operating
35882       ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
35883      &  - P(5,5)
35884       IF (ENUCL.LT. EFMAX) THEN
35885         IF(INIPRI.LT.10)THEN
35886           INIPRI=INIPRI+1
35887 C         WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
35888 C...the interaction is not possible due to Pauli-Blocking and
35889 C...it must be resampled
35890         ENDIF
35891         GOTO 100
35892       ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
35893         IF(INIPRI.LT.10)THEN
35894           INIPRI=INIPRI+1
35895 C     WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
35896         ENDIF
35897 C                      Reject (J:R) here all these events
35898 C                      are otherwise rejected in dpmjet
35899         GOTO 100
35900 C...the interaction is possible, but the nucleon remains inside
35901 C...the nucleus. The nucleus is therefore left excited.
35902 C...We treat this case as a nucleon with 0 kinetic energy.
35903 C       P(5,5) = AMF
35904 C       P(5,4) = AMF
35905 C       P(5,1) = 0.
35906 C       P(5,2) = 0.
35907 C       P(5,3) = 0.
35908       ELSE IF (ENUCL.GE.ENWELL) THEN
35909 C     WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
35910 C...the interaction is possible, the nucleon can exit the nucleus
35911 C...but the nuclear well depth must be subtracted. The nucleus could be
35912 C...left in an excited state.
35913         Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
35914 C       P(5,4) = ENUCL-ENWELL + AMF
35915         Pnucl = SQRT(P(5,4)**2-AMF**2)
35916 C...The 3-momentum is scaled assuming that the direction remains
35917 C...unaffected
35918         P(5,1) = P(5,1) * Pnucl/Pstart
35919         P(5,2) = P(5,2) * Pnucl/Pstart
35920         P(5,3) = P(5,3) * Pnucl/Pstart
35921 C     WRITE(6,*)' qel new P(5,4) ',P(5,4)
35922       ENDIF
35923 CGB-...
35924       DSIGSU=DSIGSU+DSIGEV
35925
35926          GA=P(4,4)/P(4,5)
35927          BGX=P(4,1)/P(4,5)
35928          BGY=P(4,2)/P(4,5)
35929          BGZ=P(4,3)/P(4,5)
35930 *
35931          DBETB(1)=BGX/GA
35932          DBETB(2)=BGY/GA
35933          DBETB(3)=BGZ/GA
35934          IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
35935
35936             CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
35937
35938          ENDIF
35939 c
35940 C      PRINT*,' FINE   EVENTO '
35941       enu=enu0
35942       RETURN
35943
35944  1001 FORMAT(2X, 'DT_GEN_QEL   : event rejected ', I5,  G10.3)
35945       END
35946
35947 *$ CREATE DT_MASS_INI.FOR
35948 *COPY DT_MASS_INI
35949 C====================================================================
35950 C.  Masses
35951 C====================================================================
35952 *
35953 *===mass_ini===========================================================*
35954 *
35955       SUBROUTINE DT_MASS_INI
35956 C...Initialize  the kinematics for the quasi-elastic cross section
35957
35958       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35959       SAVE
35960
35961 * particle masses used in qel neutrino scattering modules
35962       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
35963      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
35964      &                EMPROTSQ,EMNEUTSQ,EMNSQ
35965
35966       EML(1) = 0.51100D-03   ! e-
35967       EML(2) = EML(1)        ! e+
35968       EML(3) = 0.105659D0      ! mu-
35969       EML(4) = EML(3)        ! mu+
35970       EML(5) = 1.7777D0        ! tau-
35971       EML(6) = EML(5)        ! tau+
35972       EMPROT = 0.93827231D0    ! p
35973       EMNEUT = 0.93956563D0    ! n
35974       EMPROTSQ = EMPROT**2
35975       EMNEUTSQ = EMNEUT**2
35976       EMN = (EMPROT + EMNEUT)/2.
35977       EMNSQ = EMN**2
35978       DO J=1,3
35979         J0 = 2*(J-1)
35980         EMN1(J0+1) = EMNEUT
35981         EMN1(J0+2) = EMPROT
35982         EMN2(J0+1) = EMPROT
35983         EMN2(J0+2) = EMNEUT
35984       ENDDO
35985       DO J=1,6
35986         EMLSQ(J) = EML(J)**2
35987         ETQE(J)  = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
35988       ENDDO
35989       RETURN
35990       END
35991
35992 *$ CREATE DT_DSQEL_Q2.FOR
35993 *COPY DT_DSQEL_Q2
35994 *
35995 *===dsqel_q2===========================================================*
35996 *
35997       DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
35998
35999 C...differential cross section for  Quasi-Elastic scattering
36000 C.       nu + N -> l + N'
36001 C.  From Llewellin Smith  Phys.Rep.  3C, 261, (1971).
36002 C.
36003 C.  INPUT :  JTYP = 1,...,6    nu_e, ...., nubar_tau
36004 C.           ENU (GeV) =  Neutrino energy
36005 C.           Q2  (GeV**2) =  (Transfer momentum)**2
36006 C.
36007 C.  OUTPUT : DSQEL_Q2  = differential  cross section :
36008 C.                       dsigma/dq**2  (10**-38 cm+2/GeV**2)
36009 C------------------------------------------------------------------
36010
36011       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36012       SAVE
36013
36014 * particle masses used in qel neutrino scattering modules
36015       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
36016      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
36017      &                EMPROTSQ,EMNEUTSQ,EMNSQ
36018 **sr - removed (not needed)
36019 C     COMMON /CAXIAL/ FA0, AXIAL2
36020 **
36021
36022       DIMENSION SS(6)
36023       DATA C0 /0.17590D0 /  ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
36024       DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
36025       DATA AXIAL2 /1.03D0/  ! to be checked
36026
36027       FA0=-1.253D0
36028       CSI = 3.71D0                   !  ???
36029       GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2   ! G_e(q**2)
36030       GVM = (1.D0+CSI)*GVE           ! G_m (q**2)
36031       X = Q2/(EMN*EMN)     ! emn=massa barione
36032       XA = X/4.D0
36033       FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
36034       FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
36035       FA = FA0/(1.D0 + Q2/AXIAL2)**2
36036       FFA = FA*FA
36037       FFV1 = FV1*FV1
36038       FFV2 = FV2*FV2
36039       RM = EMLSQ(JTYP)/(EMN*EMN)            ! emlsq(jtyp)
36040       A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
36041       A2 = -RM * ((FV1 + FV2)**2 +  FFA)
36042       AA = (XA+0.25D0*RM)*(A1 + A2)
36043       BB = -X*FA*(FV1 + FV2)
36044       CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
36045       SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
36046       DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU)  !
36047       IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
36048
36049       RETURN
36050       END
36051
36052 *$ CREATE DT_PREPOLA.FOR
36053 *COPY DT_PREPOLA
36054 *
36055 *===prepola============================================================*
36056 *
36057       SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
36058
36059       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36060       SAVE
36061 c
36062 c By G. Battistoni and E. Scapparone (sept. 1997)
36063 c According to:
36064 c     Albright & Jarlskog, Nucl Phys B84 (1975) 467
36065 c
36066 c
36067       PARAMETER (MAXLND=4000)
36068       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
36069       COMMON /QNPOL/ POLARX(4),PMODUL
36070 * particle masses used in qel neutrino scattering modules
36071       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
36072      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
36073      &                EMPROTSQ,EMNEUTSQ,EMNSQ
36074 * steering flags for qel neutrino scattering modules
36075       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
36076 **sr - removed (not needed)
36077 C     COMMON /CAXIAL/ FA0, AXIAL2
36078 C     COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
36079 C    &        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
36080 **
36081       REAL*8 POL(4,4),BB2(3)
36082       DIMENSION SS(6)
36083 C     DATA C0 /0.17590D0 /  ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
36084       DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
36085 **sr uncommented since common block CAXIAL is now commented
36086       DATA AXIAL2 /1.03D0/  ! to be checked
36087 **
36088
36089       RML=P(4,5)
36090       RMM=0.93960D+00
36091       FM2 = RMM**2
36092       MPI = 0.135D+00
36093       OLDQ2=Q2
36094       FA0=-1.253D+00
36095       CSI = 3.71D+00                      !
36096       GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2   ! G_e(q**2)
36097       GVM = (1.D0+CSI)*GVE           ! G_m (q**2)
36098       X = Q2/(EMN*EMN)     ! emn=massa barione
36099       XA = X/4.D0
36100       FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
36101       FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
36102       FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
36103       FFA = FA*FA
36104       FFV1 = FV1*FV1
36105       FFV2 = FV2*FV2
36106       FP=2.D0*FA*RMM/(MPI**2 + Q2)
36107       RM = EMLSQ(JTYP)/(EMN*EMN)            ! emlsq(jtyp)
36108       A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
36109       A2 = -RM * ((FV1 + FV2)**2 +  FFA)
36110       AA = (XA+0.25D+00*RM)*(A1 + A2)
36111       BB = -X*FA*(FV1 + FV2)
36112       CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
36113       SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
36114
36115       OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2   )  ! articolo di ll...-smith
36116       OMEGA2=4.D+00*CC
36117       OMEGA3=2.D+00*FA*(FV1+FV2)
36118       OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
36119      1     (Q2/FM2))*FP**2)
36120       OMEGA5=OMEGA2
36121       OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
36122       WW1=2.D+00*OMEGA1*EMN**2
36123       WW2=2.D+00*OMEGA2*EMN**2
36124       WW3=2.D+00*OMEGA3*EMN**2
36125       WW4=2.D+00*OMEGA4*EMN**2
36126       WW5=2.D+00*OMEGA5*EMN**2
36127
36128       DO I=1,3
36129         BB2(I)=-P(4,I)/P(4,4)
36130       END DO
36131 c      WRITE(*,*)
36132 c      WRITE(*,*)
36133 c      WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
36134       N=5
36135       CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
36136 * NOW PARTICLES ARE IN THE SCATTERED LEPTON  REST FRAME
36137 c      WRITE(*,*)
36138 c      WRITE(*,*)
36139 c      WRITE(*,*) 'Prepola: now in lepton rest frame'
36140       EE=ENU
36141       QM2=Q2+RML**2
36142       U=Q2/(2.*RMM)
36143       FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
36144      +     (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
36145      +     ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
36146
36147       FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
36148      +     - ((RML**2)/FM2)*WW4                        !<=FM2 inv di RMM!!
36149
36150       FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
36151
36152       DO I=1,3
36153         POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
36154         POLARX(I)=POL(4,I)
36155       END DO
36156
36157       PMODUL=0.D0
36158       DO I=1,3
36159         PMODUL=PMODUL+POL(4,I)**2
36160       END DO
36161
36162       IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
36163          IF(NEUDEC.EQ.1) THEN
36164             CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
36165      +        ETL,PXL,PYL,PZL,
36166      +        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36167 c
36168 c     Tau has decayed in muon
36169 c
36170          ENDIF
36171          IF(NEUDEC.EQ.2) THEN
36172             CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
36173      +        ETL,PXL,PYL,PZL,
36174      +        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36175 c
36176 c     Tau has decayed in electron
36177 c
36178          ENDIF
36179          K(4,1)=15
36180          K(4,4) = 6
36181          K(4,5) = 8
36182          N=N+3
36183 c
36184 c     fill common for muon(electron)
36185 c
36186          P(6,1)=PXL
36187          P(6,2)=PYL
36188          P(6,3)=PZL
36189          P(6,4)=ETL
36190          K(6,1)=1
36191          IF(JTYP.EQ.5) THEN
36192             IF(NEUDEC.EQ.1) THEN
36193                P(6,5)=EML(JTYP-2)
36194                K(6,2)=13
36195             ELSEIF(NEUDEC.EQ.2) THEN
36196                P(6,5)=EML(JTYP-4)
36197                K(6,2)=11
36198             ENDIF
36199          ELSEIF(JTYP.EQ.6) THEN
36200             IF(NEUDEC.EQ.1) THEN
36201                K(6,2)=-13
36202             ELSEIF(NEUDEC.EQ.2) THEN
36203                K(6,2)=-11
36204             ENDIF
36205          END IF
36206          K(6,3)=4
36207          K(6,4)=0
36208          K(6,5)=0
36209 c
36210 c     fill common for tau_(anti)neutrino
36211 c
36212          P(7,1)=PXB
36213          P(7,2)=PYB
36214          P(7,3)=PZB
36215          P(7,4)=ETB
36216          P(7,5)=0.
36217          K(7,1)=1
36218          IF(JTYP.EQ.5) THEN
36219             K(7,2)=16
36220          ELSEIF(JTYP.EQ.6) THEN
36221             K(7,2)=-16
36222          END IF
36223          K(7,3)=4
36224          K(7,4)=0
36225          K(7,5)=0
36226 c
36227 c     Fill common for muon(electron)_(anti)neutrino
36228 c
36229          P(8,1)=PXN
36230          P(8,2)=PYN
36231          P(8,3)=PZN
36232          P(8,4)=ETN
36233          P(8,5)=0.
36234          K(8,1)=1
36235          IF(JTYP.EQ.5) THEN
36236             IF(NEUDEC.EQ.1) THEN
36237                K(8,2)=-14
36238             ELSEIF(NEUDEC.EQ.2) THEN
36239                K(8,2)=-12
36240             ENDIF
36241          ELSEIF(JTYP.EQ.6) THEN
36242             IF(NEUDEC.EQ.1) THEN
36243                K(8,2)=14
36244             ELSEIF(NEUDEC.EQ.2) THEN
36245                K(8,2)=12
36246             ENDIF
36247          END IF
36248          K(8,3)=4
36249          K(8,4)=0
36250          K(8,5)=0
36251       ENDIF
36252 c      WRITE(*,*)
36253 c      WRITE(*,*)
36254
36255 c      IF(PMODUL.GE.1.D+00) THEN
36256 c        WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
36257 c        write(*,*) pmodul
36258 c        DO I=1,3
36259 c          POL(4,I)=POL(4,I)/PMODUL
36260 c          POLARX(I)=POL(4,I)
36261 c        END DO
36262 c        PMODUL=0.
36263 c        DO I=1,3
36264 c          PMODUL=PMODUL+POL(4,I)**2
36265 c        END DO
36266 c        WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
36267 c
36268 c      ENDIF
36269
36270 c      WRITE(*,*) 'PMODUL = ',PMODUL
36271
36272 c      WRITE(*,*)
36273 c      WRITE(*,*)
36274 c      WRITE(*,*) 'prepola: Now back to nucl rest frame'
36275       CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
36276
36277       XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
36278       YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
36279       ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
36280       DO NDC =6,8
36281          V(NDC,1) = XDC
36282          V(NDC,2) = YDC
36283          V(NDC,3) = ZDC
36284       END DO
36285
36286       RETURN
36287       END
36288
36289 *$ CREATE DT_TESTROT.FOR
36290 *COPY DT_TESTROT
36291 *
36292 *===testrot============================================================*
36293 *
36294       SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
36295
36296       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36297       SAVE
36298
36299       DIMENSION ROT(3,3),PI(3),PO(3)
36300
36301       IF (MODE.EQ.1) THEN
36302          ROT(1,1) = 1.D0
36303          ROT(1,2) = 0.D0
36304          ROT(1,3) = 0.D0
36305          ROT(2,1) = 0.D0
36306          ROT(2,2) = COS(PHI)
36307          ROT(2,3) = -SIN(PHI)
36308          ROT(3,1) = 0.D0
36309          ROT(3,2) = SIN(PHI)
36310          ROT(3,3) = COS(PHI)
36311       ELSEIF (MODE.EQ.2) THEN
36312          ROT(1,1) = 0.D0
36313          ROT(1,2) = 1.D0
36314          ROT(1,3) = 0.D0
36315          ROT(2,1) = COS(PHI)
36316          ROT(2,2) = 0.D0
36317          ROT(2,3) = -SIN(PHI)
36318          ROT(3,1) = SIN(PHI)
36319          ROT(3,2) = 0.D0
36320          ROT(3,3) = COS(PHI)
36321       ELSEIF (MODE.EQ.3) THEN
36322          ROT(1,1) = 0.D0
36323          ROT(2,1) = 1.D0
36324          ROT(3,1) = 0.D0
36325          ROT(1,2) = COS(PHI)
36326          ROT(2,2) = 0.D0
36327          ROT(3,2) = -SIN(PHI)
36328          ROT(1,3) = SIN(PHI)
36329          ROT(2,3) = 0.D0
36330          ROT(3,3) = COS(PHI)
36331       ELSEIF (MODE.EQ.4) THEN
36332          ROT(1,1) = 1.D0
36333          ROT(2,1) = 0.D0
36334          ROT(3,1) = 0.D0
36335          ROT(1,2) = 0.D0
36336          ROT(2,2) = COS(PHI)
36337          ROT(3,2) = -SIN(PHI)
36338          ROT(1,3) = 0.D0
36339          ROT(2,3) = SIN(PHI)
36340          ROT(3,3) = COS(PHI)
36341       ELSE
36342          STOP ' TESTROT: mode not supported!'
36343       ENDIF
36344       DO 1 J=1,3
36345         PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
36346     1 CONTINUE
36347
36348       RETURN
36349       END
36350
36351 *$ CREATE DT_LEPDCYP.FOR
36352 *COPY DT_LEPDCYP
36353 *
36354 *===lepdcyp============================================================*
36355 *
36356       SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
36357      &                      ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36358 C
36359 C-----------------------------------------------------------------
36360 C
36361 C   Author   :- G. Battistoni         10-NOV-1995
36362 C
36363 C=================================================================
36364 C
36365 C   Purpose   : performs decay of polarized lepton in
36366 C               its rest frame: a => b + l + anti-nu
36367 C               (Example: mu- => nu-mu + e- + anti-nu-e)
36368 C               Polarization is assumed along Z-axis
36369 C               WARNING:
36370 C               1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
36371 C                  OF NEGLIGIBLE MASS
36372 C               2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
36373 C                  IN THIS VERSION
36374 C
36375 C   Method    : modifies phase space distribution obtained
36376 C               by routine EXPLOD using a rejection against the
36377 C               matrix element for unpolarized lepton decay
36378 C
36379 C   Inputs    : Mass of a :  AMA
36380 C               Mass of l :  AML
36381 C               Polar. of a: POL
36382 C               (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
36383 C                                                 POL = -1)
36384 C
36385 C   Outputs   : kinematic variables in the rest frame of decaying lepton
36386 C               ETL,PXL,PYL,PZL 4-moment of l
36387 C               ETB,PXB,PYB,PZB 4-moment of b
36388 C               ETN,PXN,PYN,PZN 4-moment of anti-nu
36389 C
36390 C============================================================
36391 C +
36392 C Declarations.
36393 C -
36394       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36395       SAVE
36396
36397       PARAMETER ( LINP = 10 ,
36398      &            LOUT = 6 ,
36399      &            LDAT = 9 )
36400       PARAMETER ( KALGNM = 2 )
36401       PARAMETER ( ANGLGB = 5.0D-16 )
36402       PARAMETER ( ANGLSQ = 2.5D-31 )
36403       PARAMETER ( AXCSSV = 0.2D+16 )
36404       PARAMETER ( ANDRFL = 1.0D-38 )
36405       PARAMETER ( AVRFLW = 1.0D+38 )
36406       PARAMETER ( AINFNT = 1.0D+30 )
36407       PARAMETER ( AZRZRZ = 1.0D-30 )
36408       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
36409       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
36410       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
36411       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
36412       PARAMETER ( CSNNRM = 2.0D-15 )
36413       PARAMETER ( DMXTRN = 1.0D+08 )
36414       PARAMETER ( ZERZER = 0.D+00 )
36415       PARAMETER ( ONEONE = 1.D+00 )
36416       PARAMETER ( TWOTWO = 2.D+00 )
36417       PARAMETER ( THRTHR = 3.D+00 )
36418       PARAMETER ( FOUFOU = 4.D+00 )
36419       PARAMETER ( FIVFIV = 5.D+00 )
36420       PARAMETER ( SIXSIX = 6.D+00 )
36421       PARAMETER ( SEVSEV = 7.D+00 )
36422       PARAMETER ( EIGEIG = 8.D+00 )
36423       PARAMETER ( ANINEN = 9.D+00 )
36424       PARAMETER ( TENTEN = 10.D+00 )
36425       PARAMETER ( HLFHLF = 0.5D+00 )
36426       PARAMETER ( ONETHI = ONEONE / THRTHR )
36427       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
36428       PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
36429       PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
36430       PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
36431       PARAMETER ( CLIGHT = 2.99792458         D+10 )
36432       PARAMETER ( AVOGAD = 6.0221367          D+23 )
36433       PARAMETER ( AMELGR = 9.1093897          D-28 )
36434       PARAMETER ( PLCKBR = 1.05457266         D-27 )
36435       PARAMETER ( ELCCGS = 4.8032068          D-10 )
36436       PARAMETER ( ELCMKS = 1.60217733         D-19 )
36437       PARAMETER ( AMUGRM = 1.6605402          D-24 )
36438       PARAMETER ( AMMUMU = 0.113428913        D+00 )
36439       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
36440       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
36441       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
36442       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
36443       PARAMETER ( PLABRC = 0.197327053        D+00 )
36444       PARAMETER ( AMELCT = 0.51099906         D-03 )
36445       PARAMETER ( AMUGEV = 0.93149432         D+00 )
36446       PARAMETER ( AMMUON = 0.105658389        D+00 )
36447       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
36448       PARAMETER ( GEVMEV = 1.0                D+03 )
36449       PARAMETER ( EMVGEV = 1.0                D-03 )
36450       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
36451       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
36452       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
36453 C +
36454 C    variables for EXPLOD
36455 C -
36456       PARAMETER ( KPMX = 10 )
36457       DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
36458      &          PZEXPL (KPMX), ETEXPL (KPMX)
36459 C +
36460 C      test variables
36461 C -
36462 **sr - removed (not needed)
36463 C     COMMON /GBATNU/ ELERAT,NTRY
36464 **
36465 C +
36466 C     Initializes test variables
36467 C -
36468       NTRY = 0
36469       ELERAT = 0.D+00
36470 C +
36471 C     Maximum value for matrix element
36472 C -
36473       ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
36474      &  SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
36475 C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
36476 C     Inputs for EXPLOD
36477 C part. no. 1 is l       (e- in mu- decay)
36478 C part. no. 2 is b       (nu-mu in mu- decay)
36479 C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
36480 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
36481       NPEXPL = 3
36482       ETOTEX = AMA
36483       AMEXPL(1) = AML
36484       AMEXPL(2) = 0.D+00
36485       AMEXPL(3) = 0.D+00
36486 C +
36487 C     phase space distribution
36488 C -
36489   100 CONTINUE
36490       NTRY = NTRY + 1
36491
36492       CALL DT_EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
36493      &                 PYEXPL, PZEXPL )
36494
36495 C +
36496 C  Calculates matrix element:
36497 C  64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
36498 C  Here CTH is the cosine of the angle between anti-nu and Z axis
36499 C -
36500       CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
36501      &  PZEXPL(3)**2 )
36502       PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
36503       PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
36504      &     PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
36505       ELEMAT = 16.D+00 * PROD1 * PROD2
36506       IF(ELEMAT.GT.ELEMAX) THEN
36507         WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
36508         STOP
36509       ENDIF
36510 C +
36511 C     Here performs the rejection
36512 C -
36513       TEST = DT_RNDM(ETOTEX) * ELEMAX
36514       IF ( TEST .GT. ELEMAT ) GO TO 100
36515 C +
36516 C     final assignment of variables
36517 C -
36518       ELERAT = ELEMAT/ELEMAX
36519       ETL = ETEXPL(1)
36520       PXL = PXEXPL(1)
36521       PYL = PYEXPL(1)
36522       PZL = PZEXPL(1)
36523       ETB = ETEXPL(2)
36524       PXB = PXEXPL(2)
36525       PYB = PYEXPL(2)
36526       PZB = PZEXPL(2)
36527       ETN = ETEXPL(3)
36528       PXN = PXEXPL(3)
36529       PYN = PYEXPL(3)
36530       PZN = PZEXPL(3)
36531   999 RETURN
36532       END
36533
36534 *$ CREATE DT_GEN_DELTA.FOR
36535 *COPY DT_GEN_DELTA
36536 C==================================================================
36537 C.  Generation of  Delta resonance events
36538 C==================================================================
36539 *
36540 *===gen_delta==========================================================*
36541 *
36542       SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
36543
36544       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36545       SAVE
36546
36547       PARAMETER ( LINP = 10 ,
36548      &            LOUT = 6 ,
36549      &            LDAT = 9 )
36550 C...Generate a Delta-production neutrino/antineutrino
36551 C.  CC-interaction on a nucleon
36552 C
36553 C.  INPUT  ENU (GeV) = Neutrino Energy
36554 C.         LLEP = neutrino type
36555 C.         LTARG = nucleon target type 1=p, 2=n.
36556 C.         JINT = 1:CC, 2::NC
36557 C.
36558 C.  OUTPUT PPL(4)  4-monentum of final lepton
36559 C----------------------------------------------------
36560       PARAMETER (MAXLND=4000)
36561       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
36562 **sr - removed (not needed)
36563 C     COMMON /CBAD/  LBAD, NBAD
36564 **
36565
36566       DIMENSION PI(3),PO(3)
36567 C     REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
36568       DIMENSION AML0(6),AMN(2)
36569       DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
36570       DATA AMN  /0.93827231, 0.93956563/
36571       DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
36572
36573 c     WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
36574       LBAD = 0
36575 C...Final lepton mass
36576       IF (JINT.EQ.1) THEN
36577         AML = AML0(LLEP)
36578       ELSE
36579         AML = 0.
36580       ENDIF
36581       AML2 = AML**2
36582
36583 C...Particle labels (LUND)
36584       N = 5
36585       K(1,1) = 21
36586       K(2,1) = 21
36587       K(3,1) = 21
36588       K(4,1) = 1
36589       K(3,3) = 1
36590       K(4,3) = 1
36591       IF (LTARG .EQ. 1)  THEN
36592          K(2,2) = 2212
36593       ELSE
36594          K(2,2) = 2112
36595       ENDIF
36596       K0 = (LLEP-1)/2
36597       K1 = LLEP/2
36598       KA = 12 + 2*K0
36599       IS = -1 + 2*LLEP - 4*K1
36600       LNU = 2 - LLEP + 2*K1
36601       K(1,2) = IS*KA
36602       K(5,1) = 1
36603       K(5,3) = 2
36604       IF (JINT .EQ. 1)  THEN                    ! CC interactions
36605          K(3,2) = IS*24
36606          K(4,2) = IS*(KA-1)
36607         IF(LNU.EQ.1) THEN
36608           IF (LTARG .EQ. 1)  THEN
36609               K(5,2) = 2224
36610           ELSE
36611               K(5,2) = 2214
36612           ENDIF
36613         ELSE
36614           IF (LTARG .EQ. 1)  THEN
36615               K(5,2) = 2114
36616           ELSE
36617               K(5,2) = 1114
36618           ENDIF
36619         ENDIF
36620       ELSE
36621          K(3,2) = 23                           ! NC (Z0) interactions
36622          K(4,2) = K(1,2)
36623 **sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
36624 *                                Delta0 for neutron (LTARG=2)
36625 C        IF (LTARG .EQ. 1)  THEN
36626 C           K(5,2) = 2114
36627 C        ELSE
36628 C           K(5,2) = 2214
36629 C        ENDIF
36630          IF (LTARG .EQ. 1)  THEN
36631             K(5,2) = 2214
36632          ELSE
36633             K(5,2) = 2114
36634          ENDIF
36635 **
36636       ENDIF
36637
36638 C...4-momentum initial lepton
36639       P(1,5) = 0.
36640       P(1,4) = ENU
36641       P(1,1) = 0.
36642       P(1,2) = 0.
36643       P(1,3) = ENU
36644 C...4-momentum initial nucleon
36645       P(2,5) = AMN(LTARG)
36646 C     P(2,4) = P(2,5)
36647 C     P(2,1) = 0.
36648 C     P(2,2) = 0.
36649 C     P(2,3) = 0.
36650        P(2,1) = P21
36651        P(2,2) = P22
36652        P(2,3) = P23
36653        P(2,4) = P24
36654        P(2,5) = P25
36655       N=2
36656       beta1=-p(2,1)/p(2,4)
36657       beta2=-p(2,2)/p(2,4)
36658       beta3=-p(2,3)/p(2,4)
36659       N=2
36660
36661       CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
36662
36663 C     print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
36664
36665       phi11=atan(p(1,2)/p(1,3))
36666       pi(1)=p(1,1)
36667       pi(2)=p(1,2)
36668       pi(3)=p(1,3)
36669
36670       CALL DT_TESTROT(PI,Po,PHI11,1)
36671       DO ll=1,3
36672        IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36673       END DO
36674       p(1,1)=po(1)
36675       p(1,2)=po(2)
36676       p(1,3)=po(3)
36677       phi12=atan(p(1,1)/p(1,3))
36678
36679       pi(1)=p(1,1)
36680       pi(2)=p(1,2)
36681       pi(3)=p(1,3)
36682       CALL DT_TESTROT(Pi,Po,PHI12,2)
36683       DO ll=1,3
36684         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36685       END DO
36686       p(1,1)=po(1)
36687       p(1,2)=po(2)
36688       p(1,3)=po(3)
36689
36690       ENUU=P(1,4)
36691
36692 C...Generate the Mass of the Delta
36693       NTRY = 0
36694 100   R = PYR(0)
36695       AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
36696       NTRY = NTRY + 1
36697       IF (NTRY .GT. 1000)  THEN
36698          LBAD = 1
36699          WRITE (LOUT,1001)  NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
36700          RETURN
36701       ENDIF
36702       IF (AMD .LT. AMDMIN)  GOTO 100
36703       ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
36704       IF (ENUU .LT. ET) GOTO 100
36705
36706 C...Kinematical  limits in Q**2
36707       S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
36708       SQS = SQRT(S)
36709       PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
36710       ELF = (S - AMD**2 + AML2)/(2.*SQS)
36711       PLF = SQRT(ELF**2 - AML2)
36712       Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
36713       Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
36714       IF (Q2MIN .LT. 0.)   Q2MIN = 0.
36715
36716       DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
36717 200   Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
36718       DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
36719       IF (DSIG .LT.  DSIGMAX*PYR(0)) GOTO 200
36720
36721 C...Generate the kinematics of the final particles
36722       EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
36723       GAM = EISTAR/AMN(LTARG)
36724       BET = PSTAR/EISTAR
36725       CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
36726       EL  = GAM*(ELF + BET*PLF*CTSTAR)
36727       PLZ = GAM*(PLF*CTSTAR + BET*ELF)
36728       PL  = SQRT(EL**2 - AML2)
36729       PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
36730       PHI = 6.28319*PYR(0)
36731       P(4,1) = PLT*COS(PHI)
36732       P(4,2) = PLT*SIN(PHI)
36733       P(4,3) = PLZ
36734       P(4,4) = EL
36735       P(4,5) = AML
36736
36737 C...4-momentum of Delta
36738       P(5,1) = -P(4,1)
36739       P(5,2) = -P(4,2)
36740       P(5,3) = ENUU-P(4,3)
36741       P(5,4) = ENUU+AMN(LTARG)-P(4,4)
36742       P(5,5) = AMD
36743
36744 C...4-momentum  of intermediate boson
36745       P(3,5) = -Q2
36746       P(3,4) = P(1,4)-P(4,4)
36747       P(3,1) = P(1,1)-P(4,1)
36748       P(3,2) = P(1,2)-P(4,2)
36749       P(3,3) = P(1,3)-P(4,3)
36750       N=5
36751
36752       DO kw=1,5
36753         pi(1)=p(kw,1)
36754         pi(2)=p(kw,2)
36755         pi(3)=p(kw,3)
36756         CALL DT_TESTROT(Pi,Po,PHI12,3)
36757         DO ll=1,3
36758           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36759         END DO
36760         p(kw,1)=po(1)
36761         p(kw,2)=po(2)
36762         p(kw,3)=po(3)
36763       END DO
36764
36765 c********************************************
36766
36767         DO kw=1,5
36768           pi(1)=p(kw,1)
36769           pi(2)=p(kw,2)
36770           pi(3)=p(kw,3)
36771           CALL DT_TESTROT(Pi,Po,PHI11,4)
36772           DO ll=1,3
36773             IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36774           END DO
36775           p(kw,1)=po(1)
36776           p(kw,2)=po(2)
36777           p(kw,3)=po(3)
36778        END DO
36779 c********************************************
36780 C         transform back into Lab.
36781
36782       CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
36783
36784 C     WRITE(6,*)' Lab fram ( fermi incl.) '
36785       N=5
36786       CALL PYEXEC
36787
36788       RETURN
36789 1001  FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5,  6G10.3)
36790       END
36791
36792 *$ CREATE DT_DSIGMA_DELTA.FOR
36793 *COPY DT_DSIGMA_DELTA
36794 *
36795 *===dsigma_delta=======================================================*
36796 *
36797       DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
36798
36799       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36800       SAVE
36801
36802 C...Reaction nu + N -> lepton + Delta
36803 C.  returns the  cross section
36804 C.  dsigma/dt
36805 C.  INPUT  LNU = 1, 2  (neutrino-antineutrino)
36806 C.         QQ = t (always negative)  GeV**2
36807 C.         S  = (c.m energy)**2      GeV**2
36808 C.  OUTPUT =  10**-38 cm+2/GeV**2
36809 C-----------------------------------------------------
36810       REAL*8 MN, MN2, MN4, MD,MD2, MD4
36811       DATA MN /0.938/
36812       DATA PI /3.1415926/
36813
36814       GF = (1.1664 * 1.97)
36815       GF2 = GF*GF
36816       MN2 = MN*MN
36817       MN4 = MN2*MN2
36818       MD2 = MD*MD
36819       MD4 = MD2*MD2
36820       AML2 = AML*AML
36821       AML4 = AML2*AML2
36822       VQ  = (MN2 - MD2 - QQ)/2.
36823       VPI = (MN2 + MD2 - QQ)/2.
36824       VK  = (S + QQ - MN2 - AML2)/2.
36825       PIK = (S - MN2)/2.
36826       QK = (AML2 - QQ)/2.
36827       PIQ = (QQ + MN2 - MD2)/2.
36828       Q = SQRT(-QQ)
36829       C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
36830       C3 = SQRT(3.)*C3V/MN
36831       C4 = -C3/MD             ! attenzione al segno
36832       C5A = 1.18/(1.-QQ/0.4225)**2
36833       C32 = C3**2
36834       C42 = C4**2
36835       C5A2 = C5A**2
36836
36837       IF (LNU .EQ. 1)  THEN
36838       ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
36839      . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
36840      . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
36841      . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
36842       ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
36843      . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
36844      . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
36845      . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
36846      . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
36847      . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ-
36848      . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
36849      . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
36850      . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
36851      . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
36852      . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD*
36853      . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A
36854      . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ*
36855      . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A*
36856      . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2
36857      . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK
36858      . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
36859      . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
36860      . *C42-2.*MD2*VPI*QK**2*C32+ANS3
36861       ELSE
36862       ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
36863      . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
36864      . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
36865      . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
36866       ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
36867      . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
36868      . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
36869      . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
36870      . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
36871      . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
36872      . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
36873      . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
36874      . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
36875      . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
36876      . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
36877      . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
36878      . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
36879      . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
36880      . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
36881      . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
36882      . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
36883      . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
36884      . *C42-2.*MD2*VPI*QK**2*C32+ANS3
36885       ENDIF
36886       ANS1=32.*ANS2
36887       ANS=ANS1/(3.*MD2)
36888       P1CM = (S-MN2)/(2.*SQRT(S))
36889       DT_DSIGMA_DELTA  = GF2/2. * ANS/(64.*PI*S*P1CM**2)
36890
36891       RETURN
36892       END
36893
36894 *$ CREATE DT_QGAUS.FOR
36895 *COPY DT_QGAUS
36896 *
36897 *===qgaus==============================================================*
36898 *
36899       SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
36900
36901       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36902       SAVE
36903
36904       DIMENSION X(5),W(5)
36905       DATA X/.1488743389D0,.4333953941D0,
36906      & .6794095682D0,.8650633666D0,.9739065285D0
36907      */
36908       DATA W/.2955242247D0,.2692667193D0,
36909      & .2190863625D0,.1494513491D0,.0666713443D0
36910      */
36911       XM=0.5D0*(B+A)
36912       XR=0.5D0*(B-A)
36913       SS=0
36914       DO 11 J=1,5
36915         DX=XR*X(J)
36916         SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
36917      *  DT_DSQEL_Q2(LTYP,ENU,XM-DX))
36918 11    CONTINUE
36919       SS=XR*SS
36920
36921       RETURN
36922       END
36923
36924 *$ CREATE DT_DIQBRK.FOR
36925 *COPY DT_DIQBRK
36926 *
36927 *===diqbrk=============================================================*
36928 *
36929       SUBROUTINE DT_DIQBRK
36930
36931       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36932       SAVE
36933
36934 * event history
36935       PARAMETER (NMXHKK=200000)
36936       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36937      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36938      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36939 * extended event history
36940       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36941      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36942      &                IHIST(2,NMXHKK)
36943 * event flag
36944       COMMON /DTEVNO/ NEVENT,ICASCA
36945
36946 C     IF(DT_RNDM(VV).LE.0.5D0)THEN
36947 C       CALL GSQBS1(NHKK)
36948 C       CALL GSQBS2(NHKK)
36949 C       CALL USQBS1(NHKK)
36950 C       CALL USQBS2(NHKK)
36951 C       CALL GSABS1(NHKK)
36952 C       CALL GSABS2(NHKK)
36953 C       CALL USABS1(NHKK)
36954 C       CALL USABS2(NHKK)
36955 C     ELSE
36956 C       CALL GSQBS2(NHKK)
36957 C       CALL GSQBS1(NHKK)
36958 C       CALL USQBS2(NHKK)
36959 C       CALL USQBS1(NHKK)
36960 C       CALL GSABS2(NHKK)
36961 C       CALL GSABS1(NHKK)
36962 C       CALL USABS2(NHKK)
36963 C       CALL USABS1(NHKK)
36964 C     ENDIF
36965
36966       IF(DT_RNDM(VV).LE.0.5D0) THEN
36967         CALL DT_DBREAK(1)
36968         CALL DT_DBREAK(2)
36969         CALL DT_DBREAK(3)
36970         CALL DT_DBREAK(4)
36971         CALL DT_DBREAK(5)
36972         CALL DT_DBREAK(6)
36973         CALL DT_DBREAK(7)
36974         CALL DT_DBREAK(8)
36975       ELSE
36976         CALL DT_DBREAK(2)
36977         CALL DT_DBREAK(1)
36978         CALL DT_DBREAK(4)
36979         CALL DT_DBREAK(3)
36980         CALL DT_DBREAK(6)
36981         CALL DT_DBREAK(5)
36982         CALL DT_DBREAK(8)
36983         CALL DT_DBREAK(7)
36984       ENDIF
36985
36986       RETURN
36987       END
36988
36989 *$ CREATE MUSQBS2.FOR
36990 *COPY MUSQBS2
36991 C
36992 C
36993 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36994       SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36995      *              IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
36996 C
36997 C                  USQBS-2 diagram (split target diquark)
36998 C
36999       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37000       SAVE
37001
37002       PARAMETER ( LINP = 10 ,
37003      &            LOUT = 6 ,
37004      &            LDAT = 9 )
37005 * event history
37006       PARAMETER (NMXHKK=200000)
37007       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37008      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37009      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37010 * extended event history
37011       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37012      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37013      &                IHIST(2,NMXHKK)
37014 * Lorentz-parameters of the current interaction
37015       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37016      &                UMO,PPCM,EPROJ,PPROJ
37017 * diquark-breaking mechanism
37018       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37019
37020 C
37021       PARAMETER (NTMHKK= 300)
37022       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37023      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37024      +(4,NTMHKK)
37025 *KEEP,XSEADI.
37026       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37027      +SSMIMQ,VVMTHR
37028 *KEEP,DPRIN.
37029       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37030       COMMON /EVFLAG/ NUMEV
37031 C
37032 C                  USQBS-2 diagram (split target diquark)
37033 C
37034 C
37035 C     Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
37036 C     Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
37037 C
37038 C     Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
37039 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37040 C
37041 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37042 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37043 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37044 C
37045 C
37046 C       Put new chains into COMMON /HKKTMP/
37047 C
37048       IIGLU1=NC1T-NC1P-1
37049       IIGLU2=NC2T-NC2P-1
37050       IGCOUN=0
37051 C     WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37052       CVQ=1.D0
37053       IREJ=0
37054       IF(IPIP.EQ.2)THEN
37055 C     IF(NUMEV.EQ.-324)THEN
37056 C     WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37057 C    *             'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
37058 C    *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37059 C    *              IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
37060       ENDIF
37061 C
37062 C
37063 C
37064 C     determine x-values of NC1T diquark
37065       XDIQT=PHKK(4,NC1T)*2.D0/UMO
37066       XVQP=PHKK(4,NC1P)*2.D0/UMO
37067 C
37068 C     determine x-values of sea quark pair
37069 C
37070       IPCO=1
37071       ICOU=0
37072  2234 CONTINUE
37073       ICOU=ICOU+1
37074       IF(ICOU.GE.500)THEN
37075         IREJ=1
37076         IF(ISQ.EQ.3)IREJ=3
37077         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
37078         IPCO=0
37079         RETURN
37080       ENDIF
37081       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call  XSEAPA: UMO,XDIQT,XVQP ',
37082      * UMO, XDIQT,XVQP
37083       XSQ=0.D0
37084       XSAQ=0.D0
37085 **NEW
37086 C     CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37087       IF (IPIP.EQ.1) THEN
37088          XQMAX  = XDIQT/2.0D0
37089          XAQMAX = 2.D0*XVQP/3.0D0
37090       ELSE
37091          XQMAX  = 2.D0*XVQP/3.0D0
37092          XAQMAX = XDIQT/2.0D0
37093       ENDIF
37094       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37095       ISAQ = 6+ISQ
37096 C     write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
37097 **
37098         IF(IPCO.GE.3)
37099      &     WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37100       IF(IREJ.GE.1)THEN
37101         IF(IPCO.GE.3)
37102      &     WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37103         IPCO=0
37104         RETURN
37105       ENDIF
37106       IF(IPIP.EQ.1)THEN
37107         IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37108       ELSEIF(IPIP.EQ.2)THEN
37109         IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37110       ENDIF
37111       IF(IPCO.GE.3)THEN
37112         WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
37113      *  XDIQT,XVQP,XSQ,XSAQ
37114       ENDIF
37115 C
37116 C     subtract xsq,xsaq from NC1T diquark and NC1P quark
37117 C
37118 C     XSQ=0.D0
37119       IF(IPIP.EQ.1)THEN
37120         XDIQT=XDIQT-XSQ
37121         XVQP =XVQP -XSAQ
37122       ELSEIF(IPIP.EQ.2)THEN
37123         XDIQT=XDIQT-XSAQ
37124         XVQP =XVQP -XSQ
37125       ENDIF
37126       IF(IPCO.GE.3)
37127      &   WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
37128 C
37129 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37130 C
37131       XVTHRO=CVQ/UMO
37132       IVTHR=0
37133  3466 CONTINUE
37134       IF(IVTHR.EQ.10)THEN
37135         IREJ=1
37136         IF(ISQ.EQ.3)IREJ=3
37137         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
37138       IPCO=0
37139         RETURN
37140       ENDIF
37141       IVTHR=IVTHR+1
37142       XVTHR=XVTHRO/(201-IVTHR)
37143       UNOPRV=UNON
37144  380  CONTINUE
37145       IF(XVTHR.GT.0.66D0*XDIQT)THEN
37146         IREJ=1
37147         IF(ISQ.EQ.3)IREJ=3
37148         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR  large ',
37149      *  XVTHR
37150       IPCO=0
37151         RETURN
37152       ENDIF
37153       IF(DT_RNDM(V).LT.0.5D0)THEN
37154         XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37155         XVTQII=XDIQT-XVTQI
37156       ELSE
37157         XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37158         XVTQI=XDIQT-XVTQII
37159       ENDIF
37160       IF(IPCO.GE.3)THEN
37161         WRITE(LOUT,'(A,2E12.4)')'  MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
37162       ENDIF
37163 C
37164 C     Prepare 4 momenta of new chains and chain ends
37165 C
37166 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37167 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37168 C    +(4,NTMHKK)
37169 C
37170 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37171 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37172 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37173 C
37174 C     SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37175 C    *              IP1,IP21,IP22,IPP1,IPP2)
37176 C
37177       IF(IPIP.EQ.1)THEN
37178         XSQ1=XSQ
37179         XSAQ1=XSAQ
37180         ISQ1=ISQ
37181         ISAQ1=ISAQ
37182       ELSEIF(IPIP.EQ.2)THEN
37183         XSQ1=XSAQ
37184         XSAQ1=XSQ
37185         ISQ1=ISAQ
37186         ISAQ1=ISQ
37187       ENDIF
37188       IDHKT(1)   =IPP1
37189       ISTHKT(1)  =951
37190       JMOHKT(1,1)=NC2P
37191       JMOHKT(2,1)=0
37192       JDAHKT(1,1)=3+IIGLU1
37193       JDAHKT(2,1)=0
37194 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37195       PHKT(1,1)  =PHKK(1,NC2P)
37196       PHKT(2,1)  =PHKK(2,NC2P)
37197       PHKT(3,1)  =PHKK(3,NC2P)
37198       PHKT(4,1)  =PHKK(4,NC2P)
37199 C     PHKT(5,1)  =PHKK(5,NC2P)
37200       XMIST  =(PHKT(4,1)**2-
37201      * PHKT(3,1)**2-PHKT(2,1)**2-
37202      *PHKT(1,1)**2)
37203       IF(XMIST.GT.0.D0)THEN
37204       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37205      *PHKT(1,1)**2)
37206       ELSE
37207 C     WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
37208       PHKT(5,1)=0.D0
37209       ENDIF
37210       VHKT(1,1)  =VHKK(1,NC2P)
37211       VHKT(2,1)  =VHKK(2,NC2P)
37212       VHKT(3,1)  =VHKK(3,NC2P)
37213       VHKT(4,1)  =VHKK(4,NC2P)
37214       WHKT(1,1)  =WHKK(1,NC2P)
37215       WHKT(2,1)  =WHKK(2,NC2P)
37216       WHKT(3,1)  =WHKK(3,NC2P)
37217       WHKT(4,1)  =WHKK(4,NC2P)
37218 C     Add here IIGLU1 gluons to this chaina
37219       PG1=0.D0
37220       PG2=0.D0
37221       PG3=0.D0
37222       PG4=0.D0
37223       IF(IIGLU1.GE.1)THEN
37224       JJG=NC1P
37225       DO 61 IIG=2,2+IIGLU1-1
37226         KKG=JJG+IIG-1
37227         IDHKT(IIG)   =IDHKK(KKG)
37228         ISTHKT(IIG)  =921
37229         JMOHKT(1,IIG)=KKG
37230         JMOHKT(2,IIG)=0
37231         JDAHKT(1,IIG)=3+IIGLU1
37232         JDAHKT(2,IIG)=0
37233         PHKT(1,IIG)=PHKK(1,KKG)
37234         PG1=PG1+ PHKT(1,IIG)
37235         PHKT(2,IIG)=PHKK(2,KKG)
37236         PG2=PG2+ PHKT(2,IIG)
37237         PHKT(3,IIG)=PHKK(3,KKG)
37238         PG3=PG3+ PHKT(3,IIG)
37239         PHKT(4,IIG)=PHKK(4,KKG)
37240         PG4=PG4+ PHKT(4,IIG)
37241         PHKT(5,IIG)=PHKK(5,KKG)
37242         VHKT(1,IIG)  =VHKK(1,KKG)
37243         VHKT(2,IIG)  =VHKK(2,KKG)
37244         VHKT(3,IIG)  =VHKK(3,KKG)
37245         VHKT(4,IIG)  =VHKK(4,KKG)
37246         WHKT(1,IIG) =WHKK(1,KKG)
37247         WHKT(2,IIG) =WHKK(2,KKG)
37248         WHKT(3,IIG) =WHKK(3,KKG)
37249         WHKT(4,IIG) =WHKK(4,KKG)
37250    61 CONTINUE
37251       ENDIF
37252       IDHKT(2+IIGLU1)   =IP21
37253       ISTHKT(2+IIGLU1)  =952
37254       JMOHKT(1,2+IIGLU1)=NC1T
37255       JMOHKT(2,2+IIGLU1)=0
37256       JDAHKT(1,2+IIGLU1)=3+IIGLU1
37257       JDAHKT(2,2+IIGLU1)=0
37258       PHKT(1,2+IIGLU1)  =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
37259       PHKT(2,2+IIGLU1)  =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
37260       PHKT(3,2+IIGLU1)  =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
37261       PHKT(4,2+IIGLU1)  =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
37262 C     PHKT(5,2)  =PHKK(5,NC1T)
37263       XMIST  =(PHKT(4,2+IIGLU1)**2-
37264      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37265      *PHKT(1,2+IIGLU1)**2)
37266       IF(XMIST.GT.0.D0)THEN
37267       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
37268      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37269      *PHKT(1,2+IIGLU1)**2)
37270       ELSE
37271 C      WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
37272         PHKT(5,5+IIGLU1)=0.D0
37273       ENDIF
37274       VHKT(1,2+IIGLU1)  =VHKK(1,NC1T)
37275       VHKT(2,2+IIGLU1)  =VHKK(2,NC1T)
37276       VHKT(3,2+IIGLU1)  =VHKK(3,NC1T)
37277       VHKT(4,2+IIGLU1)  =VHKK(4,NC1T)
37278       WHKT(1,2+IIGLU1)  =WHKK(1,NC1T)
37279       WHKT(2,2+IIGLU1)  =WHKK(2,NC1T)
37280       WHKT(3,2+IIGLU1)  =WHKK(3,NC1T)
37281       WHKT(4,2+IIGLU1)  =WHKK(4,NC1T)
37282       IDHKT(3+IIGLU1)   =88888
37283       ISTHKT(3+IIGLU1)  =95
37284       JMOHKT(1,3+IIGLU1)=1
37285       JMOHKT(2,3+IIGLU1)=2+IIGLU1
37286       JDAHKT(1,3+IIGLU1)=0
37287       JDAHKT(2,3+IIGLU1)=0
37288       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
37289       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
37290       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
37291       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
37292       XMIST
37293      * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37294      *            -PHKT(3,3+IIGLU1)**2)
37295       IF(XMIST.GT.0.D0)THEN
37296       PHKT(5,3+IIGLU1)
37297      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37298      *            -PHKT(3,3+IIGLU1)**2)
37299       ELSE
37300 C      WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
37301         PHKT(5,5+IIGLU1)=0.D0
37302       ENDIF
37303       IF(IPIP.GE.2)THEN
37304 C     IF(NUMEV.EQ.-324)THEN
37305 C     WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
37306 C    * JDAHKT(1,1),
37307 C    *JDAHKT(2,1),(PHKT(III,1),III=1,5)
37308       DO 71 IIG=2,2+IIGLU1-1
37309 C     WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37310 C    &             JMOHKT(1,IIG),JMOHKT(2,IIG),
37311 C    * JDAHKT(1,IIG),
37312 C    *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37313    71 CONTINUE
37314 C     WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
37315 C    * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
37316 C    *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
37317 C     WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
37318 C    * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
37319 C    *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
37320       ENDIF
37321       CHAMAL=CHAM1
37322       IF(IPIP.EQ.1)THEN
37323         IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
37324       ELSEIF(IPIP.EQ.2)THEN
37325         IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
37326       ENDIF
37327       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
37328 C       IREJ=1
37329         IPCO=0
37330 C       RETURN
37331 C       WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
37332         GO TO 3466
37333       ENDIF
37334       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
37335       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
37336       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
37337       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
37338       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
37339       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
37340       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
37341       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
37342       IF(IPIP.EQ.1)THEN
37343         IDHKT(4+IIGLU1)   =-(ISAQ1-6)
37344       ELSEIF(IPIP.EQ.2)THEN
37345         IDHKT(4+IIGLU1)   =ISAQ1
37346       ENDIF
37347       ISTHKT(4+IIGLU1)  =951
37348       JMOHKT(1,4+IIGLU1)=NC1P
37349       JMOHKT(2,4+IIGLU1)=0
37350       JDAHKT(1,4+IIGLU1)=6+IIGLU1
37351       JDAHKT(2,4+IIGLU1)=0
37352 C     create chain    6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37353       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
37354       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
37355       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
37356       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
37357 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
37358       XMIST  =(PHKT(4,4+IIGLU1)**2-
37359      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37360      *PHKT(1,4+IIGLU1)**2)
37361       IF(XMIST.GT.0.D0)THEN
37362       PHKT(5,4+IIGLU1)  =SQRT(PHKT(4,4+IIGLU1)**2-
37363      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37364      *PHKT(1,4+IIGLU1)**2)
37365       ELSE
37366 C     WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
37367       PHKT(5,4+IIGLU1)=0.D0
37368       ENDIF
37369       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
37370       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
37371       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
37372       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
37373       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
37374       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
37375       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
37376       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
37377       IDHKT(5+IIGLU1)   =IP22
37378       ISTHKT(5+IIGLU1)  =952
37379       JMOHKT(1,5+IIGLU1)=NC1T
37380       JMOHKT(2,5+IIGLU1)=0
37381       JDAHKT(1,5+IIGLU1)=6+IIGLU1
37382       JDAHKT(2,5+IIGLU1)=0
37383       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
37384       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
37385       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
37386       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
37387 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
37388       XMIST  =(PHKT(4,5+IIGLU1)**2-
37389      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37390      *PHKT(1,5+IIGLU1)**2)
37391       IF(XMIST.GT.0.D0)THEN
37392       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
37393      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37394      *PHKT(1,5+IIGLU1)**2)
37395       ELSE
37396 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37397         PHKT(5,5+IIGLU1)=0.D0
37398       ENDIF
37399       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
37400       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
37401       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
37402       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
37403       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
37404       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
37405       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
37406       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
37407       IDHKT(6+IIGLU1)   =88888
37408       ISTHKT(6+IIGLU1)  =95
37409       JMOHKT(1,6+IIGLU1)=4+IIGLU1
37410       JMOHKT(2,6+IIGLU1)=5+IIGLU1
37411       JDAHKT(1,6+IIGLU1)=0
37412       JDAHKT(2,6+IIGLU1)=0
37413       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37414       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37415       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37416       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37417       XMIST
37418      * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37419      *            -PHKT(3,6+IIGLU1)**2)
37420       IF(XMIST.GT.0.D0)THEN
37421       PHKT(5,6+IIGLU1)
37422      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37423      *            -PHKT(3,6+IIGLU1)**2)
37424       ELSE
37425 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37426         PHKT(5,5+IIGLU1)=0.D0
37427       ENDIF
37428 C     IF(IPIP.GE.2)THEN
37429 C     IF(NUMEV.EQ.-324)THEN
37430 C     WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37431 C    * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37432 C    *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37433 C     WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37434 C    * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37435 C    *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37436 C     WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37437 C    * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37438 C    *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37439 C     ENDIF
37440       CHAMAL=CHAM1
37441       IF(IPIP.EQ.1)THEN
37442         IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37443       ELSEIF(IPIP.EQ.2)THEN
37444         IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37445       ENDIF
37446       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37447 C       IREJ=1
37448         IPCO=0
37449 C       RETURN
37450 C       WRITE(6,*)' MUSQBS1 jump back from chain 6',
37451 C    *  CHAMAL,PHKT(5,6+IIGLU1)
37452         GO TO 3466
37453       ENDIF
37454       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
37455       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
37456       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
37457       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
37458       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
37459       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
37460       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
37461       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
37462 C     IDHKT(7)   =1000*IPP1+100*ISQ+1
37463       IDHKT(7+IIGLU1)   =IP1
37464       ISTHKT(7+IIGLU1)  =951
37465       JMOHKT(1,7+IIGLU1)=NC1P
37466       JMOHKT(2,7+IIGLU1)=0
37467 **NEW
37468 C     JDAHKT(1,7+IIGLU1)=9+IIGLU1
37469       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
37470 **
37471       JDAHKT(2,7+IIGLU1)=0
37472       PHKT(1,7+IIGLU1)  =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
37473       PHKT(2,7+IIGLU1)  =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
37474       PHKT(3,7+IIGLU1)  =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
37475       PHKT(4,7+IIGLU1)  =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
37476 C     PHKT(5,7+IIGLU1)  =PHKK(5,NC1P)
37477       XMIST  =(PHKT(4,7+IIGLU1)**2-
37478      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37479      *PHKT(1,7+IIGLU1)**2)
37480       IF(XMIST.GT.0.D0)THEN
37481       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
37482      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37483      *PHKT(1,7+IIGLU1)**2)
37484       ELSE
37485 C     WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
37486       PHKT(5,7+IIGLU1)=0.D0
37487       ENDIF
37488       VHKT(1,7+IIGLU1)  =VHKK(1,NC1P)
37489       VHKT(2,7+IIGLU1)  =VHKK(2,NC1P)
37490       VHKT(3,7+IIGLU1)  =VHKK(3,NC1P)
37491       VHKT(4,7+IIGLU1)  =VHKK(4,NC1P)
37492       WHKT(1,7+IIGLU1)  =WHKK(1,NC1P)
37493       WHKT(2,7+IIGLU1)  =WHKK(2,NC1P)
37494       WHKT(3,7+IIGLU1)  =WHKK(3,NC1P)
37495       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
37496 C     Insert here the IIGLU2 gluons
37497       PG1=0.D0
37498       PG2=0.D0
37499       PG3=0.D0
37500       PG4=0.D0
37501       IF(IIGLU2.GE.1)THEN
37502       JJG=NC2P
37503       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37504         KKG=JJG+IIG-7-IIGLU1
37505         IDHKT(IIG)   =IDHKK(KKG)
37506         ISTHKT(IIG)  =921
37507         JMOHKT(1,IIG)=KKG
37508         JMOHKT(2,IIG)=0
37509         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
37510         JDAHKT(2,IIG)=0
37511         PHKT(1,IIG)=PHKK(1,KKG)
37512         PG1=PG1+ PHKT(1,IIG)
37513         PHKT(2,IIG)=PHKK(2,KKG)
37514         PG2=PG2+ PHKT(2,IIG)
37515         PHKT(3,IIG)=PHKK(3,KKG)
37516         PG3=PG3+ PHKT(3,IIG)
37517         PHKT(4,IIG)=PHKK(4,KKG)
37518         PG4=PG4+ PHKT(4,IIG)
37519         PHKT(5,IIG)=PHKK(5,KKG)
37520         VHKT(1,IIG)  =VHKK(1,KKG)
37521         VHKT(2,IIG)  =VHKK(2,KKG)
37522         VHKT(3,IIG)  =VHKK(3,KKG)
37523         VHKT(4,IIG)  =VHKK(4,KKG)
37524         WHKT(1,IIG)  =WHKK(1,KKG)
37525         WHKT(2,IIG) =WHKK(2,KKG)
37526         WHKT(3,IIG) =WHKK(3,KKG)
37527         WHKT(4,IIG) =WHKK(4,KKG)
37528    81 CONTINUE
37529       ENDIF
37530       IF(IPIP.EQ.1)THEN
37531         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*ISQ1+3
37532         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
37533         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
37534         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
37535       ELSEIF(IPIP.EQ.2)THEN
37536         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*(-ISQ1+6)-3
37537         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
37538         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
37539         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
37540       ENDIF
37541       ISTHKT(8+IIGLU1+IIGLU2)  =952
37542       JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
37543       JMOHKT(2,8+IIGLU1+IIGLU2)=0
37544       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
37545       JDAHKT(2,8+IIGLU1+IIGLU2)=0
37546       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC2T)+
37547      * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
37548       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC2T)+
37549      * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
37550       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC2T)+
37551      * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
37552       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC2T)+
37553      * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
37554 C     WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
37555 C    * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
37556       IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
37557 C       IREJ=1
37558 C       WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
37559 C    *  ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
37560         IPCO=0
37561 C       RETURN
37562         GO TO 3466
37563       ENDIF
37564 C     PHKT(5,8)  =PHKK(5,NC2T)
37565       XMIST  =(PHKT(4,8+IIGLU1+IIGLU2)**2-
37566      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37567      *PHKT(1,8+IIGLU1+IIGLU2)**2)
37568       IF(XMIST.GT.0.D0)THEN
37569       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
37570      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37571      *PHKT(1,8+IIGLU1+IIGLU2)**2)
37572       ELSE
37573 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37574         PHKT(5,5+IIGLU1)=0.D0
37575       ENDIF
37576       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC2T)
37577       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC2T)
37578       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC2T)
37579       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC2T)
37580       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC2T)
37581       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC2T)
37582       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC2T)
37583       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC2T)
37584       IDHKT(9+IIGLU1+IIGLU2)   =88888
37585       ISTHKT(9+IIGLU1+IIGLU2)  =95
37586       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
37587       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
37588       JDAHKT(1,9+IIGLU1+IIGLU2)=0
37589       JDAHKT(2,9+IIGLU1+IIGLU2)=0
37590 **NEW
37591 C     PHKT(1,9+IIGLU1+IIGLU2)
37592 C    * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37593 C     PHKT(2,9+IIGLU1+IIGLU2)
37594 C    * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37595 C     PHKT(3,9+IIGLU1+IIGLU2)
37596 C    * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37597 C     PHKT(4,9+IIGLU1+IIGLU2)
37598 C    * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37599       PHKT(1,9+IIGLU1+IIGLU2)
37600      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37601       PHKT(2,9+IIGLU1+IIGLU2)
37602      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37603       PHKT(3,9+IIGLU1+IIGLU2)
37604      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37605       PHKT(4,9+IIGLU1+IIGLU2)
37606      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37607 **
37608       XMIST
37609      * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37610      * -PHKT(2,9+IIGLU1+IIGLU2)**2
37611      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
37612       IF(XMIST.GT.0.D0)THEN
37613       PHKT(5,9+IIGLU1+IIGLU2)
37614      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37615      * -PHKT(2,9+IIGLU1+IIGLU2)**2
37616      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
37617       ELSE
37618 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37619         PHKT(5,5+IIGLU1)=0.D0
37620       ENDIF
37621       IF(IPIP.GE.2)THEN
37622 C     IF(NUMEV.EQ.-324)THEN
37623 C     WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
37624 C    * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
37625 C    *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
37626 C     DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37627 C     WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
37628 C    * JDAHKT(1,IIG),
37629 C    *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37630 C  91 CONTINUE
37631 C     WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
37632 C    * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
37633 C    *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
37634 C    *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
37635 C     WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
37636 C    * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
37637 C    *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
37638 C    *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
37639       ENDIF
37640       CHAMAL=CHAB1
37641       IF(IPIP.EQ.1)THEN
37642         IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37643       ELSEIF(IPIP.EQ.2)THEN
37644         IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37645       ENDIF
37646       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37647 C       IREJ=1
37648         IPCO=0
37649 C       RETURN
37650 C       WRITE(6,*)' MUSQBS1 jump back from chain 9',
37651 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
37652         GO TO 3466
37653       ENDIF
37654       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
37655       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
37656       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
37657       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
37658       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
37659       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
37660       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
37661       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
37662 C
37663       IPCO=0
37664       IGCOUN=9+IIGLU1+IIGLU2
37665        RETURN
37666        END
37667
37668 *$ CREATE MGSQBS2.FOR
37669 *COPY MGSQBS2
37670 C
37671 C
37672 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37673       SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37674      *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
37675 C
37676 C                  GSQBS-2 diagram (split target diquark)
37677 C
37678       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37679       SAVE
37680
37681       PARAMETER ( LINP = 10 ,
37682      &            LOUT = 6 ,
37683      &            LDAT = 9 )
37684 * event history
37685       PARAMETER (NMXHKK=200000)
37686       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37687      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37688      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37689 * extended event history
37690       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37691      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37692      &                IHIST(2,NMXHKK)
37693 * Lorentz-parameters of the current interaction
37694       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37695      &                UMO,PPCM,EPROJ,PPROJ
37696 * diquark-breaking mechanism
37697       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37698
37699 C
37700       PARAMETER (NTMHKK= 300)
37701       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37702      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37703      +(4,NTMHKK)
37704
37705 *KEEP,XSEADI.
37706       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37707      +SSMIMQ,VVMTHR
37708 *KEEP,DPRIN.
37709       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37710 C
37711 C                  GSQBS-2 diagram (split target diquark)
37712 C
37713 C
37714 C     Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
37715 C     Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
37716 C
37717 C     Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
37718 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37719 C
37720 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37721 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37722 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37723 C
37724 C
37725 C
37726 C       Put new chains into COMMON /HKKTMP/
37727 C
37728       IIGLU1=NC1T-NC1P-1
37729       IIGLU2=NC2T-NC2P-1
37730       IGCOUN=0
37731 C     WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37732       CVQ=1.D0
37733       IREJ=0
37734 C     IF(IPIP.EQ.2)THEN
37735 C     WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37736 C    *             'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
37737 C    *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37738 C    *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
37739 C     ENDIF
37740 C
37741 C
37742 C
37743 C     determine x-values of NC1T diquark
37744       XDIQT=PHKK(4,NC1T)*2.D0/UMO
37745       XVQP=PHKK(4,NC1P)*2.D0/UMO
37746 C
37747 C     determine x-values of sea quark pair
37748 C
37749       IPCO=1
37750       ICOU=0
37751  2234 CONTINUE
37752       ICOU=ICOU+1
37753       IF(ICOU.GE.500)THEN
37754         IREJ=1
37755         IF(ISQ.EQ.3)IREJ=3
37756         IF(IPCO.GE.3)
37757      &     WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
37758         IPCO=0
37759         RETURN
37760       ENDIF
37761       IF(IPCO.GE.3)
37762      &     WRITE(LOUT,*)'MGSQBS2 call  XSEAPA: UMO,XDIQT,XVQP ',
37763      * UMO, XDIQT,XVQP
37764       XSQ=0.D0
37765       XSAQ=0.D0
37766 **NEW
37767 C     CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37768       IF (IPIP.EQ.1) THEN
37769          XQMAX  = XDIQT/2.0D0
37770          XAQMAX = 2.D0*XVQP/3.0D0
37771       ELSE
37772          XQMAX  = 2.D0*XVQP/3.0D0
37773          XAQMAX = XDIQT/2.0D0
37774       ENDIF
37775       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37776       ISAQ = 6+ISQ
37777 C     write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
37778 **
37779         IF(IPCO.GE.3)
37780      &     WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37781       IF(IREJ.GE.1)THEN
37782         IF(IPCO.GE.3)
37783      &     WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37784         IPCO=0
37785         RETURN
37786       ENDIF
37787       IF(IPIP.EQ.1)THEN
37788         IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37789       ELSEIF(IPIP.EQ.2)THEN
37790         IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37791       ENDIF
37792       IF(IPCO.GE.3)THEN
37793         WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
37794      *  XDIQT,XVQP,XSQ,XSAQ
37795       ENDIF
37796 C
37797 C     subtract xsq,xsaq from NC1T diquark and NC1P quark
37798 C
37799 C     XSQ=0.D0
37800       IF(IPIP.EQ.1)THEN
37801         XDIQT=XDIQT-XSQ
37802         XVQP =XVQP -XSAQ
37803       ELSEIF(IPIP.EQ.2)THEN
37804         XDIQT=XDIQT-XSAQ
37805         XVQP =XVQP -XSQ
37806       ENDIF
37807       IF(IPCO.GE.3)
37808      &   WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
37809 C
37810 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37811 C
37812       XVTHRO=CVQ/UMO
37813       IVTHR=0
37814  3466 CONTINUE
37815       IF(IVTHR.EQ.10)THEN
37816         IREJ=1
37817         IF(ISQ.EQ.3)IREJ=3
37818         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
37819         IPCO=0
37820         RETURN
37821       ENDIF
37822       IVTHR=IVTHR+1
37823       XVTHR=XVTHRO/(201-IVTHR)
37824       UNOPRV=UNON
37825  380  CONTINUE
37826       IF(XVTHR.GT.0.66D0*XDIQT)THEN
37827         IREJ=1
37828         IF(ISQ.EQ.3)IREJ=3
37829         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR  large ',
37830      *  XVTHR
37831         IPCO=0
37832         RETURN
37833       ENDIF
37834       IF(DT_RNDM(V).LT.0.5D0)THEN
37835         XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37836         XVTQII=XDIQT-XVTQI
37837       ELSE
37838         XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37839         XVTQI=XDIQT-XVTQII
37840       ENDIF
37841       IF(IPCO.GE.3)THEN
37842         WRITE(LOUT,'(A,2E12.4)')'  MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
37843       ENDIF
37844 C
37845 C     Prepare 4 momenta of new chains and chain ends
37846 C
37847 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37848 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37849 C    +(4,NTMHKK)
37850 C
37851 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37852 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37853 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37854 C
37855 C     SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37856 C    *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
37857 C
37858       IF(IPIP.EQ.1)THEN
37859         XSQ1=XSQ
37860         XSAQ1=XSAQ
37861         ISQ1=ISQ
37862         ISAQ1=ISAQ
37863       ELSEIF(IPIP.EQ.2)THEN
37864         XSQ1=XSAQ
37865         XSAQ1=XSQ
37866         ISQ1=ISAQ
37867         ISAQ1=ISQ
37868       ENDIF
37869       KK11=IP21
37870 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
37871       KK21=IPP11
37872       KK22=IPP12
37873       XGIVE=0.D0
37874       IF(IPIP.EQ.1)THEN
37875         IDHKT(4+IIGLU1)   =-(ISAQ1-6)
37876       ELSEIF(IPIP.EQ.2)THEN
37877         IDHKT(4+IIGLU1)   =ISAQ1
37878       ENDIF
37879       ISTHKT(4+IIGLU1)  =961
37880       JMOHKT(1,4+IIGLU1)=NC1P
37881       JMOHKT(2,4+IIGLU1)=0
37882       JDAHKT(1,4+IIGLU1)=6+IIGLU1
37883       JDAHKT(2,4+IIGLU1)=0
37884 C     create chain    6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37885       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
37886       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
37887       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
37888       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
37889 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
37890       XXMIST=(PHKT(4,4+IIGLU1)**2-
37891      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37892      *PHKT(1,4+IIGLU1)**2)
37893       IF(XXMIST.GT.0.D0)THEN
37894         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
37895       ELSE
37896         WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
37897         XXMIST=ABS(XXMIST)
37898         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
37899       ENDIF
37900       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
37901       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
37902       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
37903       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
37904       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
37905       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
37906       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
37907       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
37908       IDHKT(5+IIGLU1)   =IP22
37909       ISTHKT(5+IIGLU1)  =962
37910       JMOHKT(1,5+IIGLU1)=NC1T
37911       JMOHKT(2,5+IIGLU1)=0
37912       JDAHKT(1,5+IIGLU1)=6+IIGLU1
37913       JDAHKT(2,5+IIGLU1)=0
37914       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
37915       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
37916       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
37917       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
37918 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
37919       XXMIST=(PHKT(4,5+IIGLU1)**2-
37920      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37921      *PHKT(1,5+IIGLU1)**2)
37922       IF(XXMIST.GT.0.D0)THEN
37923         PHKT(5,5+IIGLU1)  =SQRT(XXMIST)
37924       ELSE
37925         WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
37926         XXMIST=ABS(XXMIST)
37927         PHKT(5,5+IIGLU1)  =SQRT(XXMIST)
37928       ENDIF
37929       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
37930       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
37931       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
37932       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
37933       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
37934       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
37935       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
37936       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
37937       IDHKT(6+IIGLU1)   =88888
37938       ISTHKT(6+IIGLU1)  =96
37939       JMOHKT(1,6+IIGLU1)=4+IIGLU1
37940       JMOHKT(2,6+IIGLU1)=5+IIGLU1
37941       JDAHKT(1,6+IIGLU1)=0
37942       JDAHKT(2,6+IIGLU1)=0
37943       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37944       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37945       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37946       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37947       PHKT(5,6+IIGLU1)
37948      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37949      *            -PHKT(3,6+IIGLU1)**2)
37950       CHAMAL=CHAM1
37951       IF(IPIP.EQ.1)THEN
37952         IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37953       ELSEIF(IPIP.EQ.2)THEN
37954         IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37955       ENDIF
37956 C---------------------------------------------------
37957       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37958         IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
37959 C                    we drop chain 6 and give the energy to chain 3
37960           IDHKT(6+IIGLU1)=22888
37961           XGIVE=1.D0
37962 C         WRITE(6,*)' drop chain 6 xgive=1'
37963           GO TO 7788
37964         ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
37965 C                    we drop chain 6 and give the energy to chain 3
37966 C                    and change KK11 to IDHKT(5)
37967           IDHKT(6+IIGLU1)=22888
37968           XGIVE=1.D0
37969 C         WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
37970           KK11=IDHKT(5+IIGLU1)
37971           GO TO 7788
37972         ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
37973 C                    we drop chain 6 and give the energy to chain 3
37974 C                    and change KK21 to IDHKT(5+IIGLU1)
37975 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
37976           IDHKT(6+IIGLU1)=22888
37977           XGIVE=1.D0
37978 C         WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
37979           KK21=IDHKT(5+IIGLU1)
37980           GO TO 7788
37981         ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
37982 C                    we drop chain 6 and give the energy to chain 3
37983 C                    and change KK22 to IDHKT(5)
37984 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
37985           IDHKT(6+IIGLU1)=22888
37986           XGIVE=1.D0
37987 C         WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
37988           KK22=IDHKT(5+IIGLU1)
37989           GO TO 7788
37990         ENDIF
37991 C       IREJ=1
37992         IPCO=0
37993 C       RETURN
37994         GO TO 3466
37995       ENDIF
37996  7788 CONTINUE
37997 C---------------------------------------------------
37998       IF(IPIP.GE.3)THEN
37999       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
38000      * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
38001      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
38002       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
38003      * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
38004      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
38005       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
38006      * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
38007      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
38008       ENDIF
38009       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
38010       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
38011       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
38012       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
38013       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
38014       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
38015       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
38016       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
38017 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
38018       IF(IPIP.EQ.1)THEN
38019         IDHKT(1)   =1000*KK21+100*KK22+3
38020         IF(IDHKT(1).EQ.1203)IDHKT(1)=2103
38021         IF(IDHKT(1).EQ.1303)IDHKT(1)=3103
38022         IF(IDHKT(1).EQ.2303)IDHKT(1)=3203
38023       ELSEIF(IPIP.EQ.2)THEN
38024         IDHKT(1)   =1000*KK21+100*KK22-3
38025         IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103
38026         IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103
38027         IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203
38028       ENDIF
38029       ISTHKT(1)  =961
38030       JMOHKT(1,1)=NC2P
38031       JMOHKT(2,1)=0
38032       JDAHKT(1,1)=3+IIGLU1
38033       JDAHKT(2,1)=0
38034 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
38035       PHKT(1,1)  =PHKK(1,NC2P)
38036      *+XGIVE*PHKT(1,4+IIGLU1)
38037       PHKT(2,1)  =PHKK(2,NC2P)
38038      *+XGIVE*PHKT(2,4+IIGLU1)
38039       PHKT(3,1)  =PHKK(3,NC2P)
38040      *+XGIVE*PHKT(3,4+IIGLU1)
38041       PHKT(4,1)  =PHKK(4,NC2P)
38042      *+XGIVE*PHKT(4,4+IIGLU1)
38043 C     PHKT(5,1)  =PHKK(5,NC2P)
38044       XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38045      *PHKT(1,1)**2
38046       IF(XXMIST.GT.0.D0)THEN
38047         PHKT(5,1)  =SQRT(XXMIST)
38048       ELSE
38049         WRITE(LOUT,*)'MGSQBS2',XXMIST
38050         XXMIST=ABS(XXMIST)
38051         PHKT(5,1)  =SQRT(XXMIST)
38052       ENDIF
38053       VHKT(1,1)  =VHKK(1,NC2P)
38054       VHKT(2,1)  =VHKK(2,NC2P)
38055       VHKT(3,1)  =VHKK(3,NC2P)
38056       VHKT(4,1)  =VHKK(4,NC2P)
38057       WHKT(1,1)  =WHKK(1,NC2P)
38058       WHKT(2,1)  =WHKK(2,NC2P)
38059       WHKT(3,1)  =WHKK(3,NC2P)
38060       WHKT(4,1)  =WHKK(4,NC2P)
38061 C     Add here IIGLU1 gluons to this chaina
38062       PG1=0.D0
38063       PG2=0.D0
38064       PG3=0.D0
38065       PG4=0.D0
38066       IF(IIGLU1.GE.1)THEN
38067       JJG=NC1P
38068       DO 61 IIG=2,2+IIGLU1-1
38069         KKG=JJG+IIG-1
38070         IDHKT(IIG)   =IDHKK(KKG)
38071         ISTHKT(IIG)  =921
38072         JMOHKT(1,IIG)=KKG
38073         JMOHKT(2,IIG)=0
38074         JDAHKT(1,IIG)=3+IIGLU1
38075         JDAHKT(2,IIG)=0
38076         PHKT(1,IIG)=PHKK(1,KKG)
38077         PG1=PG1+ PHKT(1,IIG)
38078         PHKT(2,IIG)=PHKK(2,KKG)
38079         PG2=PG2+ PHKT(2,IIG)
38080         PHKT(3,IIG)=PHKK(3,KKG)
38081         PG3=PG3+ PHKT(3,IIG)
38082         PHKT(4,IIG)=PHKK(4,KKG)
38083         PG4=PG4+ PHKT(4,IIG)
38084         PHKT(5,IIG)=PHKK(5,KKG)
38085         VHKT(1,IIG)  =VHKK(1,KKG)
38086         VHKT(2,IIG)  =VHKK(2,KKG)
38087         VHKT(3,IIG)  =VHKK(3,KKG)
38088         VHKT(4,IIG)  =VHKK(4,KKG)
38089         WHKT(1,IIG)  =WHKK(1,KKG)
38090         WHKT(2,IIG)  =WHKK(2,KKG)
38091         WHKT(3,IIG)  =WHKK(3,KKG)
38092         WHKT(4,IIG)  =WHKK(4,KKG)
38093    61 CONTINUE
38094       ENDIF
38095 C     IDHKT(2)   =IP21
38096       IDHKT(2+IIGLU1)   =KK11
38097       ISTHKT(2+IIGLU1)  =962
38098       JMOHKT(1,2+IIGLU1)=NC1T
38099       JMOHKT(2,2+IIGLU1)=0
38100       JDAHKT(1,2+IIGLU1)=3+IIGLU1
38101       JDAHKT(2,2+IIGLU1)=0
38102       PHKT(1,2+IIGLU1)  =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
38103 C    * +0.5D0*PHKK(1,NC2T)
38104      *+XGIVE*PHKT(1,5+IIGLU1)
38105       PHKT(2,2+IIGLU1)  =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
38106 C    *+0.5D0*PHKK(2,NC2T)
38107      *+XGIVE*PHKT(2,5+IIGLU1)
38108       PHKT(3,2+IIGLU1)  =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
38109 C    *+0.5D0*PHKK(3,NC2T)
38110      *+XGIVE*PHKT(3,5+IIGLU1)
38111       PHKT(4,2+IIGLU1)  =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
38112 C    *+0.5D0*PHKK(4,NC2T)
38113      *+XGIVE*PHKT(4,5+IIGLU1)
38114 C     PHKT(5,2)  =PHKK(5,NC1T)
38115       XXMIST=(PHKT(4,2+IIGLU1)**2-
38116      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38117      *PHKT(1,2+IIGLU1)**2)
38118       IF(XXMIST.GT.0.D0)THEN
38119         PHKT(5,2+IIGLU1)  =SQRT(XXMIST)
38120       ELSE
38121         WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
38122         XXMIST=ABS(XXMIST)
38123         PHKT(5,2+IIGLU1)  =SQRT(XXMIST)
38124       ENDIF
38125       VHKT(1,2+IIGLU1)  =VHKK(1,NC1T)
38126       VHKT(2,2+IIGLU1)  =VHKK(2,NC1T)
38127       VHKT(3,2+IIGLU1)  =VHKK(3,NC1T)
38128       VHKT(4,2+IIGLU1)  =VHKK(4,NC1T)
38129       WHKT(1,2+IIGLU1)  =WHKK(1,NC1T)
38130       WHKT(2,2+IIGLU1)  =WHKK(2,NC1T)
38131       WHKT(3,2+IIGLU1)  =WHKK(3,NC1T)
38132       WHKT(4,2+IIGLU1)  =WHKK(4,NC1T)
38133       IDHKT(3+IIGLU1)   =88888
38134       ISTHKT(3+IIGLU1)  =96
38135       JMOHKT(1,3+IIGLU1)=1
38136       JMOHKT(2,3+IIGLU1)=2+IIGLU1
38137       JDAHKT(1,3+IIGLU1)=0
38138       JDAHKT(2,3+IIGLU1)=0
38139       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38140       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38141       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38142       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38143       PHKT(5,3+IIGLU1)
38144      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38145      *            -PHKT(3,3+IIGLU1)**2)
38146       IF(IPIP.EQ.3)THEN
38147       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
38148      * JDAHKT(1,1),
38149      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38150       DO 71 IIG=2,2+IIGLU1-1
38151       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38152      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38153      * JDAHKT(1,IIG),
38154      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38155    71 CONTINUE
38156       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
38157      * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38158      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38159       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38160      * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38161      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38162       ENDIF
38163       CHAMAL=CHAB1
38164       IF(IPIP.EQ.1)THEN
38165         IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
38166       ELSEIF(IPIP.EQ.2)THEN
38167         IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
38168       ENDIF
38169       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38170 C       IREJ=1
38171         IPCO=0
38172 C       RETURN
38173         GO TO 3466
38174       ENDIF
38175       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
38176       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
38177       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
38178       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
38179       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
38180       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
38181       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
38182       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
38183 C     IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ+1
38184       IDHKT(7+IIGLU1)   =IP1
38185       ISTHKT(7+IIGLU1)  =961
38186       JMOHKT(1,7+IIGLU1)=NC1P
38187       JMOHKT(2,7+IIGLU1)=0
38188       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38189       JDAHKT(2,7+IIGLU1)=0
38190       PHKT(1,7+IIGLU1)  =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
38191       PHKT(2,7+IIGLU1)  =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
38192       PHKT(3,7+IIGLU1)  =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
38193       PHKT(4,7+IIGLU1)  =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
38194 C     PHKT(5,7+IIGLU1)  =PHKK(5,NC1P)
38195       XXMIST=(PHKT(4,7+IIGLU1)**2-
38196      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38197      *PHKT(1,7+IIGLU1)**2)
38198       IF(XXMIST.GT.0.D0)THEN
38199         PHKT(5,7+IIGLU1)  =SQRT(XXMIST)
38200       ELSE
38201         WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
38202         XXMIST=ABS(XXMIST)
38203         PHKT(5,7+IIGLU1)  =SQRT(XXMIST)
38204       ENDIF
38205       VHKT(1,7+IIGLU1)  =VHKK(1,NC1P)
38206       VHKT(2,7+IIGLU1)  =VHKK(2,NC1P)
38207       VHKT(3,7+IIGLU1)  =VHKK(3,NC1P)
38208       VHKT(4,7+IIGLU1)  =VHKK(4,NC1P)
38209       WHKT(1,7+IIGLU1)  =WHKK(1,NC1P)
38210       WHKT(2,7+IIGLU1)  =WHKK(2,NC1P)
38211       WHKT(3,7+IIGLU1)  =WHKK(3,NC1P)
38212       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
38213 C     IDHKT(7)   =1000*IPP1+100*ISQ+1
38214 C     Insert here the IIGLU2 gluons
38215       PG1=0.D0
38216       PG2=0.D0
38217       PG3=0.D0
38218       PG4=0.D0
38219       IF(IIGLU2.GE.1)THEN
38220       JJG=NC2P
38221       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38222         KKG=JJG+IIG-7-IIGLU1
38223         IDHKT(IIG)   =IDHKK(KKG)
38224         ISTHKT(IIG)  =921
38225         JMOHKT(1,IIG)=KKG
38226         JMOHKT(2,IIG)=0
38227         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38228         JDAHKT(2,IIG)=0
38229         PHKT(1,IIG)=PHKK(1,KKG)
38230         PG1=PG1+ PHKT(1,IIG)
38231         PHKT(2,IIG)=PHKK(2,KKG)
38232         PG2=PG2+ PHKT(2,IIG)
38233         PHKT(3,IIG)=PHKK(3,KKG)
38234         PG3=PG3+ PHKT(3,IIG)
38235         PHKT(4,IIG)=PHKK(4,KKG)
38236         PG4=PG4+ PHKT(4,IIG)
38237         PHKT(5,IIG)=PHKK(5,KKG)
38238         VHKT(1,IIG)  =VHKK(1,KKG)
38239         VHKT(2,IIG)  =VHKK(2,KKG)
38240         VHKT(3,IIG)  =VHKK(3,KKG)
38241         VHKT(4,IIG)  =VHKK(4,KKG)
38242         WHKT(1,IIG)  =WHKK(1,KKG)
38243         WHKT(2,IIG)  =WHKK(2,KKG)
38244         WHKT(3,IIG)  =WHKK(3,KKG)
38245         WHKT(4,IIG)  =WHKK(4,KKG)
38246    81 CONTINUE
38247       ENDIF
38248       IF(IPIP.EQ.1)THEN
38249         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*ISQ1+3
38250         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
38251         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
38252         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
38253       ELSEIF(IPIP.EQ.2)THEN
38254 **NEW
38255 C       IDHKT(8)   =1000*IPP2+100*(-ISQ1+6)-3
38256         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*(-ISQ1+6)-3
38257 **
38258         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
38259         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
38260         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
38261       ENDIF
38262       ISTHKT(8+IIGLU1+IIGLU2)  =962
38263       JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
38264       JMOHKT(2,8+IIGLU1+IIGLU2)=0
38265       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38266       JDAHKT(2,8+IIGLU1+IIGLU2)=0
38267 C     PHKT(1,8)  =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
38268 C     PHKT(2,8)  =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
38269 C     PHKT(3,8)  =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
38270 C     PHKT(4,8)  =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
38271       PHKT(1,8+IIGLU1+IIGLU2)  =
38272      * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
38273       PHKT(2,8+IIGLU1+IIGLU2)  =
38274      * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
38275       PHKT(3,8+IIGLU1+IIGLU2)  =
38276      * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
38277       PHKT(4,8+IIGLU1+IIGLU2)  =
38278      * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
38279 C     WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
38280 C    * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
38281       IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
38282 C       IREJ=1
38283 C       WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
38284         IPCO=0
38285 C       RETURN
38286         GO TO 3466
38287       ENDIF
38288 C     PHKT(5,8)  =PHKK(5,NC2T)
38289       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38290      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38291      *PHKT(1,8+IIGLU1+IIGLU2)**2)
38292       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC2T)
38293       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC2T)
38294       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC2T)
38295       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC2T)
38296       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC2T)
38297       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC2T)
38298       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC2T)
38299       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC2T)
38300       IDHKT(9+IIGLU1+IIGLU2)   =88888
38301       ISTHKT(9+IIGLU1+IIGLU2)  =96
38302       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38303       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38304       JDAHKT(1,9+IIGLU1+IIGLU2)=0
38305       JDAHKT(2,9+IIGLU1+IIGLU2)=0
38306       PHKT(1,9+IIGLU1+IIGLU2)
38307      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
38308       PHKT(2,9+IIGLU1+IIGLU2)
38309      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
38310       PHKT(3,9+IIGLU1+IIGLU2)
38311      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
38312       PHKT(4,9+IIGLU1+IIGLU2)
38313      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
38314       PHKT(5,9+IIGLU1+IIGLU2)
38315      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
38316      * PHKT(2,9+IIGLU1+IIGLU2)**2
38317      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
38318       IF(IPIP.GE.3)THEN
38319       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38320      * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38321      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38322       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38323       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38324      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38325      * JDAHKT(1,IIG),
38326      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38327    91 CONTINUE
38328       WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
38329      * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
38330      *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
38331      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38332       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38333      * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
38334      *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
38335      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38336       ENDIF
38337       CHAMAL=CHAB1
38338       IF(IPIP.EQ.1)THEN
38339         IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38340       ELSEIF(IPIP.EQ.2)THEN
38341         IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38342       ENDIF
38343       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38344 C       IREJ=1
38345         IPCO=0
38346 C       RETURN
38347         GO TO 3466
38348       ENDIF
38349       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
38350       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
38351       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
38352       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
38353       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
38354       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
38355       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
38356       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
38357 C
38358       IPCO=0
38359       IGCOUN=9+IIGLU1+IIGLU2
38360        RETURN
38361        END
38362
38363 *$ CREATE MUSQBS1.FOR
38364 *COPY MUSQBS1
38365 C
38366 C
38367 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38368       SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38369      *              IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
38370 C
38371 C                  USQBS-1 diagram (split projectile diquark)
38372 C
38373       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38374       SAVE
38375
38376       PARAMETER ( LINP = 10 ,
38377      &            LOUT = 6 ,
38378      &            LDAT = 9 )
38379 * event history
38380       PARAMETER (NMXHKK=200000)
38381       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38382      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38383      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38384 * extended event history
38385       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38386      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38387      &                IHIST(2,NMXHKK)
38388 * Lorentz-parameters of the current interaction
38389       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
38390      &                UMO,PPCM,EPROJ,PPROJ
38391 * diquark-breaking mechanism
38392       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
38393
38394 C
38395       PARAMETER (NTMHKK= 300)
38396       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38397      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38398      +(4,NTMHKK)
38399 *KEEP,XSEADI.
38400       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
38401      +SSMIMQ,VVMTHR
38402 *KEEP,DPRIN.
38403       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
38404       COMMON /EVFLAG/ NUMEV
38405 C
38406 C                  USQBS-1 diagram (split projectile diquark)
38407 C
38408 C     Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
38409 C     Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
38410 C
38411 C     Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
38412 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
38413 C
38414 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38415 C                   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38416 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38417 C
38418 C       Put new chains into COMMON /HKKTMP/
38419 C
38420       IIGLU1=NC1T-NC1P-1
38421       IIGLU2=NC2T-NC2P-1
38422       IGCOUN=0
38423 C     WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
38424       CVQ=1.D0
38425       IREJ=0
38426       IF(IPIP.EQ.3)THEN
38427 C     IF(NUMEV.EQ.-324)THEN
38428       WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
38429      *             ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
38430      *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38431      *              IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
38432       ENDIF
38433 C
38434 C
38435 C
38436 C     determine x-values of NC1P diquark
38437       XDIQP=PHKK(4,NC1P)*2.D0/UMO
38438       XVQT=PHKK(4,NC1T)*2.D0/UMO
38439 C
38440 C     determine x-values of sea quark pair
38441 C
38442       IPCO=1
38443       ICOU=0
38444  2234 CONTINUE
38445       ICOU=ICOU+1
38446       IF(ICOU.GE.500)THEN
38447         IREJ=1
38448         IF(ISQ.EQ.3)IREJ=3
38449         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
38450         IPCO=0
38451         RETURN
38452       ENDIF
38453       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call  XSEAPA: UMO,XDIQP,XVQT ',
38454      * UMO, XDIQP,XVQT
38455       XSQ=0.D0
38456       XSAQ=0.D0
38457 **NEW
38458 C     CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
38459       IF (IPIP.EQ.1) THEN
38460          XQMAX  = XDIQP/2.0D0
38461          XAQMAX = 2.D0*XVQT/3.0D0
38462       ELSE
38463          XQMAX  = 2.D0*XVQT/3.0D0
38464          XAQMAX = XDIQP/2.0D0
38465       ENDIF
38466       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
38467       ISAQ = 6+ISQ
38468 C     write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
38469 **
38470       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
38471       IF(IREJ.GE.1)THEN
38472         IF(IPCO.GE.3)
38473      &     WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
38474         IPCO=0
38475         RETURN
38476       ENDIF
38477       IF(IPIP.EQ.1)THEN
38478         IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
38479       ELSEIF(IPIP.EQ.2)THEN
38480         IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
38481       ENDIF
38482       IF(IPCO.GE.3)THEN
38483         WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
38484      *  XDIQP,XVQT,XSQ,XSAQ
38485       ENDIF
38486 C
38487 C     subtract xsq,xsaq from NC1P diquark and NC1T quark
38488 C
38489 C     XSQ=0.D0
38490       IF(IPIP.EQ.1)THEN
38491         XDIQP=XDIQP-XSQ
38492         XVQT =XVQT -XSAQ
38493       ELSEIF(IPIP.EQ.2)THEN
38494         XDIQP=XDIQP-XSAQ
38495         XVQT =XVQT -XSQ
38496       ENDIF
38497       IF(IPCO.GE.3)
38498      &   WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
38499 C
38500 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
38501 C
38502       XVTHRO=CVQ/UMO
38503       IVTHR=0
38504  3466 CONTINUE
38505       IF(IVTHR.EQ.10)THEN
38506         IREJ=1
38507         IF(ISQ.EQ.3)IREJ=3
38508         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
38509         IPCO=0
38510         RETURN
38511       ENDIF
38512       IVTHR=IVTHR+1
38513       XVTHR=XVTHRO/(201-IVTHR)
38514       UNOPRV=UNON
38515  380  CONTINUE
38516       IF(XVTHR.GT.0.66D0*XDIQP)THEN
38517         IREJ=1
38518         IF(ISQ.EQ.3)IREJ=3
38519         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR  large ',
38520      *  XVTHR
38521         IPCO=0
38522         RETURN
38523       ENDIF
38524       IF(DT_RNDM(V).LT.0.5D0)THEN
38525         XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
38526         XVPQII=XDIQP-XVPQI
38527       ELSE
38528         XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
38529         XVPQI=XDIQP-XVPQII
38530       ENDIF
38531       IF(IPCO.GE.3)THEN
38532         WRITE(LOUT,'(A,2E12.4)')'  MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
38533       ENDIF
38534 C
38535 C     Prepare 4 momenta of new chains and chain ends
38536 C
38537 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38538 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38539 C    +(4,NTMHKK)
38540 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38541 C                   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38542 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38543       IF(IPIP.EQ.1)THEN
38544         XSQ1=XSQ
38545         XSAQ1=XSAQ
38546         ISQ1=ISQ
38547         ISAQ1=ISAQ
38548       ELSEIF(IPIP.EQ.2)THEN
38549         XSQ1=XSAQ
38550         XSAQ1=XSQ
38551         ISQ1=ISAQ
38552         ISAQ1=ISQ
38553       ENDIF
38554       IDHKT(1)   =IP11
38555       ISTHKT(1)  =931
38556       JMOHKT(1,1)=NC1P
38557       JMOHKT(2,1)=0
38558       JDAHKT(1,1)=3+IIGLU1
38559       JDAHKT(2,1)=0
38560 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38561       PHKT(1,1)  =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
38562       PHKT(2,1)  =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
38563       PHKT(3,1)  =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
38564       PHKT(4,1)  =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
38565 C     PHKT(5,1)  =PHKK(5,NC1P)
38566       XMIST  =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38567      *PHKT(1,1)**2)
38568       IF(XMIST.GE.0.D0)THEN
38569       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38570      *PHKT(1,1)**2)
38571       ELSE
38572 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38573        PHKT(5,1)=0.D0
38574       ENDIF
38575       VHKT(1,1)  =VHKK(1,NC1P)
38576       VHKT(2,1)  =VHKK(2,NC1P)
38577       VHKT(3,1)  =VHKK(3,NC1P)
38578       VHKT(4,1)  =VHKK(4,NC1P)
38579       WHKT(1,1)  =WHKK(1,NC1P)
38580       WHKT(2,1)  =WHKK(2,NC1P)
38581       WHKT(3,1)  =WHKK(3,NC1P)
38582       WHKT(4,1)  =WHKK(4,NC1P)
38583 C     Add here IIGLU1 gluons to this chaina
38584       PG1=0.D0
38585       PG2=0.D0
38586       PG3=0.D0
38587       PG4=0.D0
38588       IF(IIGLU1.GE.1)THEN
38589       JJG=NC1P
38590       DO 61 IIG=2,2+IIGLU1-1
38591         KKG=JJG+IIG-1
38592         IDHKT(IIG)   =IDHKK(KKG)
38593         ISTHKT(IIG)  =921
38594         JMOHKT(1,IIG)=KKG
38595         JMOHKT(2,IIG)=0
38596         JDAHKT(1,IIG)=3+IIGLU1
38597         JDAHKT(2,IIG)=0
38598         PHKT(1,IIG)=PHKK(1,KKG)
38599         PG1=PG1+ PHKT(1,IIG)
38600         PHKT(2,IIG)=PHKK(2,KKG)
38601         PG2=PG2+ PHKT(2,IIG)
38602         PHKT(3,IIG)=PHKK(3,KKG)
38603         PG3=PG3+ PHKT(3,IIG)
38604         PHKT(4,IIG)=PHKK(4,KKG)
38605         PG4=PG4+ PHKT(4,IIG)
38606         PHKT(5,IIG)=PHKK(5,KKG)
38607         VHKT(1,IIG)  =VHKK(1,KKG)
38608         VHKT(2,IIG)  =VHKK(2,KKG)
38609         VHKT(3,IIG)  =VHKK(3,KKG)
38610         VHKT(4,IIG)  =VHKK(4,KKG)
38611         WHKT(1,IIG) =WHKK(1,KKG)
38612         WHKT(2,IIG) =WHKK(2,KKG)
38613         WHKT(3,IIG) =WHKK(3,KKG)
38614         WHKT(4,IIG) =WHKK(4,KKG)
38615    61 CONTINUE
38616       ENDIF
38617       IDHKT(2+IIGLU1)   =IPP2
38618       ISTHKT(2+IIGLU1)  =932
38619       JMOHKT(1,2+IIGLU1)=NC2T
38620       JMOHKT(2,2+IIGLU1)=0
38621       JDAHKT(1,2+IIGLU1)=3+IIGLU1
38622       JDAHKT(2,2+IIGLU1)=0
38623       PHKT(1,2+IIGLU1)  =PHKK(1,NC2T)
38624       PHKT(2,2+IIGLU1)  =PHKK(2,NC2T)
38625       PHKT(3,2+IIGLU1)  =PHKK(3,NC2T)
38626       PHKT(4,2+IIGLU1)  =PHKK(4,NC2T)
38627 C     PHKT(5,2+IIGLU1)  =PHKK(5,NC2T)
38628       XMIST=(PHKT(4,2+IIGLU1)**2-
38629      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38630      *PHKT(1,2+IIGLU1)**2)
38631       IF(XMIST.GT.0.D0)THEN
38632       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
38633      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38634      *PHKT(1,2+IIGLU1)**2)
38635       ELSE
38636 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38637         PHKT(5,2+IIGLU1)=0.D0
38638       ENDIF
38639       VHKT(1,2+IIGLU1)  =VHKK(1,NC2T)
38640       VHKT(2,2+IIGLU1)  =VHKK(2,NC2T)
38641       VHKT(3,2+IIGLU1)  =VHKK(3,NC2T)
38642       VHKT(4,2+IIGLU1)  =VHKK(4,NC2T)
38643       WHKT(1,2+IIGLU1)  =WHKK(1,NC2T)
38644       WHKT(2,2+IIGLU1)  =WHKK(2,NC2T)
38645       WHKT(3,2+IIGLU1)  =WHKK(3,NC2T)
38646       WHKT(4,2+IIGLU1)  =WHKK(4,NC2T)
38647       IDHKT(3+IIGLU1)   =88888
38648       ISTHKT(3+IIGLU1)  =94
38649       JMOHKT(1,3+IIGLU1)=1
38650       JMOHKT(2,3+IIGLU1)=2+IIGLU1
38651       JDAHKT(1,3+IIGLU1)=0
38652       JDAHKT(2,3+IIGLU1)=0
38653       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38654       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38655       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38656       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38657       XMIST
38658      * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38659      *            -PHKT(3,3+IIGLU1)**2)
38660       IF(XMIST.GE.0.D0)THEN
38661       PHKT(5,3+IIGLU1)
38662      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38663      *            -PHKT(3,3+IIGLU1)**2)
38664       ELSE
38665 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38666        PHKT(5,1)=0.D0
38667       ENDIF
38668       IF(IPIP.GE.3)THEN
38669 C     IF(NUMEV.EQ.-324)THEN
38670       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
38671      * JMOHKT(2,1),JDAHKT(1,1),
38672      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38673       DO 71 IIG=2,2+IIGLU1-1
38674       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38675      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38676      * JDAHKT(1,IIG),
38677      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38678    71 CONTINUE
38679       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
38680      * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38681      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38682       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38683      * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38684      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38685       ENDIF
38686       CHAMAL=CHAM1
38687       IF(IPIP.EQ.1)THEN
38688         IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
38689       ELSEIF(IPIP.EQ.2)THEN
38690         IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
38691       ENDIF
38692       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38693 C       IREJ=1
38694         IPCO=0
38695 C       RETURN
38696 C       WRITE(6,*)' MUSQBS1 jump back from chain 3'
38697         GO TO 3466
38698       ENDIF
38699       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
38700       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
38701       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
38702       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
38703       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
38704       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
38705       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
38706       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
38707       IDHKT(4+IIGLU1)   =IP12
38708       ISTHKT(4+IIGLU1)  =931
38709       JMOHKT(1,4+IIGLU1)=NC1P
38710       JMOHKT(2,4+IIGLU1)=0
38711       JDAHKT(1,4+IIGLU1)=6+IIGLU1
38712       JDAHKT(2,4+IIGLU1)=0
38713 C   create  chain   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38714       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
38715       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
38716       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
38717       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
38718 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
38719       XMIST  =(PHKT(4,4+IIGLU1)**2-
38720      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
38721      *PHKT(1,4+IIGLU1)**2)
38722       IF(XMIST.GT.0.D0)THEN
38723       PHKT(5,4+IIGLU1)  =SQRT(PHKT(4,4+IIGLU1)**2-
38724      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
38725      *PHKT(1,4+IIGLU1)**2)
38726       ELSE
38727 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38728         PHKT(5,4+IIGLU1)=0.D0
38729       ENDIF
38730       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
38731       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
38732       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
38733       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
38734       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
38735       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
38736       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
38737       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
38738       IF(IPIP.EQ.1)THEN
38739         IDHKT(5+IIGLU1)   =-(ISAQ1-6)
38740       ELSEIF(IPIP.EQ.2)THEN
38741         IDHKT(5+IIGLU1)   =ISAQ1
38742       ENDIF
38743       ISTHKT(5+IIGLU1)  =932
38744       JMOHKT(1,5+IIGLU1)=NC1T
38745       JMOHKT(2,5+IIGLU1)=0
38746       JDAHKT(1,5+IIGLU1)=6+IIGLU1
38747       JDAHKT(2,5+IIGLU1)=0
38748       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
38749       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
38750       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
38751       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
38752 C     IF( PHKT(4,5).EQ.0.D0)THEN
38753 C       IREJ=1
38754 CIPCO=0
38755 CRETURN
38756 C     ENDIF
38757 C     PHKT(5,5)  =PHKK(5,NC1T)
38758       XMIST=(PHKT(4,5+IIGLU1)**2-
38759      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
38760      *PHKT(1,5+IIGLU1)**2)
38761       IF(XMIST.GT.0.D0)THEN
38762       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
38763      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
38764      *PHKT(1,5+IIGLU1)**2)
38765       ELSE
38766 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38767         PHKT(5,5+IIGLU1)=0.D0
38768       ENDIF
38769       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
38770       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
38771       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
38772       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
38773       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
38774       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
38775       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
38776       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
38777       IDHKT(6+IIGLU1)   =88888
38778       ISTHKT(6+IIGLU1)  =94
38779       JMOHKT(1,6+IIGLU1)=4+IIGLU1
38780       JMOHKT(2,6+IIGLU1)=5+IIGLU1
38781       JDAHKT(1,6+IIGLU1)=0
38782       JDAHKT(2,6+IIGLU1)=0
38783       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
38784       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
38785       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
38786       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
38787       XMIST
38788      * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
38789      *            -PHKT(3,6+IIGLU1)**2)
38790       IF(XMIST.GE.0.D0)THEN
38791       PHKT(5,6+IIGLU1)
38792      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
38793      *            -PHKT(3,6+IIGLU1)**2)
38794       ELSE
38795 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38796        PHKT(5,1)=0.D0
38797       ENDIF
38798 C     IF(IPIP.EQ.3)THEN
38799       CHAMAL=CHAM1
38800       IF(IPIP.EQ.1)THEN
38801         IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
38802       ELSEIF(IPIP.EQ.2)THEN
38803         IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
38804       ENDIF
38805       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
38806 C       IREJ=1
38807         IPCO=0
38808 C       RETURN
38809 C       WRITE(6,*)' MGSQBS1 jump back from chain 6',
38810 C    *  CHAMAL,PHKT(5,6+IIGLU1)
38811         GO TO 3466
38812       ENDIF
38813       IF(IPIP.GE.3)THEN
38814 C     IF(NUMEV.EQ.-324)THEN
38815       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
38816      * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
38817      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
38818       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
38819      * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
38820      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
38821       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
38822      * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
38823      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
38824       ENDIF
38825       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
38826       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
38827       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
38828       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
38829       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
38830       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
38831       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
38832       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
38833       IF(IPIP.EQ.1)THEN
38834         IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ+3
38835         IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
38836         IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
38837         IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
38838       ELSEIF(IPIP.EQ.2)THEN
38839         IDHKT(7+IIGLU1)   =1000*IPP1+100*(-ISQ1+6)-3
38840         IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
38841         IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
38842         IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
38843 C       WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
38844       ENDIF
38845       ISTHKT(7+IIGLU1)  =931
38846       JMOHKT(1,7+IIGLU1)=NC2P
38847       JMOHKT(2,7+IIGLU1)=0
38848       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38849       JDAHKT(2,7+IIGLU1)=0
38850 C    create chain     9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38851       PHKT(1,7+IIGLU1)  =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
38852       PHKT(2,7+IIGLU1)  =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
38853       PHKT(3,7+IIGLU1)  =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
38854       PHKT(4,7+IIGLU1)  =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
38855 C     WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
38856 C    * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
38857       IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
38858 C       IREJ=1
38859 C       WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
38860         IPCO=0
38861 C       RETURN
38862         GO TO 3466
38863       ENDIF
38864 C     PHKT(5,7)  =PHKK(5,NC2P)
38865       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
38866      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38867      *PHKT(1,7+IIGLU1)**2)
38868       VHKT(1,7+IIGLU1)  =VHKK(1,NC2P)
38869       VHKT(2,7+IIGLU1)  =VHKK(2,NC2P)
38870       VHKT(3,7+IIGLU1)  =VHKK(3,NC2P)
38871       VHKT(4,7+IIGLU1)  =VHKK(4,NC2P)
38872       WHKT(1,7+IIGLU1)  =WHKK(1,NC2P)
38873       WHKT(2,7+IIGLU1)  =WHKK(2,NC2P)
38874       WHKT(3,7+IIGLU1)  =WHKK(3,NC2P)
38875       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
38876 C     Insert here the IIGLU2 gluons
38877       PG1=0.D0
38878       PG2=0.D0
38879       PG3=0.D0
38880       PG4=0.D0
38881       IF(IIGLU2.GE.1)THEN
38882       JJG=NC2P
38883       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38884         KKG=JJG+IIG-7-IIGLU1
38885         IDHKT(IIG)   =IDHKK(KKG)
38886         ISTHKT(IIG)  =921
38887         JMOHKT(1,IIG)=KKG
38888         JMOHKT(2,IIG)=0
38889         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38890         JDAHKT(2,IIG)=0
38891         PHKT(1,IIG)=PHKK(1,KKG)
38892         PG1=PG1+ PHKT(1,IIG)
38893         PHKT(2,IIG)=PHKK(2,KKG)
38894         PG2=PG2+ PHKT(2,IIG)
38895         PHKT(3,IIG)=PHKK(3,KKG)
38896         PG3=PG3+ PHKT(3,IIG)
38897         PHKT(4,IIG)=PHKK(4,KKG)
38898         PG4=PG4+ PHKT(4,IIG)
38899         PHKT(5,IIG)=PHKK(5,KKG)
38900         VHKT(1,IIG)  =VHKK(1,KKG)
38901         VHKT(2,IIG)  =VHKK(2,KKG)
38902         VHKT(3,IIG)  =VHKK(3,KKG)
38903         VHKT(4,IIG)  =VHKK(4,KKG)
38904         WHKT(1,IIG)  =WHKK(1,KKG)
38905         WHKT(2,IIG) =WHKK(2,KKG)
38906         WHKT(3,IIG) =WHKK(3,KKG)
38907         WHKT(4,IIG) =WHKK(4,KKG)
38908    81 CONTINUE
38909       ENDIF
38910       IDHKT(8+IIGLU1+IIGLU2)   =IP2
38911       ISTHKT(8+IIGLU1+IIGLU2)  =932
38912       JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
38913       JMOHKT(2,8+IIGLU1+IIGLU2)=0
38914       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38915       JDAHKT(2,8+IIGLU1+IIGLU2)=0
38916       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
38917       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
38918       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
38919       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
38920 C     PHKT(5,8+IIGLU1+IIGLU2)  =PHKK(5,NC1T)
38921       XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
38922      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38923      *PHKT(1,8+IIGLU1+IIGLU2)**2)
38924       IF(XMIST.GT.0.D0)THEN
38925       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38926      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38927      *PHKT(1,8+IIGLU1+IIGLU2)**2)
38928       ELSE
38929 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38930         PHKT(5,8+IIGLU1+IIGLU2)=0.D0
38931       ENDIF
38932       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC1T)
38933       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC1T)
38934       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC1T)
38935       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC1T)
38936       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC1T)
38937       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC1T)
38938       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC1T)
38939       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC1T)
38940       IDHKT(9+IIGLU1+IIGLU2)   =88888
38941       ISTHKT(9+IIGLU1+IIGLU2)  =94
38942       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38943       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38944       JDAHKT(1,9+IIGLU1+IIGLU2)=0
38945       JDAHKT(2,9+IIGLU1+IIGLU2)=0
38946       PHKT(1,9+IIGLU1+IIGLU2)
38947      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
38948       PHKT(2,9+IIGLU1+IIGLU2)
38949      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
38950       PHKT(3,9+IIGLU1+IIGLU2)
38951      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
38952       PHKT(4,9+IIGLU1+IIGLU2)
38953      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
38954       XMIST
38955      *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
38956      * -PHKT(2,9+IIGLU1+IIGLU2)**2
38957      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
38958       IF(XMIST.GE.0.D0)THEN
38959       PHKT(5,9+IIGLU1+IIGLU2)
38960      *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
38961      * -PHKT(2,9+IIGLU1+IIGLU2)**2
38962      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
38963       ELSE
38964 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38965        PHKT(5,1)=0.D0
38966       ENDIF
38967       IF(IPIP.GE.3)THEN
38968 C     IF(NUMEV.EQ.-324)THEN
38969       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38970      * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38971      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38972       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38973       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38974      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38975      * JDAHKT(1,IIG),
38976      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38977    91 CONTINUE
38978       WRITE(LOUT,*)8+IIGLU1+IIGLU2,
38979      * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
38980      * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
38981      *JDAHKT(1,8+IIGLU1+IIGLU2),
38982      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38983       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38984      * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
38985      *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
38986      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38987       ENDIF
38988       CHAMAL=CHAB1
38989       IF(IPIP.EQ.1)THEN
38990         IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38991       ELSEIF(IPIP.EQ.2)THEN
38992         IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38993       ENDIF
38994       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38995 C       IREJ=1
38996         IPCO=0
38997 C       RETURN
38998 C       WRITE(6,*)' MGSQBS1 jump back from chain 9',
38999 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
39000         GO TO 3466
39001       ENDIF
39002       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
39003       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
39004       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
39005       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
39006       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
39007       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
39008       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
39009       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
39010 C
39011       IPCO=0
39012       IGCOUN=9+IIGLU1+IIGLU2
39013        RETURN
39014        END
39015
39016 *$ CREATE MGSQBS1.FOR
39017 *COPY MGSQBS1
39018 C
39019 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
39020       SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
39021      *              IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
39022 C
39023 C                  GSQBS-1 diagram (split projectile diquark)
39024 C
39025       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39026       SAVE
39027
39028       PARAMETER ( LINP = 10 ,
39029      &            LOUT = 6 ,
39030      &            LDAT = 9 )
39031 * event history
39032       PARAMETER (NMXHKK=200000)
39033       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39034      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39035      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39036 * extended event history
39037       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39038      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39039      &                IHIST(2,NMXHKK)
39040 * Lorentz-parameters of the current interaction
39041       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
39042      &                UMO,PPCM,EPROJ,PPROJ
39043 * diquark-breaking mechanism
39044       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
39045
39046 C
39047       PARAMETER (NTMHKK= 300)
39048       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39049      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39050      +(4,NTMHKK)
39051 *KEEP,XSEADI.
39052       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
39053      +SSMIMQ,VVMTHR
39054 *KEEP,DPRIN.
39055       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
39056 C
39057 C                  GSQBS-1 diagram (split projectile diquark)
39058 C
39059 C
39060 C     Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
39061 C     Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
39062 C
39063 C     Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
39064 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
39065 C
39066 C     Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
39067 C                   6 valence quark(vq2P 4)-sea-quark(aqsP 5)
39068 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
39069 C
39070 C       Put new chains into COMMON /HKKTMP/
39071 C
39072       IIGLU1=NC1T-NC1P-1
39073       IIGLU2=NC2T-NC2P-1
39074       IGCOUN=0
39075 C     WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
39076       CVQ=1.D0
39077       NNNC1=IDHKK(NC1)/1000
39078       MMMC1=IDHKK(NC1)-NNNC1*1000
39079       KKKC1=ISTHKK(NC1)
39080       NNNC2=IDHKK(NC2)/1000
39081       MMMC2=IDHKK(NC2)-NNNC2*1000
39082       KKKC2=ISTHKK(NC2)
39083       IREJ=0
39084       IF(IPIP.EQ.3)THEN
39085       WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
39086      *             ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
39087      *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
39088      *              IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
39089       ENDIF
39090 C
39091 C
39092 C
39093 C     determine x-values of NC1P diquark
39094       XDIQP=PHKK(4,NC1P)*2.D0/UMO
39095       XVQT=PHKK(4,NC1T)*2.D0/UMO
39096 C
39097 C     determine x-values of sea quark pair
39098 C
39099       IPCO=1
39100       ICOU=0
39101  2234 CONTINUE
39102       ICOU=ICOU+1
39103       IF(ICOU.GE.500)THEN
39104         IREJ=1
39105         IF(ISQ.EQ.3)IREJ=3
39106         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
39107       IPCO=0
39108         RETURN
39109       ENDIF
39110       IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call  XSEAPA: UMO,XDIQP,XVQT ',
39111      * UMO, XDIQP,XVQT
39112       XSQ=0.D0
39113       XSAQ=0.D0
39114 **NEW
39115 C     CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
39116       IF (IPIP.EQ.1) THEN
39117          XQMAX  = XDIQP/2.0D0
39118          XAQMAX = 2.D0*XVQT/3.0D0
39119       ELSE
39120          XQMAX  = 2.D0*XVQT/3.0D0
39121          XAQMAX = XDIQP/2.0D0
39122       ENDIF
39123       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
39124       ISAQ = 6+ISQ
39125 C     write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
39126 **
39127         IF(IPCO.GE.3)
39128      &     WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
39129       IF(IREJ.GE.1)THEN
39130         IF(IPCO.GE.3)
39131      &     WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
39132       IPCO=0
39133         RETURN
39134       ENDIF
39135       IF(IPIP.EQ.1)THEN
39136         IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
39137       ELSEIF(IPIP.EQ.2)THEN
39138         IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
39139       ENDIF
39140       IF(IPCO.GE.3)THEN
39141         WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
39142      *  XDIQP,XVQT,XSQ,XSAQ
39143       ENDIF
39144 C
39145 C     subtract xsq,xsaq from NC1P diquark and NC1T quark
39146 C
39147 C     XSQ=0.D0
39148       IF(IPIP.EQ.1)THEN
39149         XDIQP=XDIQP-XSQ
39150 **NEW
39151 C       IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
39152 **
39153         XVQT =XVQT -XSAQ
39154       ELSEIF(IPIP.EQ.2)THEN
39155         XDIQP=XDIQP-XSAQ
39156         XVQT =XVQT -XSQ
39157       ENDIF
39158       IF(IPCO.GE.3)
39159      &   WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
39160 C
39161 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
39162 C
39163       XVTHRO=CVQ/UMO
39164       IVTHR=0
39165  3466 CONTINUE
39166       IF(IVTHR.EQ.10)THEN
39167         IREJ=1
39168         IF(ISQ.EQ.3)IREJ=3
39169         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
39170       IPCO=0
39171         RETURN
39172       ENDIF
39173       IVTHR=IVTHR+1
39174       XVTHR=XVTHRO/(201-IVTHR)
39175       UNOPRV=UNON
39176  380  CONTINUE
39177       IF(XVTHR.GT.0.66D0*XDIQP)THEN
39178         IREJ=1
39179         IF(ISQ.EQ.3)IREJ=3
39180         IF(IPCO.GE.3)
39181      &     WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR  large ',
39182      *  XVTHR
39183       IPCO=0
39184         RETURN
39185       ENDIF
39186       IF(DT_RNDM(V).LT.0.5D0)THEN
39187         XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
39188         XVPQII=XDIQP-XVPQI
39189       ELSE
39190         XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
39191         XVPQI=XDIQP-XVPQII
39192       ENDIF
39193       IF(IPCO.GE.3)THEN
39194         WRITE(LOUT,'(A,4E12.4)')'  MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
39195      *  XVTHR,XDIQP,XVPQI,XVPQII
39196       ENDIF
39197 C
39198 C     Prepare 4 momenta of new chains and chain ends
39199 C
39200 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39201 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39202 C    +(4,NTMHKK)
39203 C     Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
39204 C                   6 valence quark(vq2P 4)-sea-quark(aqsP 5)
39205 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
39206       IF(IPIP.EQ.1)THEN
39207         XSQ1=XSQ
39208         XSAQ1=XSAQ
39209         ISQ1=ISQ
39210         ISAQ1=ISAQ
39211       ELSEIF(IPIP.EQ.2)THEN
39212         XSQ1=XSAQ
39213         XSAQ1=XSQ
39214         ISQ1=ISAQ
39215         ISAQ1=ISQ
39216       ENDIF
39217       KK11=IP11
39218 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
39219       KK21= IPP21
39220       KK22= IPP22
39221       XGIVE=0.D0
39222       IDHKT(4+IIGLU1)   =IP12
39223       ISTHKT(4+IIGLU1)  =921
39224       JMOHKT(1,4+IIGLU1)=NC1P
39225       JMOHKT(2,4+IIGLU1)=0
39226       JDAHKT(1,4+IIGLU1)=6+IIGLU1
39227       JDAHKT(2,4+IIGLU1)=0
39228 **NEW
39229       IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
39230      &    (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
39231 **
39232       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
39233       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
39234       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
39235       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
39236 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
39237       XXMIST=(PHKT(4,4+IIGLU1)**2-
39238      *              PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
39239      *              PHKT(1,4+IIGLU1)**2)
39240       IF(XXMIST.GT.0.D0)THEN
39241         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
39242       ELSE
39243         WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
39244         XXMIST=ABS(XXMIST)
39245         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
39246       ENDIF
39247       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
39248       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
39249       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
39250       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
39251       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
39252       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
39253       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
39254       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
39255       IF(IPIP.EQ.1)THEN
39256         IDHKT(5+IIGLU1)   =-(ISAQ1-6)
39257       ELSEIF(IPIP.EQ.2)THEN
39258         IDHKT(5+IIGLU1)   =ISAQ1
39259       ENDIF
39260       ISTHKT(5+IIGLU1)  =922
39261       JMOHKT(1,5+IIGLU1)=NC1T
39262       JMOHKT(2,5+IIGLU1)=0
39263       JDAHKT(1,5+IIGLU1)=6+IIGLU1
39264       JDAHKT(2,5+IIGLU1)=0
39265 **NEW
39266       IF ((XSAQ1.LT.0.0D0).OR.(XVQT  .LT.0.0D0))
39267      &    WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
39268 **
39269       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
39270       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
39271       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
39272       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
39273 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
39274       XMIST=(PHKT(4,5+IIGLU1)**2-
39275      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
39276      *PHKT(1,5+IIGLU1)**2)
39277       IF(XMIST.GT.0.D0)THEN
39278       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
39279      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
39280      *PHKT(1,5+IIGLU1)**2)
39281       ELSE
39282 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
39283         PHKT(5,5+IIGLU1)=0.D0
39284       ENDIF
39285       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
39286       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
39287       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
39288       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
39289       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
39290       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
39291       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
39292       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
39293       IDHKT(6+IIGLU1)   =88888
39294 C     IDHKT(6)   =1000*NNNC1+MMMC1
39295       ISTHKT(6+IIGLU1)  =93
39296 C     ISTHKT(6)  =KKKC1
39297       JMOHKT(1,6+IIGLU1)=4+IIGLU1
39298       JMOHKT(2,6+IIGLU1)=5+IIGLU1
39299       JDAHKT(1,6+IIGLU1)=0
39300       JDAHKT(2,6+IIGLU1)=0
39301       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
39302       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
39303       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
39304       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
39305       PHKT(5,6+IIGLU1)
39306      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
39307      *            -PHKT(3,6+IIGLU1)**2)
39308       CHAMAL=CHAM1
39309       IF(IPIP.EQ.1)THEN
39310         IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
39311       ELSEIF(IPIP.EQ.2)THEN
39312         IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
39313       ENDIF
39314       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
39315         IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
39316 C                    we drop chain 6 and give the energy to chain 3
39317           IDHKT(6+IIGLU1)=33888
39318           XGIVE=1.D0
39319 C         WRITE(6,*)' drop chain 6 xgive=1'
39320           GO TO 7788
39321         ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
39322 C                    we drop chain 6 and give the energy to chain 3
39323 C                    and change KK11 to IDHKT(4)
39324           IDHKT(6+IIGLU1)=33888
39325           XGIVE=1.D0
39326 C         WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
39327           KK11=IDHKT(4+IIGLU1)
39328           GO TO 7788
39329         ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
39330 C                    we drop chain 6 and give the energy to chain 3
39331 C                    and change KK21 to IDHKT(4)
39332 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
39333           IDHKT(6+IIGLU1)=33888
39334           XGIVE=1.D0
39335 C         WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
39336           KK21=IDHKT(4+IIGLU1)
39337           GO TO 7788
39338         ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
39339 C                    we drop chain 6 and give the energy to chain 3
39340 C                    and change KK22 to IDHKT(4)
39341 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
39342           IDHKT(6+IIGLU1)=33888
39343           XGIVE=1.D0
39344 C         WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
39345           KK22=IDHKT(4+IIGLU1)
39346           GO TO 7788
39347         ENDIF
39348 C       IREJ=1
39349         IPCO=0
39350 C       RETURN
39351 C       WRITE(6,*)' MGSQBS1 jump back from chain 6'
39352         GO TO 3466
39353       ENDIF
39354  7788 CONTINUE
39355       IF(IPIP.GE.3)THEN
39356       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
39357      * JMOHKT(1,4+IIGLU1),
39358      * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
39359      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
39360       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
39361      * JMOHKT(1,5+IIGLU1),
39362      * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
39363      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
39364       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
39365      * JMOHKT(1,6+IIGLU1),
39366      * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
39367      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
39368       ENDIF
39369       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
39370       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
39371       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
39372       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
39373       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
39374       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
39375       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
39376       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
39377 C     IDHKT(1)   =IP11
39378       IDHKT(1)   =KK11
39379       ISTHKT(1)  =921
39380       JMOHKT(1,1)=NC1P
39381       JMOHKT(2,1)=0
39382       JDAHKT(1,1)=3+IIGLU1
39383       JDAHKT(2,1)=0
39384       PHKT(1,1)  =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
39385 C    * +0.5D0*PHKK(1,NC2P)
39386      *+XGIVE*PHKT(1,4+IIGLU1)
39387       PHKT(2,1)  =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
39388 C    * +0.5D0*PHKK(2,NC2P)
39389      *+XGIVE*PHKT(2,4+IIGLU1)
39390       PHKT(3,1)  =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
39391 C    * +0.5D0*PHKK(3,NC2P)
39392      *+XGIVE*PHKT(3,4+IIGLU1)
39393       PHKT(4,1)  =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
39394 C    * +0.5D0*PHKK(4,NC2P)
39395      *+XGIVE*PHKT(4,4+IIGLU1)
39396 C     PHKT(5,1)  =PHKK(5,NC1P)
39397       XMIST  =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
39398      *PHKT(1,1)**2)
39399       IF(XMIST.GE.0.D0)THEN
39400       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
39401      *PHKT(1,1)**2)
39402       ELSE
39403 C      WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
39404        PHKT(5,1)=0.D0
39405       ENDIF
39406       VHKT(1,1)  =VHKK(1,NC1P)
39407       VHKT(2,1)  =VHKK(2,NC1P)
39408       VHKT(3,1)  =VHKK(3,NC1P)
39409       VHKT(4,1)  =VHKK(4,NC1P)
39410       WHKT(1,1)  =WHKK(1,NC1P)
39411       WHKT(2,1)  =WHKK(2,NC1P)
39412       WHKT(3,1)  =WHKK(3,NC1P)
39413       WHKT(4,1)  =WHKK(4,NC1P)
39414 C     Add here IIGLU1 gluons to this chaina
39415       PG1=0.D0
39416       PG2=0.D0
39417       PG3=0.D0
39418       PG4=0.D0
39419       IF(IIGLU1.GE.1)THEN
39420       JJG=NC1P
39421       DO 61 IIG=2,2+IIGLU1-1
39422         KKG=JJG+IIG-1
39423         IDHKT(IIG)   =IDHKK(KKG)
39424         ISTHKT(IIG)  =921
39425         JMOHKT(1,IIG)=KKG
39426         JMOHKT(2,IIG)=0
39427         JDAHKT(1,IIG)=3+IIGLU1
39428         JDAHKT(2,IIG)=0
39429         PHKT(1,IIG)=PHKK(1,KKG)
39430         PG1=PG1+ PHKT(1,IIG)
39431         PHKT(2,IIG)=PHKK(2,KKG)
39432         PG2=PG2+ PHKT(2,IIG)
39433         PHKT(3,IIG)=PHKK(3,KKG)
39434         PG3=PG3+ PHKT(3,IIG)
39435         PHKT(4,IIG)=PHKK(4,KKG)
39436         PG4=PG4+ PHKT(4,IIG)
39437         PHKT(5,IIG)=PHKK(5,KKG)
39438         VHKT(1,IIG)  =VHKK(1,KKG)
39439         VHKT(2,IIG)  =VHKK(2,KKG)
39440         VHKT(3,IIG)  =VHKK(3,KKG)
39441         VHKT(4,IIG)  =VHKK(4,KKG)
39442         WHKT(1,IIG)  =WHKK(1,KKG)
39443         WHKT(2,IIG)  =WHKK(2,KKG)
39444         WHKT(3,IIG)  =WHKK(3,KKG)
39445         WHKT(4,IIG)  =WHKK(4,KKG)
39446    61 CONTINUE
39447       ENDIF
39448 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
39449       IF(IPIP.EQ.1)THEN
39450         IDHKT(2+IIGLU1)   =1000*KK21+100*KK22+3
39451         IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103
39452         IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103
39453         IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203
39454       ELSEIF(IPIP.EQ.2)THEN
39455         IDHKT(2+IIGLU1)   =1000*KK21+100*KK22-3
39456         IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103
39457         IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103
39458         IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203
39459       ENDIF
39460       ISTHKT(2+IIGLU1)  =922
39461       JMOHKT(1,2+IIGLU1)=NC2T
39462       JMOHKT(2,2+IIGLU1)=0
39463       JDAHKT(1,2+IIGLU1)=3+IIGLU1
39464       JDAHKT(2,2+IIGLU1)=0
39465       PHKT(1,2+IIGLU1)  =PHKK(1,NC2T)
39466      *+XGIVE*PHKT(1,5+IIGLU1)
39467       PHKT(2,2+IIGLU1)  =PHKK(2,NC2T)
39468      *+XGIVE*PHKT(2,5+IIGLU1)
39469       PHKT(3,2+IIGLU1)  =PHKK(3,NC2T)
39470      *+XGIVE*PHKT(3,5+IIGLU1)
39471       PHKT(4,2+IIGLU1)  =PHKK(4,NC2T)
39472      *+XGIVE*PHKT(4,5+IIGLU1)
39473 C     PHKT(5,2)  =PHKK(5,NC2T)
39474       XMIST=(PHKT(4,2+IIGLU1)**2-
39475      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
39476      *PHKT(1,2+IIGLU1)**2)
39477       IF(XMIST.GT.0.D0)THEN
39478       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
39479      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
39480      *PHKT(1,2+IIGLU1)**2)
39481       ELSE
39482 C     WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
39483       PHKT(5,2+IIGLU1)=0.D0
39484       ENDIF
39485       VHKT(1,2+IIGLU1)  =VHKK(1,NC2T)
39486       VHKT(2,2+IIGLU1)  =VHKK(2,NC2T)
39487       VHKT(3,2+IIGLU1)  =VHKK(3,NC2T)
39488       VHKT(4,2+IIGLU1)  =VHKK(4,NC2T)
39489       WHKT(1,2+IIGLU1)  =WHKK(1,NC2T)
39490       WHKT(2,2+IIGLU1)  =WHKK(2,NC2T)
39491       WHKT(3,2+IIGLU1)  =WHKK(3,NC2T)
39492       WHKT(4,2+IIGLU1)  =WHKK(4,NC2T)
39493       IDHKT(3+IIGLU1)   =88888
39494 C     IDHKT(3)   =1000*NNNC1+MMMC1+10
39495       ISTHKT(3+IIGLU1)  =93
39496 C     ISTHKT(3)  =KKKC1
39497       JMOHKT(1,3+IIGLU1)=1
39498       JMOHKT(2,3+IIGLU1)=2+IIGLU1
39499       JDAHKT(1,3+IIGLU1)=0
39500       JDAHKT(2,3+IIGLU1)=0
39501       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
39502       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
39503       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
39504       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
39505       PHKT(5,3+IIGLU1)
39506      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
39507      *            -PHKT(3,3+IIGLU1)**2)
39508       IF(IPIP.GE.3)THEN
39509       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
39510      * JDAHKT(1,1),
39511      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
39512       DO 71 IIG=2,2+IIGLU1-1
39513       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
39514      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
39515      * JDAHKT(1,IIG),
39516      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
39517    71 CONTINUE
39518       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
39519      &             IDHKT(2),JMOHKT(1,2+IIGLU1),
39520      * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
39521      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
39522       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
39523      * JMOHKT(1,3+IIGLU1),
39524      * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
39525      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
39526       ENDIF
39527       CHAMAL=CHAB1
39528 **NEW
39529 C     IF(IPIP.EQ.1)THEN
39530 C       IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
39531 C     ELSEIF(IPIP.EQ.2)THEN
39532 C       IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
39533 C     ENDIF
39534       IF(IPIP.EQ.1)THEN
39535         IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
39536       ELSEIF(IPIP.EQ.2)THEN
39537         IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
39538       ENDIF
39539 **
39540       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
39541 C       IREJ=1
39542         IPCO=0
39543 C       RETURN
39544 C       WRITE(6,*)' MGSQBS1 jump back from chain 3'
39545         GO TO 3466
39546       ENDIF
39547       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
39548       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
39549       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
39550       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
39551       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
39552       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
39553       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
39554       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
39555       IF(IPIP.EQ.1)THEN
39556         IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ1+3
39557         IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
39558         IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
39559         IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
39560       ELSEIF(IPIP.EQ.2)THEN
39561         IDHKT(7+IIGLU1)   =1000*IPP1+100*(-ISQ1+6)-3
39562         IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
39563         IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
39564         IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
39565 C       WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
39566       ENDIF
39567       ISTHKT(7+IIGLU1)  =921
39568       JMOHKT(1,7+IIGLU1)=NC2P
39569       JMOHKT(2,7+IIGLU1)=0
39570       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
39571       JDAHKT(2,7+IIGLU1)=0
39572 C     PHKT(1,7)  =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
39573 C     PHKT(2,7)  =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
39574 C     PHKT(3,7)  =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
39575 C     PHKT(4,7+IIGLU1)  =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
39576 **NEW
39577       IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
39578      &    WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
39579 **
39580       PHKT(1,7+IIGLU1)  =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
39581       PHKT(2,7+IIGLU1)  =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
39582       PHKT(3,7+IIGLU1)  =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
39583       PHKT(4,7+IIGLU1)  =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
39584 C     WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
39585 C    * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
39586       IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
39587 C       IREJ=1
39588 C       WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
39589         IPCO=0
39590 C       RETURN
39591         GO TO 3466
39592       ENDIF
39593 C     PHKT(5,7)  =PHKK(5,NC2P)
39594       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
39595      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
39596      *PHKT(1,7+IIGLU1)**2)
39597       VHKT(1,7+IIGLU1)  =VHKK(1,NC2P)
39598       VHKT(2,7+IIGLU1)  =VHKK(2,NC2P)
39599       VHKT(3,7+IIGLU1)  =VHKK(3,NC2P)
39600       VHKT(4,7+IIGLU1)  =VHKK(4,NC2P)
39601       WHKT(1,7+IIGLU1)  =WHKK(1,NC2P)
39602       WHKT(2,7+IIGLU1)  =WHKK(2,NC2P)
39603       WHKT(3,7+IIGLU1)  =WHKK(3,NC2P)
39604       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
39605 C     Insert here the IIGLU2 gluons
39606       PG1=0.D0
39607       PG2=0.D0
39608       PG3=0.D0
39609       PG4=0.D0
39610       IF(IIGLU2.GE.1)THEN
39611       JJG=NC2P
39612       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
39613         KKG=JJG+IIG-7-IIGLU1
39614         IDHKT(IIG)   =IDHKK(KKG)
39615         ISTHKT(IIG)  =921
39616         JMOHKT(1,IIG)=KKG
39617         JMOHKT(2,IIG)=0
39618         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
39619         JDAHKT(2,IIG)=0
39620         PHKT(1,IIG)=PHKK(1,KKG)
39621         PG1=PG1+ PHKT(1,IIG)
39622         PHKT(2,IIG)=PHKK(2,KKG)
39623         PG2=PG2+ PHKT(2,IIG)
39624         PHKT(3,IIG)=PHKK(3,KKG)
39625         PG3=PG3+ PHKT(3,IIG)
39626         PHKT(4,IIG)=PHKK(4,KKG)
39627         PG4=PG4+ PHKT(4,IIG)
39628         PHKT(5,IIG)=PHKK(5,KKG)
39629         VHKT(1,IIG)  =VHKK(1,KKG)
39630         VHKT(2,IIG)  =VHKK(2,KKG)
39631         VHKT(3,IIG)  =VHKK(3,KKG)
39632         VHKT(4,IIG)  =VHKK(4,KKG)
39633         WHKT(1,IIG)  =WHKK(1,KKG)
39634         WHKT(2,IIG)  =WHKK(2,KKG)
39635         WHKT(3,IIG)  =WHKK(3,KKG)
39636         WHKT(4,IIG)  =WHKK(4,KKG)
39637    81 CONTINUE
39638       ENDIF
39639       IDHKT(8+IIGLU1+IIGLU2)   =IP2
39640       ISTHKT(8+IIGLU1+IIGLU2)  =922
39641       JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
39642       JMOHKT(2,8+IIGLU1+IIGLU2)=0
39643       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
39644       JDAHKT(2,8+IIGLU1+IIGLU2)=0
39645 **NEW
39646       IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
39647      &    WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
39648 **
39649       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
39650       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
39651       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
39652       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
39653 C     PHKT(5,8+IIGLU1+IIGLU2)  =PHKK(5,NC1T)
39654       XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
39655      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
39656      *PHKT(1,8+IIGLU1+IIGLU2)**2)
39657       IF(XMIST.GT.0.D0)THEN
39658       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
39659      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
39660      *PHKT(1,8+IIGLU1+IIGLU2)**2)
39661       ELSE
39662 C     WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
39663       PHKT(5,8+IIGLU1+IIGLU2)=0.D0
39664       ENDIF
39665       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC1T)
39666       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC1T)
39667       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC1T)
39668       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC1T)
39669       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC1T)
39670       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC1T)
39671       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC1T)
39672       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC1T)
39673       IDHKT(9+IIGLU1+IIGLU2)   =88888
39674 C     IDHKT(9)   =1000*NNNC2+MMMC2+10
39675       ISTHKT(9+IIGLU1+IIGLU2)  =93
39676 C     ISTHKT(9)  =KKKC2
39677       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
39678       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
39679       JDAHKT(1,9+IIGLU1+IIGLU2)=0
39680       JDAHKT(2,9+IIGLU1+IIGLU2)=0
39681       PHKT(1,9+IIGLU1+IIGLU2)  =PHKT(1,7+IIGLU1)
39682      * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
39683       PHKT(2,9+IIGLU1+IIGLU2)  =PHKT(2,7+IIGLU1)
39684      * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
39685       PHKT(3,9+IIGLU1+IIGLU2)  =PHKT(3,7+IIGLU1)
39686      * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
39687       PHKT(4,9+IIGLU1+IIGLU2)  =PHKT(4,7+IIGLU1)
39688      * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
39689       PHKT(5,9+IIGLU1+IIGLU2)
39690      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
39691      * PHKT(2,9+IIGLU1+IIGLU2)**2
39692      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
39693       IF(IPIP.GE.3)THEN
39694       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
39695      * JMOHKT(1,7+IIGLU1),
39696      * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
39697      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
39698       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
39699       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
39700      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
39701      * JDAHKT(1,IIG),
39702      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
39703    91 CONTINUE
39704       WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
39705      * IDHKT(8+IIGLU1+IIGLU2),
39706      * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
39707      * JDAHKT(1,8+IIGLU1+IIGLU2),
39708      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
39709       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
39710      * IDHKT(9+IIGLU1+IIGLU2),
39711      * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
39712      * JDAHKT(1,9+IIGLU1+IIGLU2),
39713      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
39714       ENDIF
39715       CHAMAL=CHAB1
39716       IF(IPIP.EQ.1)THEN
39717         IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
39718       ELSEIF(IPIP.EQ.2)THEN
39719         IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
39720       ENDIF
39721       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
39722 C       IREJ=1
39723         IPCO=0
39724 C       RETURN
39725 C       WRITE(6,*)' MGSQBS1 jump back from chain 9',
39726 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
39727         GO TO 3466
39728       ENDIF
39729       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
39730       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
39731       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
39732       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
39733       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
39734       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
39735       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
39736       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
39737 C
39738       IGCOUN=9+IIGLU1+IIGLU2
39739       IPCO=0
39740        RETURN
39741        END
39742
39743 *$ CREATE HKKHKT.FOR
39744 *COPY HKKHKT
39745 C
39746 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
39747 C
39748       SUBROUTINE HKKHKT(I,J)
39749       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39750       SAVE
39751
39752 * event history
39753       PARAMETER (NMXHKK=200000)
39754       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39755      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39756      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39757 * extended event history
39758       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39759      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39760      &                IHIST(2,NMXHKK)
39761
39762       PARAMETER (NTMHKK= 300)
39763       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39764      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39765      +(4,NTMHKK)
39766 C
39767       ISTHKK(I)  =ISTHKT(J)
39768       IDHKK(I)   =IDHKT(J)
39769 C     IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
39770       IF(IDHKK(I).EQ.88888)THEN
39771 C       JMOHKK(1,I)=I-2
39772 C       JMOHKK(2,I)=I-1
39773         JMOHKK(1,I)=I-(J-JMOHKT(1,J))
39774         JMOHKK(2,I)=I-(J-JMOHKT(2,J))
39775       ELSE
39776         JMOHKK(1,I)=JMOHKT(1,J)
39777         JMOHKK(2,I)=JMOHKT(2,J)
39778       ENDIF
39779       JDAHKK(1,I)=JDAHKT(1,J)
39780       JDAHKK(2,I)=JDAHKT(2,J)
39781 C       IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
39782 C       JDAHKK(1,I)=I+2
39783 C     ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
39784 C       JDAHKK(1,I)=I+1
39785 C     ENDIF
39786       IF(JDAHKT(1,J).GT.0)THEN
39787         JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
39788       ENDIF
39789       PHKK(1,I)  =PHKT(1,J)
39790       PHKK(2,I)  =PHKT(2,J)
39791       PHKK(3,I)  =PHKT(3,J)
39792       PHKK(4,I)  =PHKT(4,J)
39793       PHKK(5,I)  =PHKT(5,J)
39794       VHKK(1,I)  =VHKT(1,J)
39795       VHKK(2,I)  =VHKT(2,J)
39796       VHKK(3,I)  =VHKT(3,J)
39797       VHKK(4,I)  =VHKT(4,J)
39798       WHKK(1,I)  =WHKT(1,J)
39799       WHKK(2,I)  =WHKT(2,J)
39800       WHKK(3,I)  =WHKT(3,J)
39801       WHKK(4,I)  =WHKT(4,J)
39802       RETURN
39803       END
39804
39805 *$ CREATE DT_DBREAK.FOR
39806 *COPY DT_DBREAK
39807 *
39808 *===dbreak=============================================================*
39809 *
39810       SUBROUTINE DT_DBREAK(MODE)
39811
39812 ************************************************************************
39813 * This is the steering subroutine for the different diquark breaking   *
39814 * mechanisms.                                                          *
39815 *                                                                      *
39816 * MODE = 1  breaking of projectile diquark in qq-q chain using         *
39817 *           a sea quark (q-qq chain) of the same projectile            *
39818 *      = 2  breaking of target     diquark in q-qq chain using         *
39819 *           a sea quark (qq-q chain) of the same target                *
39820 *      = 3  breaking of projectile diquark in qq-q chain using         *
39821 *           a sea quark (q-aq chain) of the same projectile            *
39822 *      = 4  breaking of target     diquark in q-qq chain using         *
39823 *           a sea quark (aq-q chain) of the same target                *
39824 *      = 5  breaking of projectile anti-diquark in aqaq-aq chain using *
39825 *           a sea anti-quark (aq-aqaq chain) of the same projectile    *
39826 *      = 6  breaking of target     anti-diquark in aq-aqaq chain using *
39827 *           a sea anti-quark (aqaq-aq chain) of the same target        *
39828 *      = 7  breaking of projectile anti-diquark in aqaq-aq chain using *
39829 *           a sea anti-quark (aq-q chain) of the same projectile       *
39830 *      = 8  breaking of target     anti-diquark in aq-aqaq chain using *
39831 *           a sea anti-quark (q-aq chain) of the same target           *
39832 *                                                                      *
39833 * Original version by J. Ranft.                                        *
39834 * This version dated 17.5.00  is written by S. Roesler.                *
39835 ************************************************************************
39836
39837       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39838       SAVE
39839       PARAMETER ( LINP = 10 ,
39840      &            LOUT = 6 ,
39841      &            LDAT = 9 )
39842
39843 * event history
39844       PARAMETER (NMXHKK=200000)
39845       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39846      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39847      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39848 * extended event history
39849       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39850      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39851      &                IHIST(2,NMXHKK)
39852 * flags for input different options
39853       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
39854       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
39855      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
39856 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
39857       PARAMETER (MAXCHN=10000)
39858       COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
39859 * diquark-breaking mechanism
39860       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
39861 * flags for particle decays
39862       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
39863      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
39864      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
39865
39866 *
39867 * chain identifiers
39868 * ( 1 = q-aq,   2 = aq-q,   3 = q-qq,   4 = qq-q,
39869 *   5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
39870       DIMENSION IDCHN1(8),IDCHN2(8)
39871       DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
39872       DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
39873 *
39874 * parton identifiers
39875 * ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
39876 *   +-51/52 = unitarity-sea, +-61/62 = gluons )
39877       DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
39878       DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
39879      &             31, 31, 31, 31, 31, 31, 31, 31,
39880      &             41, 41, 41, 41, 51, 51, 51, 51/
39881       DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
39882      &             32, 32, 32, 32, 32, 32, 32, 32,
39883      &             42, 42, 42, 42, 52, 52, 52, 52/
39884       DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
39885      &             51, 31, 41, 41, 31, 31, 31, 31,
39886      &              0, 41, 51, 51, 51, 51, 51, 51/
39887       DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
39888      &             32, 52, 42, 42, 32, 32, 32, 32,
39889      &             42,  0, 52, 52, 52, 52, 52, 52/
39890
39891       IF (NCHAIN.LE.0) RETURN
39892       DO 1 I=1,NCHAIN
39893          IDX1 = IDXCHN(1,I)
39894          IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
39895          IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
39896          IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
39897      &       .AND.
39898      &        ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
39899      &                                    (IS1P.EQ.ISP1P(MODE,3)))
39900      &       .AND.
39901      &        ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
39902      &                                    (IS1T.EQ.ISP1T(MODE,3)))
39903      &      ) THEN
39904             DO 2 J=1,NCHAIN
39905                IDX2 = IDXCHN(1,J)
39906                IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
39907                IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
39908                IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
39909      &             .AND.
39910      &              ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
39911      &                                      .OR.(IS2P.EQ.ISP2P(MODE,3)))
39912      &             .AND.
39913      &              ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
39914      &                                      .OR.(IS2T.EQ.ISP2T(MODE,3)))
39915      &            ) THEN
39916 *   find mother nucleons of the diquark to be splitted and of the
39917 *   sea-quark and reject this combination if it is not the same
39918                   IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
39919      &                (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
39920                      IANCES = 1
39921                   ELSE
39922                      IANCES = 2
39923                   ENDIF
39924                   IDXMO1 = JMOHKK(IANCES,IDX1)
39925     4             CONTINUE
39926                   IF ((JMOHKK(1,IDXMO1).NE.0).AND.
39927      &                (JMOHKK(2,IDXMO1).NE.0)) THEN
39928                      IANC = IANCES
39929                   ELSE
39930                      IANC = 1
39931                   ENDIF
39932                   IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
39933                      IDXMO1 = JMOHKK(IANC,IDXMO1)
39934                      GOTO 4
39935                   ENDIF
39936                   IDXMO2 = JMOHKK(IANCES,IDX2)
39937     5             CONTINUE
39938                   IF ((JMOHKK(1,IDXMO2).NE.0).AND.
39939      &                (JMOHKK(2,IDXMO2).NE.0)) THEN
39940                      IANC = IANCES
39941                   ELSE
39942                      IANC = 1
39943                   ENDIF
39944                   IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
39945                      IDXMO2 = JMOHKK(IANC,IDXMO2)
39946                      GOTO 5
39947                   ENDIF
39948                   IF (IDXMO1.NE.IDXMO2) GOTO 2
39949 *   quark content of projectile parton
39950                   IP1   = IDHKK(JMOHKK(1,IDX1))
39951                   IP11  = IP1/1000
39952                   IP12  = (IP1-1000*IP11)/100
39953                   IP2   = IDHKK(JMOHKK(2,IDX1))
39954                   IP21  = IP2/1000
39955                   IP22  = (IP2-1000*IP21)/100
39956 *   quark content of target parton
39957                   IT1  = IDHKK(JMOHKK(1,IDX2))
39958                   IT11 = IT1/1000
39959                   IT12 = (IT1-1000*IT11)/100
39960                   IT2  = IDHKK(JMOHKK(2,IDX2))
39961                   IT21 = IT2/1000
39962                   IT22 = (IT2-1000*IT21)/100
39963 *   split diquark and form new chains
39964                   IF (MODE.EQ.1) THEN
39965                      IF (IT1.EQ.4) GOTO 2
39966                      CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39967      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39968      &                         IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
39969                   ELSEIF (MODE.EQ.2) THEN
39970                      IF (IT2.EQ.4) GOTO 2
39971                      CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39972      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39973      &                         IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
39974                   ELSEIF (MODE.EQ.3) THEN
39975                      IF (IT1.EQ.4) GOTO 2
39976                      CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39977      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39978      &                         IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
39979                   ELSEIF (MODE.EQ.4) THEN
39980                      IF (IT2.EQ.4) GOTO 2
39981                      CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39982      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39983      &                         IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
39984                   ELSEIF (MODE.EQ.5) THEN
39985                      CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39986      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39987      &                         IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
39988                   ELSEIF (MODE.EQ.6) THEN
39989                      CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39990      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39991      &                         IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN)
39992                   ELSEIF (MODE.EQ.7) THEN
39993                      CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39994      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39995      &                         IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
39996                   ELSEIF (MODE.EQ.8) THEN
39997                      CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39998      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39999      &                         IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
40000                   ENDIF
40001                   IF (IREJ.GE.1) THEN
40002                      if ((ipq.lt.0).or.(ipq.ge.4))
40003      &                  write(LOUT,*) 'ipq !!!',ipq,mode
40004                      DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
40005 *   accept or reject new chains corresponding to PDBSEA
40006                   ELSE
40007                      IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
40008                         ACC   = DBRKA(1,MODE)+DBRKA(2,MODE)
40009                         REJ   = DBRKR(1,MODE)+DBRKR(2,MODE)
40010                      ELSEIF (IPQ.EQ.3) THEN
40011                         ACC   = DBRKA(3,MODE)
40012                         REJ   = DBRKR(3,MODE)
40013                      ELSE
40014                         WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
40015                         STOP
40016                      ENDIF
40017                      IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
40018                         DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
40019                         IACC = 1
40020                      ELSE
40021                         DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
40022                         IACC = 0
40023                      ENDIF
40024 *   new chains have been accepted and are now copied into HKKEVT
40025                      IF (IACC.EQ.1) THEN
40026                         IF (LEMCCK) THEN
40027                            CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
40028      &                                    PHKK(3,IDX1),PHKK(4,IDX1),
40029      &                                    1,IDUM1,IDUM2)
40030                            CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
40031      &                                    PHKK(3,IDX2),PHKK(4,IDX2),
40032      &                                    2,IDUM1,IDUM2)
40033                         ENDIF
40034                         IDHKK(IDX1) = 99888
40035                         IDHKK(IDX2) = 99888
40036                         IDXCHN(2,I) = -1
40037                         IDXCHN(2,J) = -1
40038                         DO 3 K=1,IGCOUN
40039                            NHKK = NHKK+1
40040                            CALL HKKHKT(NHKK,K)
40041                            IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
40042                               PX = -PHKK(1,NHKK)
40043                               PY = -PHKK(2,NHKK)
40044                               PZ = -PHKK(3,NHKK)
40045                               PE = -PHKK(4,NHKK)
40046                               CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
40047                            ENDIF
40048     3                   CONTINUE
40049                         IF (LEMCCK) THEN
40050                            CHKLEV = 0.1D0
40051                            CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
40052      &                                                             IREJ)
40053                            IF (IREJ.NE.0) CALL DT_EVTOUT(4)
40054                         ENDIF
40055                         GOTO 1
40056                      ENDIF
40057                   ENDIF
40058                ENDIF
40059     2       CONTINUE
40060          ENDIF
40061     1 CONTINUE
40062       RETURN
40063       END
40064
40065 *$ CREATE DT_CQPAIR.FOR
40066 *COPY DT_CQPAIR
40067 *
40068 *===cqpair=============================================================*
40069 *
40070       SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
40071
40072 ************************************************************************
40073 * This subroutine Creates a Quark-antiquark PAIR from the sea.         *
40074 *                                                                      *
40075 *   XQMAX   maxium energy fraction of quark (input)                    *
40076 *   XAQMAX  maxium energy fraction of antiquark (input)                *
40077 *   XQ      energy fraction of quark (output)                          *
40078 *   XAQ     energy fraction of antiquark (output)                      *
40079 *   IFLV    quark flavour (- antiquark flavor) (output)                *
40080 *                                                                      *
40081 * This version dated 14.5.00  is written by S. Roesler.                *
40082 ************************************************************************
40083
40084       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
40085       SAVE
40086       PARAMETER ( LINP = 10 ,
40087      &            LOUT = 6 ,
40088      &            LDAT = 9 )
40089
40090 * Lorentz-parameters of the current interaction
40091       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
40092      &                UMO,PPCM,EPROJ,PPROJ
40093
40094 *
40095       IREJ = 0
40096       XQ   = 0.0D0
40097       XAQ  = 0.0D0
40098 *
40099 * sample quark flavour
40100 *
40101 *  set seasq here (the one from DTCHAI should be used in the future)
40102       SEASQ = 0.5D0
40103       IFLV  = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
40104 *
40105 * sample energy fractions of sea pair
40106 * we first sample the energy fraction of a gluon and then split the gluon
40107 *
40108 *  maximum energy fraction of the gluon forced via input
40109       XGMAXI = XQMAX+XAQMAX
40110 *  minimum energy fraction of the gluon
40111       XTHR1 = 4.0D0 /UMO**2
40112       XTHR2 = 0.54D0/UMO**1.5D0
40113       XGMIN = MAX(XTHR1,XTHR2)
40114 *  maximum energy fraction of the gluon
40115       XGMAX = 0.3D0
40116       XGMAX = MIN(XGMAXI,XGMAX)
40117       IF (XGMIN.GE.XGMAX) THEN
40118          IREJ = 1
40119          RETURN
40120       ENDIF
40121 *
40122 *  sample energy fraction of the gluon
40123       NLOOP = 0
40124     1 CONTINUE
40125       NLOOP = NLOOP+1
40126       IF (NLOOP.GE.50) THEN
40127          IREJ = 1
40128          RETURN
40129       ENDIF
40130       XGLUON = DT_SAMSQX(XGMIN,XGMAX)
40131       EGLUON = XGLUON*UMO/2.0D0
40132 *
40133 *  split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
40134       ZMIN = MIN(0.1D0,0.5D0/EGLUON)
40135       ZMAX = 1.0D0-ZMIN
40136       RZ   = DT_RNDM(ZMAX)
40137       XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
40138       RQ   = DT_RNDM(ZMAX)
40139       IF (RQ.LT.0.5D0) THEN
40140          XQ  = XGLUON*XHLP
40141          XAQ = XGLUON-XQ
40142       ELSE
40143          XAQ = XGLUON*XHLP
40144          XQ  = XGLUON-XAQ
40145       ENDIF
40146       IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1
40147
40148       RETURN
40149       END