DPMJET/dpmjet3.0-5.f

   1 *$ CREATE DT_INIT.FOR
   2 *COPY DT_INIT
   3 *
   4 *    +-------------------------------------------------------------+
   5 *    |                                                             |
   6 *    |                                                             |
   7 *    |                        DPMJET 3.0                           |
   8 *    |                                                             |
   9 *    |                                                             |
  10 *    |         S. Roesler+), R. Engel#), J. Ranft*)                |
  11 *    |                                                             |
  12 *    |         +) CERN, SC-RP                                      |
  13 *    |            CH-1211 Geneva 23, Switzerland                   |
  14 *    |            Email: Stefan.Roesler@cern.ch                    |
  15 *    |                                                             |
  16 *    |         #) Institut fuer Kernphysik                         |
  17 *    |            Forschungszentrum Karlsruhe                      |
  18 *    |            D-76021 Karlsruhe, Germany                       |
  19 *    |                                                             |
  20 *    |         *) University of Siegen, Dept. of Physics           |
  21 *    |            D-57068 Siegen, Germany                          |
  22 *    |                                                             |
  23 *    |                                                             |
  24 *    |       http://home.cern.ch/sroesler/dpmjet3.html             |
  25 *    |                                                             |
  26 *    |                                                             |
  27 *    |       Monte Carlo models used for event generation:         |
  28 *    |          PHOJET 1.12, JETSET 7.4 and LEPTO 6.5.1            |
  29 *    |                                                             |
  30 *    +-------------------------------------------------------------+
  31 *
  32 *
  33 *===init===============================================================*
  34 *
  35       SUBROUTINE DT_INIT(NCASES,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
  36      &                                             IDP,IGLAU)
  37
  38 ************************************************************************
  39 * Initialization of event generation                                   *
  40 * This version dated  7.4.98  is written by S. Roesler.                *
  41 *                                                                      *
  42 * Last change 27.12.2006 by S. Roesler.                                *
  43 ************************************************************************
  44
  45       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  46       SAVE
  47
  48       PARAMETER ( LINP = 10 ,
  49      &            LOUT = 6 ,
  50      &            LDAT = 9 )
  51       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
  52
  53 * particle properties (BAMJET index convention)
  54       CHARACTER*8  ANAME
  55       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
  56      &                IICH(210),IIBAR(210),K1(210),K2(210)
  57 * names of hadrons used in input-cards
  58       CHARACTER*8 BTYPE
  59       COMMON /DTPAIN/ BTYPE(30)
  60 * (original name: PAREVT)
  61       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
  62      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
  63       PARAMETER ( NALLWP = 39   )
  64       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
  65      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
  66      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
  67      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
  68 * (original name: INPFLG)
  69       COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
  70 * (original name: FRBKCM)
  71       PARAMETER ( MXFFBK =     6 )
  72       PARAMETER ( MXZFBK =     9 )
  73       PARAMETER ( MXNFBK =    10 )
  74       PARAMETER ( MXAFBK =    16 )
  75       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
  76       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
  77       PARAMETER ( NXAFBK = MXAFBK + 1 )
  78       PARAMETER ( MXPSST =   300 )
  79       PARAMETER ( MXPSFB = 41000 )
  80       LOGICAL LFRMBK, LNCMSS
  81       COMMON /FKFRBK/  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
  82      &          EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
  83      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
  84      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
  85      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
  86      &          IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
  87      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
  88      &          IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
  89      &          IFBFRB, NBUFBK, LFRMBK, LNCMSS
  90       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
  91 * emulsion treatment
  92       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
  93      &                NCOMPO,IEMUL
  94 * Glauber formalism: parameters
  95       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
  96      &                BMAX(NCOMPX),BSTEP(NCOMPX),
  97      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
  98      &                NSITEB,NSTATB
  99 * Glauber formalism: cross sections
 100       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
 101      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
 102      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
 103      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
 104      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
 105      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
 106      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
 107      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
 108      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
 109      &                BSLOPE,NEBINI,NQBINI
 110 * interface HADRIN-DPM
 111       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
 112 * central particle production, impact parameter biasing
 113       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
 114 * parameter for intranuclear cascade
 115       LOGICAL LPAULI
 116       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
 117 * various options for treatment of partons (DTUNUC 1.x)
 118 * (chain recombination, Cronin,..)
 119       LOGICAL LCO2CR,LINTPT
 120       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
 121      &                LCO2CR,LINTPT
 122 * threshold values for x-sampling (DTUNUC 1.x)
 123       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
 124      &                SSMIMQ,VVMTHR
 125 * flags for input different options
 126       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
 127       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
 128      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
 129 * nuclear potential
 130       LOGICAL LFERMI
 131       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
 132      &                EBINDP(2),EBINDN(2),EPOT(2,210),
 133      &                ETACOU(2),ICOUL,LFERMI
 134 * n-n cross section fluctuations
 135       PARAMETER (NBINS = 1000)
 136       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
 137 * flags for particle decays
 138       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
 139      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
 140      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
 141 * diquark-breaking mechanism
 142       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
 143 * nucleon-nucleon event-generator
 144       CHARACTER*8 CMODEL
 145       LOGICAL LPHOIN
 146       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
 147 * properties of interacting particles
 148       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
 149 * properties of photon/lepton projectiles
 150       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
 151 * flags for diffractive interactions (DTUNUC 1.x)
 152       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
 153 * parameters for hA-diffraction
 154       COMMON /DTDIHA/ DIBETA,DIALPH
 155 * Lorentz-parameters of the current interaction
 156       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
 157      &                UMO,PPCM,EPROJ,PPROJ
 158 * kinematical cuts for lepton-nucleus interactions
 159       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
 160      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
 161 * VDM parameter for photon-nucleus interactions
 162       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
 163 * Glauber formalism: flags and parameters for statistics
 164       LOGICAL LPROD
 165       CHARACTER*8 CGLB
 166       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
 167 * cuts for variable energy runs
 168       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
 169 * flags for activated histograms
 170       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
 171       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
 172       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
 173 * LEPTO
 174 **LUND single / double precision
 175       REAL CUT,PARL,TMPX,TMPY,TMPW2,TMPQ2,TMPU
 176       COMMON /LEPTOU/ CUT(14),LST(40),PARL(30),
 177      &                TMPX,TMPY,TMPW2,TMPQ2,TMPU
 178 * LEPTO
 179       REAL RPPN
 180       COMMON /LEPTOI/ RPPN,LEPIN,INTER
 181 * steering flags for qel neutrino scattering modules
 182       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
 183 * event flag
 184       COMMON /DTEVNO/ NEVENT,ICASCA
 185
 186       INTEGER PYCOMP
 187
 188 C     DIMENSION XPARA(5)
 189       DIMENSION XDUMB(40),IPRANG(5)
 190
 191       PARAMETER (MXCARD=58)
 192       CHARACTER*78 CLINE,CTITLE
 193       CHARACTER*60 CWHAT
 194       CHARACTER*8  BLANK,SDUM
 195       CHARACTER*10 CODE,CODEWD
 196       CHARACTER*72 HEADER
 197       LOGICAL LSTART,LEINP,LXSTAB
 198       DIMENSION WHAT(6),CODE(MXCARD)
 199       DATA CODE/
 200      &   'TITLE     ','PROJPAR   ','TARPAR    ','ENERGY    ',
 201      &   'MOMENTUM  ','CMENERGY  ','EMULSION  ','FERMI     ',
 202      &   'TAUFOR    ','PAULI     ','COULOMB   ','HADRIN    ',
 203      &   'EVAP      ','EMCCHECK  ','MODEL     ','PHOINPUT  ',
 204      &   'GLAUBERI  ','FLUCTUAT  ','CENTRAL   ','RECOMBIN  ',
 205      &   'COMBIJET  ','XCUTS     ','INTPT     ','CRONINPT  ',
 206      &   'SEADISTR  ','SEASU3    ','DIQUARKS  ','RESONANC  ',
 207      &   'DIFFRACT  ','SINGLECH  ','NOFRAGME  ','HADRONIZE ',
 208      &   'POPCORN   ','PARDECAY  ','BEAM      ','LUND-MSTU ',
 209      &   'LUND-MSTJ ','LUND-MDCY ','LUND-PARJ ','LUND-PARU ',
 210      &   'OUTLEVEL  ','FRAME     ','L-TAG     ','L-ETAG    ',
 211      &   'ECMS-CUT  ','VDM-PAR1  ','HISTOGRAM ','XS-TABLE  ',
 212      &   'GLAUB-PAR ','GLAUB-INI ','VDM-PAR2  ','XS-QELPRO ',
 213      &   'RNDMINIT  ','LEPTO-CUT ','LEPTO-LST ','LEPTO-PARL',
 214      &   'START     ','STOP      '/
 215       DATA BLANK /'        '/
 216
 217       DATA LSTART,LXSTAB,IFIRST /.TRUE.,.FALSE.,1/
 218       DATA CMEOLD /0.0D0/
 219
 220 *---------------------------------------------------------------------
 221 * at the first call of INIT: initialize event generation
 222       EPNSAV = EPN
 223       IF (LSTART) THEN
 224          CALL DT_TITLE
 225 *   initialization and test of the random number generator
 226          IF (ITRSPT.NE.1) THEN
 227             CALL DT_RNDMST(22,54,76,92)
 228             CALL DT_RNDMTE(1)
 229          ENDIF
 230 *   initialization of BAMJET, DECAY and HADRIN
 231          CALL DT_DDATAR
 232          CALL DT_DHADDE
 233          CALL DT_DCHANT
 234          CALL DT_DCHANH
 235 *   set default values for input variables
 236          CALL DT_DEFAUL(EPN,PPN)
 237          IGLAU  = 0
 238          IXSQEL = 0
 239 *   flag for collision energy input
 240          LEINP  = .FALSE.
 241          LSTART = .FALSE.
 242       ENDIF
 243
 244 *---------------------------------------------------------------------
 245    10 CONTINUE
 246
 247 * bypass reading input cards (e.g. for use with Fluka)
 248 *  in this case Epn is expected to carry the beam momentum
 249       IF (NCASES.EQ.-1) THEN
 250          IP      = NPMASS
 251          IPZ     = NPCHAR
 252          PPN     = EPNSAV
 253          EPN     = ZERO
 254          CMENER  = ZERO
 255          LEINP   = .TRUE.
 256          MKCRON  = 0
 257          WHAT(1) = 1
 258          WHAT(2) = 0
 259          CODEWD  = 'START     '
 260          GOTO 900
 261       ENDIF
 262
 263 * read control card from input-unit LINP
 264       READ(LINP,'(A78)',END=9999) CLINE
 265       IF (CLINE(1:1).EQ.'*') THEN
 266 * comment-line
 267          WRITE(LOUT,'(A78)') CLINE
 268          GOTO 10
 269       ENDIF
 270 C     READ(CLINE,1000,END=9999) CODEWD,(WHAT(I),I=1,6),SDUM
 271 C1000 FORMAT(A10,6E10.0,A8)
 272       DO 1008 I=1,6
 273          WHAT(I) = ZERO
 274  1008 CONTINUE
 275       READ(CLINE,1006,END=9999) CODEWD,CWHAT,SDUM
 276  1006 FORMAT(A10,A60,A8)
 277       READ(CWHAT,*,END=1007) (WHAT(I),I=1,6)
 278  1007 CONTINUE
 279       WRITE(LOUT,1001) CODEWD,(WHAT(I),I=1,6),SDUM
 280  1001 FORMAT(A10,6G10.3,A8)
 281
 282   900 CONTINUE
 283
 284 * check for valid control card and get card index
 285       ICW = 0
 286       DO 11 I=1,MXCARD
 287          IF (CODEWD.EQ.CODE(I)) ICW = I
 288    11 CONTINUE
 289       IF (ICW.EQ.0) THEN
 290          WRITE(LOUT,1002) CODEWD
 291  1002    FORMAT(/,1X,'---> ',A10,': invalid control-card !',/)
 292          GOTO 10
 293       ENDIF
 294
 295       GOTO(
 296 *------------------------------------------------------------
 297 *       TITLE   ,  PROJPAR ,  TARPAR  ,  ENERGY  ,  MOMENTUM,
 298      &  100     ,  110     ,  120     ,  130     ,  140     ,
 299 *
 300 *------------------------------------------------------------
 301 *       CMENERGY,  EMULSION,  FERMI   ,  TAUFOR  ,  PAULI   ,
 302      &  150     ,  160     ,  170     ,  180     ,  190     ,
 303 *
 304 *------------------------------------------------------------
 305 *       COULOMB ,  HADRIN  ,  EVAP    ,  EMCCHECK,  MODEL   ,
 306      &  200     ,  210     ,  220     ,  230     ,  240     ,
 307 *
 308 *------------------------------------------------------------
 309 *       PHOINPUT,  GLAUBERI,  FLUCTUAT,  CENTRAL ,  RECOMBIN,
 310      &  250     ,  260     ,  270     ,  280     ,  290     ,
 311 *
 312 *------------------------------------------------------------
 313 *       COMBIJET,  XCUTS   ,  INTPT   ,  CRONINPT,  SEADISTR,
 314      &  300     ,  310     ,  320     ,  330     ,  340     ,
 315 *
 316 *------------------------------------------------------------
 317 *       SEASU3  ,  DIQUARKS,  RESONANC,  DIFFRACT,  SINGLECH,
 318      &  350     ,  360     ,  370     ,  380     ,  390     ,
 319 *
 320 *------------------------------------------------------------
 321 *       NOFRAGME, HADRONIZE,  POPCORN ,  PARDECAY,  BEAM    ,
 322      &  400     ,  410     ,  420     ,  430     ,  440     ,
 323 *
 324 *------------------------------------------------------------
 325 *      LUND-MSTU, LUND-MSTJ, LUND-MDCY, LUND-PARJ, LUND-PARU,
 326      &  450     ,  451     ,  452     ,  460     ,  470     ,
 327 *
 328 *------------------------------------------------------------
 329 *       OUTLEVEL,  FRAME   , L-TAG    ,  L-ETAG  ,  ECMS-CUT,
 330      &  480     ,  490     ,  500     ,  510     ,  520     ,
 331 *
 332 *------------------------------------------------------------
 333 *       VDM-PAR1, HISTOGRAM, XS-TABLE , GLAUB-PAR, GLAUB-INI,
 334      &  530     ,  540     ,  550     ,  560     ,  565     ,
 335 *
 336 *------------------------------------------------------------
 337 *               ,          ,  VDM-PAR2, XS-QELPRO, RNDMINIT ,
 338      &                        570     ,  580     ,  590     ,
 339 *
 340 *------------------------------------------------------------
 341 *      LEPTO-CUT, LEPTO-LST,LEPTO-PARL,  START   ,  STOP    )
 342      &  600     ,  610     ,  620     ,  630     ,  640     ) , ICW
 343 *
 344 *------------------------------------------------------------
 345
 346       GOTO 10
 347
 348 *********************************************************************
 349 *                                                                   *
 350 *               control card:  codewd = TITLE                       *
 351 *                                                                   *
 352 *       what (1..6), sdum   no meaning                              *
 353 *                                                                   *
 354 *       Note:  The control-card following this must consist of      *
 355 *              a string of characters usually giving the title of   *
 356 *              the run.                                             *
 357 *                                                                   *
 358 *********************************************************************
 359
 360   100 CONTINUE
 361       READ(LINP,'(A78)') CTITLE
 362       WRITE(LOUT,'(//,5X,A78,//)') CTITLE
 363       GOTO 10
 364
 365 *********************************************************************
 366 *                                                                   *
 367 *               control card:  codewd = PROJPAR                     *
 368 *                                                                   *
 369 *       what (1) =  mass number of projectile nucleus  default: 1   *
 370 *       what (2) =  charge of projectile nucleus       default: 1   *
 371 *       what (3..6)   no meaning                                    *
 372 *       sdum        projectile particle code word                   *
 373 *                                                                   *
 374 *       Note: If sdum is defined what (1..2) have no meaning.       *
 375 *                                                                   *
 376 *********************************************************************
 377
 378   110 CONTINUE
 379       IF (SDUM.EQ.BLANK) THEN
 380          IP     = INT(WHAT(1))
 381          IPZ    = INT(WHAT(2))
 382          IJPROJ = 1
 383          IBPROJ = 1
 384       ELSE
 385          IJPROJ = 0
 386          DO 111 II=1,30
 387             IF (SDUM.EQ.BTYPE(II)) THEN
 388                IP     = 1
 389                IPZ    = 1
 390                IF (II.EQ.26) THEN
 391                   IJPROJ = 135
 392                ELSEIF (II.EQ.27) THEN
 393                   IJPROJ = 136
 394                ELSEIF (II.EQ.28) THEN
 395                   IJPROJ = 133
 396                ELSEIF (II.EQ.29) THEN
 397                   IJPROJ = 134
 398                ELSE
 399                   IJPROJ = II
 400                ENDIF
 401                IBPROJ = IIBAR(IJPROJ)
 402 * photon
 403                IF ((IJPROJ.EQ.7).AND.(WHAT(1).GT.ZERO)) VIRT = WHAT(1)
 404 * lepton
 405                IF (((IJPROJ.EQ. 3).OR.(IJPROJ.EQ. 4).OR.
 406      &              (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11)).AND.
 407      &                              (WHAT(1).GT.ZERO)) Q2HI = WHAT(1)
 408             ENDIF
 409   111    CONTINUE
 410          IF (IJPROJ.EQ.0) THEN
 411             WRITE(LOUT,1110)
 412  1110       FORMAT(/,1X,'invalid PROJPAR card !',/)
 413             GOTO 9999
 414          ENDIF
 415       ENDIF
 416       GOTO 10
 417
 418 *********************************************************************
 419 *                                                                   *
 420 *               control card:  codewd = TARPAR                      *
 421 *                                                                   *
 422 *       what (1) =  mass number of target nucleus      default: 1   *
 423 *       what (2) =  charge of target nucleus           default: 1   *
 424 *       what (3..6)   no meaning                                    *
 425 *       sdum        target particle code word                       *
 426 *                                                                   *
 427 *       Note: If sdum is defined what (1..2) have no meaning.       *
 428 *                                                                   *
 429 *********************************************************************
 430
 431   120 CONTINUE
 432       IF (SDUM.EQ.BLANK) THEN
 433          IT     = INT(WHAT(1))
 434          ITZ    = INT(WHAT(2))
 435          IJTARG = 1
 436          IBTARG = 1
 437       ELSE
 438          IJTARG = 0
 439          DO 121 II=1,30
 440             IF (SDUM.EQ.BTYPE(II)) THEN
 441                IT     = 1
 442                ITZ    = 1
 443                IJTARG = II
 444                IBTARG = IIBAR(IJTARG)
 445             ENDIF
 446   121    CONTINUE
 447          IF (IJTARG.EQ.0) THEN
 448             WRITE(LOUT,1120)
 449  1120       FORMAT(/,1X,'invalid TARPAR card !',/)
 450             GOTO 9999
 451          ENDIF
 452       ENDIF
 453       GOTO 10
 454
 455 *********************************************************************
 456 *                                                                   *
 457 *               control card:  codewd = ENERGY                      *
 458 *                                                                   *
 459 *       what (1) =  energy (GeV) of projectile in Lab.              *
 460 *                   if what(1) < 0:  |what(1)| = kinetic energy     *
 461 *                                                default: 200 GeV   *
 462 *                   if |what(2)| > 0: min. energy for variable      *
 463 *                                     energy runs                   *
 464 *       what (2) =  max. energy for variable energy runs            *
 465 *                   if what(2) < 0:  |what(2)| = kinetic energy     *
 466 *                                                                   *
 467 *********************************************************************
 468
 469   130 CONTINUE
 470       EPN    = WHAT(1)
 471       PPN    = ZERO
 472       CMENER = ZERO
 473       IF ((ABS(WHAT(2)).GT.ZERO).AND.
 474      &    (ABS(WHAT(2)).GT.ABS(WHAT(1)))) THEN
 475          VARELO = WHAT(1)
 476          VAREHI = WHAT(2)
 477          EPN    = VAREHI
 478       ENDIF
 479       LEINP  = .TRUE.
 480       GOTO 10
 481
 482 *********************************************************************
 483 *                                                                   *
 484 *               control card:  codewd = MOMENTUM                    *
 485 *                                                                   *
 486 *       what (1) =  momentum (GeV/c) of projectile in Lab.          *
 487 *                                                default: 200 GeV/c *
 488 *       what (2..6), sdum   no meaning                              *
 489 *                                                                   *
 490 *********************************************************************
 491
 492   140 CONTINUE
 493       EPN    = ZERO
 494       PPN    = WHAT(1)
 495       CMENER = ZERO
 496       LEINP  = .TRUE.
 497       GOTO 10
 498
 499 *********************************************************************
 500 *                                                                   *
 501 *               control card:  codewd = CMENERGY                    *
 502 *                                                                   *
 503 *       what (1) =  energy in nucleon-nucleon cms.                  *
 504 *                                                default: none      *
 505 *       what (2..6), sdum   no meaning                              *
 506 *                                                                   *
 507 *********************************************************************
 508
 509   150 CONTINUE
 510       EPN    = ZERO
 511       PPN    = ZERO
 512       CMENER = WHAT(1)
 513       LEINP  = .TRUE.
 514       GOTO 10
 515
 516 *********************************************************************
 517 *                                                                   *
 518 *               control card:  codewd = EMULSION                    *
 519 *                                                                   *
 520 *               definition of nuclear emulsions                     *
 521 *                                                                   *
 522 *     what(1)      mass number of emulsion component                *
 523 *     what(2)      charge of emulsion component                     *
 524 *     what(3)      fraction of events in which a scattering on a    *
 525 *                  nucleus of this properties is performed          *
 526 *     what(4,5,6)  as what(1,2,3) but for another component         *
 527 *                                             default: no emulsion  *
 528 *     sdum         no meaning                                       *
 529 *                                                                   *
 530 *     Note: If this input-card is once used with valid parameters   *
 531 *           TARPAR is obsolete.                                     *
 532 *           Not the absolute values of the fractions are important  *
 533 *           but only the ratios of fractions of different comp.     *
 534 *           This control card can be repeatedly used to define      *
 535 *           emulsions consisting of up to 10 elements.              *
 536 *                                                                   *
 537 *********************************************************************
 538
 539   160 CONTINUE
 540       IF ((WHAT(1).GT.ZERO).AND.(WHAT(2).GT.ZERO)
 541      &                     .AND.(ABS(WHAT(3)).GT.ZERO)) THEN
 542          NCOMPO = NCOMPO+1
 543          IF (NCOMPO.GT.NCOMPX) THEN
 544             WRITE(LOUT,1600)
 545             STOP
 546          ENDIF
 547          IEMUMA(NCOMPO) = INT(WHAT(1))
 548          IEMUCH(NCOMPO) = INT(WHAT(2))
 549          EMUFRA(NCOMPO) = WHAT(3)
 550          IEMUL = 1
 551 C        CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
 552       ENDIF
 553       IF ((WHAT(4).GT.ZERO).AND.(WHAT(5).GT.ZERO)
 554      &                     .AND.(ABS(WHAT(6)).GT.ZERO)) THEN
 555          NCOMPO = NCOMPO+1
 556          IF (NCOMPO.GT.NCOMPX) THEN
 557             WRITE(LOUT,1001)
 558             STOP
 559          ENDIF
 560          IEMUMA(NCOMPO) = INT(WHAT(4))
 561          IEMUCH(NCOMPO) = INT(WHAT(5))
 562          EMUFRA(NCOMPO) = WHAT(6)
 563 C        CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
 564       ENDIF
 565  1600 FORMAT(1X,'too many emulsion components - program stopped')
 566       GOTO 10
 567
 568 *********************************************************************
 569 *                                                                   *
 570 *               control card:  codewd = FERMI                       *
 571 *                                                                   *
 572 *       what (1) = -1 Fermi-motion of nucleons not treated          *
 573 *                                                 default: 1        *
 574 *       what (2) =    scale factor for Fermi-momentum               *
 575 *                                                 default: 0.75     *
 576 *       what (3..6), sdum   no meaning                              *
 577 *                                                                   *
 578 *********************************************************************
 579
 580   170 CONTINUE
 581       IF (WHAT(1).EQ.-1.0D0) THEN
 582          LFERMI = .FALSE.
 583       ELSE
 584          LFERMI = .TRUE.
 585       ENDIF
 586       XMOD = WHAT(2)
 587       IF (XMOD.GE.ZERO) FERMOD = XMOD
 588       GOTO 10
 589
 590 *********************************************************************
 591 *                                                                   *
 592 *               control card:  codewd = TAUFOR                      *
 593 *                                                                   *
 594 *          formation time supressed intranuclear cascade            *
 595 *                                                                   *
 596 *    what (1)      formation time (in fm/c)                         *
 597 *                  note: what(1)=10. corresponds roughly to an      *
 598 *                        average formation time of 1 fm/c           *
 599 *                                                 default: 5. fm/c  *
 600 *    what (2)      number of generations followed                   *
 601 *                                                 default: 25       *
 602 *    what (3) = 1. p_t-dependent formation zone                     *
 603 *             = 2. constant formation zone                          *
 604 *                                                 default: 1        *
 605 *    what (4)      modus of selection of nucleus where the          *
 606 *                  cascade if followed first                        *
 607 *             = 1.  proj./target-nucleus with probab. 1/2           *
 608 *             = 2.  nucleus with highest mass                       *
 609 *             = 3.  proj. nucleus if particle is moving in pos. z   *
 610 *                   targ. nucleus if particle is moving in neg. z   *
 611 *                                                 default: 1        *
 612 *    what (5..6), sdum   no meaning                                 *
 613 *                                                                   *
 614 *********************************************************************
 615
 616   180 CONTINUE
 617       TAUFOR = WHAT(1)
 618       KTAUGE = INT(WHAT(2))
 619       INCMOD = 1
 620       IF ((WHAT(3).GE.1.0D0).AND.(WHAT(3).LE.2.0D0))
 621      &                                    ITAUVE = INT(WHAT(3))
 622       IF ((WHAT(4).GE.1.0D0).AND.(WHAT(4).LE.3.0D0))
 623      &                                    INCMOD = INT(WHAT(4))
 624       GOTO 10
 625
 626 *********************************************************************
 627 *                                                                   *
 628 *               control card:  codewd = PAULI                       *
 629 *                                                                   *
 630 *       what (1) =  -1  Pauli's principle for secondary             *
 631 *                       interactions not treated                    *
 632 *                                                    default: 1     *
 633 *       what (2..6), sdum   no meaning                              *
 634 *                                                                   *
 635 *********************************************************************
 636
 637   190 CONTINUE
 638       IF (WHAT(1).EQ.-1.0D0) THEN
 639          LPAULI = .FALSE.
 640       ELSE
 641          LPAULI = .TRUE.
 642       ENDIF
 643       GOTO 10
 644
 645 *********************************************************************
 646 *                                                                   *
 647 *               control card:  codewd = COULOMB                     *
 648 *                                                                   *
 649 *       what (1) = -1. Coulomb-energy treatment switched off        *
 650 *                                                    default: 1     *
 651 *       what (2..6), sdum   no meaning                              *
 652 *                                                                   *
 653 *********************************************************************
 654
 655   200 CONTINUE
 656       ICOUL = 1
 657       IF (WHAT(1).EQ.-1.0D0) THEN
 658          ICOUL = 0
 659       ELSE
 660          ICOUL = 1
 661       ENDIF
 662       GOTO 10
 663
 664 *********************************************************************
 665 *                                                                   *
 666 *               control card:  codewd = HADRIN                      *
 667 *                                                                   *
 668 *                       HADRIN module                               *
 669 *                                                                   *
 670 *    what (1) = 0. elastic/inelastic interactions with probab.      *
 671 *                  as defined by cross-sections                     *
 672 *             = 1. inelastic interactions forced                    *
 673 *             = 2. elastic interactions forced                      *
 674 *                                                 default: 1        *
 675 *    what (2)      upper threshold in total energy (GeV) below      *
 676 *                  which interactions are sampled by HADRIN         *
 677 *                                                 default: 5. GeV   *
 678 *    what (3..6), sdum   no meaning                                 *
 679 *                                                                   *
 680 *********************************************************************
 681
 682   210 CONTINUE
 683       IWHAT = INT(WHAT(1))
 684       IF ((IWHAT.GE.0).AND.(IWHAT.LE.2)) INTHAD = IWHAT
 685       IF ((WHAT(2).GT.ZERO).AND.(WHAT(2).LT.15.0D0)) EHADTH = WHAT(2)
 686       GOTO 10
 687
 688 *********************************************************************
 689 *                                                                   *
 690 *               control card:  codewd = EVAP                        *
 691 *                                                                   *
 692 *                    evaporation module                             *
 693 *                                                                   *
 694 *  what (1) =< -1 ==> evaporation is switched off                   *
 695 *           >=  1 ==> evaporation is performed                      *
 696 *                                                                   *
 697 *         what (1) = i1 + i2*10 + i3*100 + i4*10000                 *
 698 *                    (i1, i2, i3, i4 >= 0 )                         *
 699 *                                                                   *
 700 *   i1 is the flag for selecting the T=0 level density option used  *
 701 *      =  1: standard EVAP level densities with Cook pairing        *
 702 *            energies                                               *
 703 *      =  2: Z,N-dependent Gilbert & Cameron level densities        *
 704 *                                                        (default)  *
 705 *      =  3: Julich A-dependent level densities                     *
 706 *      =  4: Z,N-dependent Brancazio & Cameron level densities      *
 707 *                                                                   *
 708 *   i2 >= 1: high energy fission activated                          *
 709 *            (default high energy fission activated)                *
 710 *                                                                   *
 711 *   i3 =  0: No energy dependence for level densities               *
 712 *      =  1: Standard Ignyatuk (1975, 1st) energy dependence        *
 713 *            for level densities (default)                          *
 714 *      =  2: Standard Ignyatuk (1975, 1st) energy dependence        *
 715 *            for level densities with NOT used set of parameters    *
 716 *      =  3: Standard Ignyatuk (1975, 1st) energy dependence        *
 717 *            for level densities with NOT used set of parameters    *
 718 *      =  4: Second   Ignyatuk (1975, 2nd) energy dependence        *
 719 *            for level densities                                    *
 720 *      =  5: Second   Ignyatuk (1975, 2nd) energy dependence        *
 721 *            for level densities with fit 1 Iljinov & Mebel set of  *
 722 *            parameters                                             *
 723 *      =  6: Second   Ignyatuk (1975, 2nd) energy dependence        *
 724 *            for level densities with fit 2 Iljinov & Mebel set of  *
 725 *            parameters                                             *
 726 *      =  7: Second   Ignyatuk (1975, 2nd) energy dependence        *
 727 *            for level densities with fit 3 Iljinov & Mebel set of  *
 728 *            parameters                                             *
 729 *      =  8: Second   Ignyatuk (1975, 2nd) energy dependence        *
 730 *            for level densities with fit 4 Iljinov & Mebel set of  *
 731 *            parameters                                             *
 732 *                                                                   *
 733 *   i4 >= 1: Original Gilbert and Cameron pairing energies used     *
 734 *            (default Cook's modified pairing energies)             *
 735 *                                                                   *
 736 *  what (2) = ig + 10 * if   (ig and if must have the same sign)    *
 737 *                                                                   *
 738 *   ig =< -1 ==> deexcitation gammas are not produced               *
 739 *                (if the evaporation step is not performed          *
 740 *                 they are never produced)                          *
 741 *   if =< -1 ==> Fermi Break Up is not invoked                      *
 742 *                (if the evaporation step is not performed          *
 743 *                 it is never invoked)                              *
 744 *   The default is: deexcitation gamma produced and Fermi break up  *
 745 *                   activated for the new  preequilibrium, not      *
 746 *                   activated otherwise.                            *
 747 *  what (3..6), sdum   no meaning                                   *
 748 *                                                                   *
 749 *********************************************************************
 750
 751  220  CONTINUE
 752       WRITE(LOUT,1009)
 753  1009 FORMAT(1X,/,'Warning!  Evaporation request rejected since',
 754      &       ' evaporation modules not available with this version.')
 755       LEVPRT = .FALSE.
 756       LDEEXG = .FALSE.
 757       LHEAVY = .FALSE.
 758       LFRMBK = .FALSE.
 759       IFISS  = 0
 760       IEVFSS = 0
 761
 762       GOTO 10
 763
 764 *********************************************************************
 765 *                                                                   *
 766 *               control card:  codewd = EMCCHECK                    *
 767 *                                                                   *
 768 *    extended energy-momentum / quantum-number conservation check   *
 769 *                                                                   *
 770 *       what (1) = -1   extended check not performed                *
 771 *                                                    default: 1.    *
 772 *       what (2..6), sdum   no meaning                              *
 773 *                                                                   *
 774 *********************************************************************
 775
 776   230 CONTINUE
 777       IF (WHAT(1).EQ.-1) THEN
 778          LEMCCK = .FALSE.
 779       ELSE
 780          LEMCCK = .TRUE.
 781       ENDIF
 782       GOTO 10
 783
 784 *********************************************************************
 785 *                                                                   *
 786 *               control card:  codewd = MODEL                       *
 787 *                                                                   *
 788 *     Model to be used to treat nucleon-nucleon interactions        *
 789 *                                                                   *
 790 *       sdum = DTUNUC    two-chain model                            *
 791 *            = PHOJET    multiple chains including minijets         *
 792 *            = LEPTO     DIS                                        *
 793 *            = QNEUTRIN  quasi-elastic neutrino scattering          *
 794 *                                                  default: PHOJET  *
 795 *                                                                   *
 796 *       if sdum = LEPTO:                                            *
 797 *       what (1)         (variable INTER)                           *
 798 *                        = 1  gamma exchange                        *
 799 *                        = 2  W+-   exchange                        *
 800 *                        = 3  Z0    exchange                        *
 801 *                        = 4  gamma/Z0 exchange                     *
 802 *                                                                   *
 803 *       if sdum = QNEUTRIN:                                         *
 804 *       what (1)         = 0  elastic scattering on nucleon and     *
 805 *                             tau does not decay (default)          *
 806 *                        = 1  decay of tau into mu..                *
 807 *                        = 2  decay of tau into e..                 *
 808 *                        = 10 CC events on p and n                  *
 809 *                        = 11 NC events on p and n                  *
 810 *                                                                   *
 811 *       what (2..6)      no meaning                                 *
 812 *                                                                   *
 813 *********************************************************************
 814
 815   240 CONTINUE
 816       IF (SDUM.EQ.CMODEL(1)) THEN
 817          MCGENE = 1
 818       ELSEIF (SDUM.EQ.CMODEL(2)) THEN
 819          MCGENE = 2
 820       ELSEIF (SDUM.EQ.CMODEL(3)) THEN
 821          MCGENE = 3
 822          IF ((WHAT(1).GE.1.0D0).AND.(WHAT(1).LE.4.0D0))
 823      &      INTER = INT(WHAT(1))
 824       ELSEIF (SDUM.EQ.CMODEL(4)) THEN
 825          MCGENE = 4
 826          IWHAT  = INT(WHAT(1))
 827          IF ((IWHAT.EQ.1 ).OR.(IWHAT.EQ.2 ).OR.
 828      &       (IWHAT.EQ.10).OR.(IWHAT.EQ.11))
 829      &      NEUDEC = IWHAT
 830       ELSE
 831          STOP ' Unknown model !'
 832       ENDIF
 833       GOTO 10
 834
 835 *********************************************************************
 836 *                                                                   *
 837 *               control card:  codewd = PHOINPUT                    *
 838 *                                                                   *
 839 *       Start of input-section for PHOJET-specific input-cards      *
 840 *       Note:  This section will not be finished before giving      *
 841 *              ENDINPUT-card                                        *
 842 *       what (1..6), sdum   no meaning                              *
 843 *                                                                   *
 844 *********************************************************************
 845
 846   250 CONTINUE
 847       IF (LPHOIN) THEN
 848          CALL PHO_INIT(LINP,LOUT,IREJ1)
 849          IF (IREJ1.NE.0) THEN
 850             WRITE(LOUT,'(1X,A)')'INIT:   reading PHOJET-input failed'
 851             STOP
 852          ENDIF
 853          LPHOIN = .FALSE.
 854       ENDIF
 855       GOTO 10
 856
 857 *********************************************************************
 858 *                                                                   *
 859 *               control card:  codewd = GLAUBERI                    *
 860 *                                                                   *
 861 *        Pre-initialization of impact parameter selection           *
 862 *                                                                   *
 863 *        what (1..6), sdum   no meaning                             *
 864 *                                                                   *
 865 *********************************************************************
 866
 867   260 CONTINUE
 868       IF (IFIRST.NE.99) THEN
 869          CALL DT_RNDMST(12,34,56,78)
 870          CALL DT_RNDMTE(1)
 871          OPEN(40,FILE='outdata0/shm.out',STATUS='UNKNOWN')
 872 C        OPEN(11,FILE='outdata0/shm.dbg',STATUS='UNKNOWN')
 873          IFIRST = 99
 874       ENDIF
 875
 876       IPPN = 8
 877       PLOW = 10.0D0
 878 C     IPPN = 1
 879 C     PLOW = 100.0D0
 880       PHI  = 1.0D5
 881       APLOW = LOG10(PLOW)
 882       APHI  = LOG10(PHI)
 883       ADP   = (APHI-APLOW)/DBLE(IPPN)
 884
 885       IPLOW = 1
 886       IDIP  = 1
 887       IIP   = 5
 888 C     IPLOW = 1
 889 C     IDIP  = 1
 890 C     IIP   = 1
 891       IPRANG(1) = 1
 892       IPRANG(2) = 2
 893       IPRANG(3) = 5
 894       IPRANG(4) = 10
 895       IPRANG(5) = 20
 896
 897       ITLOW = 30
 898       IDIT  = 3
 899       IIT   = 60
 900 C     IDIT  = 10
 901 C     IIT   = 21
 902
 903       DO 473 NCIT=1,IIT
 904          IT   = ITLOW+(NCIT-1)*IDIT
 905 C        IPHI = IT
 906 C        IDIP = 10
 907 C        IIP  = (IPHI-IPLOW)/IDIP
 908 C        IF (IIP.EQ.0) IIP = 1
 909 C        IF (IT.EQ.IPLOW) IIP = 0
 910
 911          DO 472 NCIP=1,IIP
 912             IP = IPRANG(NCIP)
 913 CC           IF (NCIP.LE.IIP) THEN
 914 C               IP = IPLOW+(NCIP-1)*IDIP
 915 CC           ELSE
 916 CC              IP = IT
 917 CC           ENDIF
 918             IF (IP.GT.IT) GOTO 472
 919
 920             DO 471 NCP=1,IPPN+1
 921                APPN = APLOW+DBLE(NCP-1)*ADP
 922                PPN  = 10**APPN
 923
 924                OPEN(12,FILE='outdata0/shm.sta',STATUS='UNKNOWN')
 925                WRITE(12,'(1X,2I5,E15.3)') IP,IT,PPN
 926                CLOSE(12)
 927
 928                XLIM1 = 0.0D0
 929                XLIM2 = 50.0D0
 930                XLIM3 = ZERO
 931                IBIN  = 50
 932                CALL DT_NEWHGR(XDUM,XDUM,XDUM,XDUMB,-1,IHDUM)
 933                CALL DT_NEWHGR(XLIM1,XLIM2,XLIM3,XDUMB,IBIN,IHSHMA)
 934
 935                NEVFIT = 5
 936 C              IF ((IP.GT.10).OR.(IT.GT.10)) THEN
 937 C                 NEVFIT = 5
 938 C              ELSE
 939 C                 NEVFIT = 10
 940 C              ENDIF
 941                SIGAV  = 0.0D0
 942
 943                DO 478 I=1,NEVFIT
 944                   CALL DT_SHMAKI(IP,IDUM1,IT,IDUM1,IJPROJ,PPN,99)
 945                   SIGAV = SIGAV+XSPRO(1,1,1)
 946                   DO 479 J=1,50
 947                      XC = DBLE(J)
 948                      CALL DT_FILHGR(XC,BSITE(1,1,1,J),IHSHMA,I)
 949   479             CONTINUE
 950   478          CONTINUE
 951
 952                CALL DT_EVTHIS(IDUM)
 953                HEADER = ' BSITE'
 954 C              CALL OUTGEN(IHSHMA,0,0,0,0,0,HEADER,0,NEVFIT,ONE,0,1,-1)
 955
 956 C              CALL GENFIT(XPARA)
 957 C              WRITE(40,'(2I4,E11.3,F6.0,5E11.3)')
 958 C    &              IP,IT,PPN,SIGAV/DBLE(NEVFIT),XPARA
 959
 960   471       CONTINUE
 961
 962   472    CONTINUE
 963
 964   473 CONTINUE
 965
 966       STOP
 967
 968 *********************************************************************
 969 *                                                                   *
 970 *               control card:  codewd = FLUCTUAT                    *
 971 *                                                                   *
 972 *           Treatment of cross section fluctuations                 *
 973 *                                                                   *
 974 *       what (1) = 1  treat cross section fluctuations              *
 975 *                                                    default: 0.    *
 976 *       what (1..6), sdum   no meaning                              *
 977 *                                                                   *
 978 *********************************************************************
 979
 980  270  CONTINUE
 981       IFLUCT = 0
 982       IF (WHAT(1).EQ.ONE) THEN
 983          IFLUCT = 1
 984          CALL DT_FLUINI
 985       ENDIF
 986       GOTO 10
 987
 988 *********************************************************************
 989 *                                                                   *
 990 *               control card:  codewd = CENTRAL                     *
 991 *                                                                   *
 992 *       what (1) = 1.  central production forced     default: 0     *
 993 *  if what (1) < 0 and > -100                                       *
 994 *       what (2) = min. impact parameter             default: 0     *
 995 *       what (3) = max. impact parameter             default: b_max *
 996 *  if what (1) < -99                                                *
 997 *       what (2) = fraction of cross section         default: 1     *
 998 *  if what (1) = -1 : evaporation/fzc suppressed                    *
 999 *  if what (1) < -1 : evaporation/fzc allowed                       *
1000 *                                                                   *
1001 *       what (4..6), sdum   no meaning                              *
1002 *                                                                   *
1003 *********************************************************************
1004
1005   280 CONTINUE
1006       ICENTR = INT(WHAT(1))
1007       IF (ICENTR.LT.0) THEN
1008          IF (ICENTR.GT.-100) THEN
1009             BIMIN = WHAT(2)
1010             BIMAX = WHAT(3)
1011          ELSE
1012             XSFRAC = WHAT(2)
1013          ENDIF
1014       ENDIF
1015       GOTO 10
1016
1017 *********************************************************************
1018 *                                                                   *
1019 *               control card:  codewd = RECOMBIN                    *
1020 *                                                                   *
1021 *                     Chain recombination                           *
1022 *        (recombine S-S and V-V chains to V-S chains)               *
1023 *                                                                   *
1024 *       what (1) = -1. recombination switched off    default: 1     *
1025 *       what (2..6), sdum   no meaning                              *
1026 *                                                                   *
1027 *********************************************************************
1028
1029   290 CONTINUE
1030       IRECOM = 1
1031       IF (WHAT(1).EQ.-1.0D0) IRECOM = 0
1032       GOTO 10
1033
1034 *********************************************************************
1035 *                                                                   *
1036 *               control card:  codewd = COMBIJET                    *
1037 *                                                                   *
1038 *               chain fusion (2 q-aq --> qq-aqaq)                   *
1039 *                                                                   *
1040 *       what (1) = 1   fusion treated                               *
1041 *                                                    default: 0.    *
1042 *       what (2)       minimum number of uncombined chains from     *
1043 *                      single projectile or target nucleons         *
1044 *                                                    default: 0.    *
1045 *       what (3..6), sdum   no meaning                              *
1046 *                                                                   *
1047 *********************************************************************
1048
1049   300 CONTINUE
1050       LCO2CR = .FALSE.
1051       IF (INT(WHAT(1)).EQ.1) LCO2CR = .TRUE.
1052       IF (WHAT(2).GE.ZERO) CUTOF = WHAT(2)
1053       GOTO 10
1054
1055 *********************************************************************
1056 *                                                                   *
1057 *               control card:  codewd = XCUTS                       *
1058 *                                                                   *
1059 *                 thresholds for x-sampling                         *
1060 *                                                                   *
1061 *    what (1)    defines lower threshold for val.-q x-value (CVQ)   *
1062 *                                                 default: 1.       *
1063 *    what (2)    defines lower threshold for val.-qq x-value (CDQ)  *
1064 *                                                 default: 2.       *
1065 *    what (3)    defines lower threshold for sea-q x-value (CSEA)   *
1066 *                                                 default: 0.2      *
1067 *    what (4)    sea-q x-values in S-S chains (SSMIMA)              *
1068 *                                                 default: 0.14     *
1069 *    what (5)    not used                                           *
1070 *                                                 default: 2.       *
1071 *    what (6), sdum   no meaning                                    *
1072 *                                                                   *
1073 *    Note: Lower thresholds (what(1..3)) are def. as x_thr=CXXX/ECM *
1074 *                                                                   *
1075 *********************************************************************
1076
1077   310 CONTINUE
1078       IF (WHAT(1).GE.0.5D0) CVQ    = WHAT(1)
1079       IF (WHAT(2).GE.ONE)   CDQ    = WHAT(2)
1080       IF (WHAT(3).GE.0.1D0) CSEA   = WHAT(3)
1081       IF (WHAT(4).GE.ZERO) THEN
1082          SSMIMA = WHAT(4)
1083          SSMIMQ = SSMIMA**2
1084       ENDIF
1085       IF (WHAT(5).GT.2.0D0) VVMTHR = WHAT(5)
1086       GOTO 10
1087
1088 *********************************************************************
1089 *                                                                   *
1090 *               control card:  codewd = INTPT                       *
1091 *                                                                   *
1092 *     what (1) = -1   intrinsic transverse momenta of partons       *
1093 *                     not treated                default: 1         *
1094 *     what (2..6), sdum   no meaning                                *
1095 *                                                                   *
1096 *********************************************************************
1097
1098   320 CONTINUE
1099       IF (WHAT(1).EQ.-1.0D0) THEN
1100          LINTPT = .FALSE.
1101       ELSE
1102          LINTPT = .TRUE.
1103       ENDIF
1104       GOTO 10
1105
1106 *********************************************************************
1107 *                                                                   *
1108 *               control card:  codewd = CRONINPT                    *
1109 *                                                                   *
1110 *    Cronin effect (multiple scattering of partons at chain ends)   *
1111 *                                                                   *
1112 *       what (1) = -1  Cronin effect not treated     default: 1     *
1113 *       what (2) = 0   scattering parameter          default: 0.64  *
1114 *       what (3..6), sdum   no meaning                              *
1115 *                                                                   *
1116 *********************************************************************
1117
1118   330 CONTINUE
1119       IF (WHAT(1).EQ.-1.0D0) THEN
1120          MKCRON = 0
1121       ELSE
1122          MKCRON = 1
1123       ENDIF
1124       CRONCO = WHAT(2)
1125       GOTO 10
1126
1127 *********************************************************************
1128 *                                                                   *
1129 *               control card:  codewd = SEADISTR                    *
1130 *                                                                   *
1131 *     what (1)  (XSEACO)  sea(x) prop. 1/x**what (1)   default: 1.  *
1132 *     what (2)  (UNON)                                 default: 2.  *
1133 *     what (3)  (UNOM)                                 default: 1.5 *
1134 *     what (4)  (UNOSEA)                               default: 5.  *
1135 *                        qdis(x) prop. (1-x)**what (1)  etc.        *
1136 *     what (5..6), sdum   no meaning                                *
1137 *                                                                   *
1138 *********************************************************************
1139
1140   340 CONTINUE
1141       XSEACO = WHAT(1)
1142       XSEACU = 1.05D0-XSEACO
1143       UNON   = WHAT(2)
1144       IF (UNON.LT.0.1D0) UNON = 2.0D0
1145       UNOM   = WHAT(3)
1146       IF (UNOM.LT.0.1D0) UNOM = 1.5D0
1147       UNOSEA = WHAT(4)
1148       IF (UNOSEA.LT.0.1D0) UNOSEA = 5.0D0
1149       GOTO 10
1150
1151 *********************************************************************
1152 *                                                                   *
1153 *               control card:  codewd = SEASU3                      *
1154 *                                                                   *
1155 *          Treatment of strange-quarks at chain ends                *
1156 *                                                                   *
1157 *       what (1)   (SEASQ)  strange-quark supression factor         *
1158 *                  iflav = 1.+rndm*(2.+SEASQ)                       *
1159 *                                                    default: 1.    *
1160 *       what (2..6), sdum   no meaning                              *
1161 *                                                                   *
1162 *********************************************************************
1163
1164   350 CONTINUE
1165       SEASQ = WHAT(1)
1166       GOTO 10
1167
1168 *********************************************************************
1169 *                                                                   *
1170 *               control card:  codewd = DIQUARKS                    *
1171 *                                                                   *
1172 *     what (1) = -1.  sea-diquark/antidiquark-pairs not treated     *
1173 *                                                    default: 1.    *
1174 *     what (2..6), sdum   no meaning                                *
1175 *                                                                   *
1176 *********************************************************************
1177
1178  360  CONTINUE
1179       IF (WHAT(1).EQ.-1.0D0) THEN
1180          LSEADI = .FALSE.
1181       ELSE
1182          LSEADI = .TRUE.
1183       ENDIF
1184       GOTO 10
1185
1186 *********************************************************************
1187 *                                                                   *
1188 *               control card:  codewd = RESONANC                    *
1189 *                                                                   *
1190 *                 treatment of low mass chains                      *
1191 *                                                                   *
1192 *    what (1) = -1 low chain masses are not corrected for resonance *
1193 *                  masses (obsolete for BAMJET-fragmentation)       *
1194 *                                       default: 1.                 *
1195 *    what (2) = -1 massless partons     default: 1. (massive)       *
1196 *                                       default: 1. (massive)       *
1197 *    what (3) = -1 chain-system containing chain of too small       *
1198 *                  mass is rejected (note: this does not fully      *
1199 *                  apply to S-S chains) default: 0.                 *
1200 *    what (4..6), sdum   no meaning                                 *
1201 *                                                                   *
1202 *********************************************************************
1203
1204   370 CONTINUE
1205       IRESCO = 1
1206       IMSHL  = 1
1207       IRESRJ = 0
1208       IF (WHAT(1).EQ.-ONE) IRESCO = 0
1209       IF (WHAT(2).EQ.-ONE) IMSHL  = 0
1210       IF (WHAT(3).EQ.-ONE) IRESRJ = 1
1211       GOTO 10
1212
1213 *********************************************************************
1214 *                                                                   *
1215 *               control card:  codewd = DIFFRACT                    *
1216 *                                                                   *
1217 *                Treatment of diffractive events                    *
1218 *                                                                   *
1219 *     what (1) = (ISINGD) 0  no single diffraction                  *
1220 *                         1  single diffraction included            *
1221 *                       +-2  single diffractive events only         *
1222 *                       +-3  projectile single diffraction only     *
1223 *                       +-4  target single diffraction only         *
1224 *                        -5  double pomeron exchange only           *
1225 *                      (neg. sign applies to PHOJET events)         *
1226 *                                                     default: 0.   *
1227 *                                                                   *
1228 *     what (2) = (IDOUBD) 0  no double diffraction                  *
1229 *                         1  double diffraction included            *
1230 *                         2  double diffractive events only         *
1231 *                                                     default: 0.   *
1232 *     what (3) = 1 projectile diffraction treated (2-channel form.) *
1233 *                                                     default: 0.   *
1234 *     what (4) = alpha-parameter in projectile diffraction          *
1235 *                                                     default: 0.   *
1236 *     what (5..6), sdum   no meaning                                *
1237 *                                                                   *
1238 *********************************************************************
1239
1240   380 CONTINUE
1241       IF (ABS(WHAT(1)).GT.ZERO) ISINGD = INT(WHAT(1))
1242       IF (ABS(WHAT(2)).GT.ZERO) IDOUBD = INT(WHAT(2))
1243       IF ((ISINGD.GT.1).AND.(IDOUBD.GT.1)) THEN
1244          WRITE(LOUT,1380)
1245  1380    FORMAT(1X,'INIT:   inconsistent DIFFRACT - input !',/,
1246      &          11X,'IDOUBD is reset to zero')
1247          IDOUBD = 0
1248       ENDIF
1249       IF (WHAT(3).GT.ZERO) DIBETA = WHAT(3)
1250       IF (WHAT(4).GT.ZERO) DIALPH = WHAT(4)
1251       GOTO 10
1252
1253 *********************************************************************
1254 *                                                                   *
1255 *               control card:  codewd = SINGLECH                    *
1256 *                                                                   *
1257 *       what (1) = 1.  Regge contribution (one chain) included      *
1258 *                                                   default: 0.     *
1259 *       what (2..6), sdum   no meaning                              *
1260 *                                                                   *
1261 *********************************************************************
1262
1263  390  CONTINUE
1264       ISICHA = 0
1265       IF (WHAT(1).EQ.ONE) ISICHA = 1
1266       GOTO 10
1267
1268 *********************************************************************
1269 *                                                                   *
1270 *               control card:  codewd = NOFRAGME                    *
1271 *                                                                   *
1272 *                 biased chain hadronization                        *
1273 *                                                                   *
1274 *       what (1..6) = -1  no of hadronizsation of S-S chains        *
1275 *                   = -2  no of hadronizsation of D-S chains        *
1276 *                   = -3  no of hadronizsation of S-D chains        *
1277 *                   = -4  no of hadronizsation of S-V chains        *
1278 *                   = -5  no of hadronizsation of D-V chains        *
1279 *                   = -6  no of hadronizsation of V-S chains        *
1280 *                   = -7  no of hadronizsation of V-D chains        *
1281 *                   = -8  no of hadronizsation of V-V chains        *
1282 *                   = -9  no of hadronizsation of comb. chains      *
1283 *                                  default:  complete hadronization *
1284 *       sdum   no meaning                                           *
1285 *                                                                   *
1286 *********************************************************************
1287
1288   400 CONTINUE
1289       DO 401 I=1,6
1290          ICHAIN = INT(WHAT(I))
1291          IF ((ICHAIN.LE.-1).AND.(ICHAIN.GE.-9))
1292      &      LHADRO(ABS(ICHAIN)) = .FALSE.
1293   401 CONTINUE
1294       GOTO 10
1295
1296 *********************************************************************
1297 *                                                                   *
1298 *               control card:  codewd = HADRONIZE                   *
1299 *                                                                   *
1300 *           hadronization model and parameter switch                *
1301 *                                                                   *
1302 *       what (1) = 1    hadronization via BAMJET                    *
1303 *                = 2    hadronization via JETSET                    *
1304 *                                                    default: 2     *
1305 *       what (2) = 1..3 parameter set to be used                    *
1306 *                       JETSET: 3 sets available                    *
1307 *                               ( = 3 default JETSET-parameters)    *
1308 *                       BAMJET: 1 set available                     *
1309 *                                                    default: 1     *
1310 *       what (3..6), sdum   no meaning                              *
1311 *                                                                   *
1312 *********************************************************************
1313
1314   410 CONTINUE
1315       IWHAT1 = INT(WHAT(1))
1316       IWHAT2 = INT(WHAT(2))
1317       IF ((IWHAT1.EQ.1).OR.(IWHAT1.EQ.2)) IFRAG(1) = IWHAT1
1318       IF ((IWHAT1.EQ.2).AND.(IWHAT2.GE.1).AND.(IWHAT2.LE.3))
1319      &                                    IFRAG(2) = IWHAT2
1320       GOTO 10
1321
1322 *********************************************************************
1323 *                                                                   *
1324 *               control card:  codewd = POPCORN                     *
1325 *                                                                   *
1326 *  "Popcorn-effect" in fragmentation and diquark breaking diagrams  *
1327 *                                                                   *
1328 *   what (1) = (PDB) frac. of diquark fragmenting directly into     *
1329 *                    baryons (PYTHIA/JETSET fragmentation)          *
1330 *                    (JETSET: = 0. Popcorn mechanism switched off)  *
1331 *                                                    default: 0.5   *
1332 *   what (2) = probability for accepting a diquark breaking         *
1333 *              diagram involving the generation of a u/d quark-     *
1334 *              antiquark pair                        default: 0.0   *
1335 *   what (3) = same a what (2), here for s quark-antiquark pair     *
1336 *                                                    default: 0.0   *
1337 *   what (4..6), sdum   no meaning                                  *
1338 *                                                                   *
1339 *********************************************************************
1340
1341   420 CONTINUE
1342       IF (WHAT(1).GE.0.0D0) PDB = WHAT(1)
1343       IF (WHAT(2).GE.0.0D0) THEN
1344          PDBSEA(1) = WHAT(2)
1345          PDBSEA(2) = WHAT(2)
1346       ENDIF
1347       IF (WHAT(3).GE.0.0D0) PDBSEA(3) = WHAT(3)
1348       DO 421 I=1,8
1349          DBRKA(1,I) = DBRKR(1,I)*PDBSEA(1)/(1.D0-PDBSEA(1))
1350          DBRKA(2,I) = DBRKR(2,I)*PDBSEA(2)/(1.D0-PDBSEA(2))
1351          DBRKA(3,I) = DBRKR(3,I)*PDBSEA(3)/(1.D0-PDBSEA(3))
1352   421 CONTINUE
1353       GOTO 10
1354
1355 *********************************************************************
1356 *                                                                   *
1357 *               control card:  codewd = PARDECAY                    *
1358 *                                                                   *
1359 *      what (1) = 1.  Sigma0/Asigma0 are decaying within JETSET     *
1360 *               = 2.  pion^0 decay after intranucl. cascade         *
1361 *                                                default: no decay  *
1362 *      what (2..6), sdum   no meaning                               *
1363 *                                                                   *
1364 *********************************************************************
1365
1366  430  CONTINUE
1367       IF (WHAT(1).EQ.ONE)  ISIG0 = 1
1368       IF (WHAT(1).EQ.2.0D0) IPI0 = 1
1369       GOTO 10
1370
1371 *********************************************************************
1372 *                                                                   *
1373 *               control card:  codewd = BEAM                        *
1374 *                                                                   *
1375 *              definition of beam parameters                        *
1376 *                                                                   *
1377 *      what (1/2)  > 0 : energy of beam 1/2 (GeV)                   *
1378 *                  < 0 : abs(what(1/2)) energy per charge of        *
1379 *                        beam 1/2 (GeV)                             *
1380 *                  (beam 1 is directed into positive z-direction)   *
1381 *      what (3)    beam crossing angle, defined as 2x angle between *
1382 *                  one beam and the z-axis (micro rad)              *
1383 *      what (4)    angle with x-axis defining the collision plane   *
1384 *      what (5..6), sdum   no meaning                               *
1385 *                                                                   *
1386 *      Note: this card requires previously defined projectile and   *
1387 *            target identities (PROJPAR, TARPAR)                    *
1388 *                                                                   *
1389 *********************************************************************
1390
1391   440 CONTINUE
1392       CALL DT_BEAMPR(WHAT,PPN,1)
1393       EPN    = ZERO
1394       CMENER = ZERO
1395       LEINP  = .TRUE.
1396       GOTO 10
1397
1398 *********************************************************************
1399 *                                                                   *
1400 *               control card:  codewd = LUND-MSTU                   *
1401 *                                                                   *
1402 *          set parameter MSTU in JETSET-common /LUDAT1/             *
1403 *                                                                   *
1404 *       what (1) =  index according to LUND-common block            *
1405 *       what (2) =  new value of MSTU( int(what(1)) )               *
1406 *       what (3), what(4) and what (5), what(6) further             *
1407 *                   parameter in the same way as what (1) and       *
1408 *                   what (2)                                        *
1409 *                        default: default-Lund or corresponding to  *
1410 *                                 the set given in HADRONIZE        *
1411 *                                                                   *
1412 *********************************************************************
1413
1414   450 CONTINUE
1415       IF (WHAT(1).GT.ZERO) THEN
1416          NMSTU = NMSTU+1
1417          IMSTU(NMSTU) = INT(WHAT(1))
1418          MSTUX(NMSTU) = INT(WHAT(2))
1419       ENDIF
1420       IF (WHAT(3).GT.ZERO) THEN
1421          NMSTU = NMSTU+1
1422          IMSTU(NMSTU) = INT(WHAT(3))
1423          MSTUX(NMSTU) = INT(WHAT(4))
1424       ENDIF
1425       IF (WHAT(5).GT.ZERO) THEN
1426          NMSTU = NMSTU+1
1427          IMSTU(NMSTU) = INT(WHAT(5))
1428          MSTUX(NMSTU) = INT(WHAT(6))
1429       ENDIF
1430       GOTO 10
1431
1432 *********************************************************************
1433 *                                                                   *
1434 *               control card:  codewd = LUND-MSTJ                   *
1435 *                                                                   *
1436 *          set parameter MSTJ in JETSET-common /LUDAT1/             *
1437 *                                                                   *
1438 *       what (1) =  index according to LUND-common block            *
1439 *       what (2) =  new value of MSTJ( int(what(1)) )               *
1440 *       what (3), what(4) and what (5), what(6) further             *
1441 *                   parameter in the same way as what (1) and       *
1442 *                   what (2)                                        *
1443 *                        default: default-Lund or corresponding to  *
1444 *                                 the set given in HADRONIZE        *
1445 *                                                                   *
1446 *********************************************************************
1447
1448   451 CONTINUE
1449       IF (WHAT(1).GT.ZERO) THEN
1450          NMSTJ = NMSTJ+1
1451          IMSTJ(NMSTJ) = INT(WHAT(1))
1452          MSTJX(NMSTJ) = INT(WHAT(2))
1453       ENDIF
1454       IF (WHAT(3).GT.ZERO) THEN
1455          NMSTJ = NMSTJ+1
1456          IMSTJ(NMSTJ) = INT(WHAT(3))
1457          MSTJX(NMSTJ) = INT(WHAT(4))
1458       ENDIF
1459       IF (WHAT(5).GT.ZERO) THEN
1460          NMSTJ = NMSTJ+1
1461          IMSTJ(NMSTJ) = INT(WHAT(5))
1462          MSTJX(NMSTJ) = INT(WHAT(6))
1463       ENDIF
1464       GOTO 10
1465
1466 *********************************************************************
1467 *                                                                   *
1468 *               control card:  codewd = LUND-MDCY                   *
1469 *                                                                   *
1470 *  set parameter MDCY(I,1) for particle decays in JETSET-common     *
1471 *                                                      /LUDAT3/     *
1472 *                                                                   *
1473 *       what (1-6) = PDG particle index of particle which should    *
1474 *                    not decay                                      *
1475 *                        default: default-Lund or forced in         *
1476 *                                 DT_INITJS                         *
1477 *                                                                   *
1478 *********************************************************************
1479
1480   452 CONTINUE
1481       DO 4521 I=1,6
1482          IF (WHAT(I).NE.ZERO) THEN
1483             KC = PYCOMP(INT(WHAT(I)))
1484             MDCY(KC,1) = 0
1485          ENDIF
1486  4521 CONTINUE
1487       GOTO 10
1488
1489 *********************************************************************
1490 *                                                                   *
1491 *               control card:  codewd = LUND-PARJ                   *
1492 *                                                                   *
1493 *          set parameter PARJ in JETSET-common /LUDAT1/             *
1494 *                                                                   *
1495 *       what (1) =  index according to LUND-common block            *
1496 *       what (2) =  new value of PARJ( int(what(1)) )               *
1497 *       what (3), what(4) and what (5), what(6) further             *
1498 *                   parameter in the same way as what (1) and       *
1499 *                   what (2)                                        *
1500 *                        default: default-Lund or corresponding to  *
1501 *                                 the set given in HADRONIZE        *
1502 *                                                                   *
1503 *********************************************************************
1504
1505   460 CONTINUE
1506       IF (WHAT(1).NE.ZERO) THEN
1507          NPARJ = NPARJ+1
1508          IPARJ(NPARJ) = INT(WHAT(1))
1509          PARJX(NPARJ) = WHAT(2)
1510       ENDIF
1511       IF (WHAT(3).NE.ZERO) THEN
1512          NPARJ = NPARJ+1
1513          IPARJ(NPARJ) = INT(WHAT(3))
1514          PARJX(NPARJ) = WHAT(4)
1515       ENDIF
1516       IF (WHAT(5).NE.ZERO) THEN
1517          NPARJ = NPARJ+1
1518          IPARJ(NPARJ) = INT(WHAT(5))
1519          PARJX(NPARJ) = WHAT(6)
1520       ENDIF
1521       GOTO 10
1522
1523 *********************************************************************
1524 *                                                                   *
1525 *               control card:  codewd = LUND-PARU                   *
1526 *                                                                   *
1527 *          set parameter PARJ in JETSET-common /LUDAT1/             *
1528 *                                                                   *
1529 *       what (1) =  index according to LUND-common block            *
1530 *       what (2) =  new value of PARU( int(what(1)) )               *
1531 *       what (3), what(4) and what (5), what(6) further             *
1532 *                   parameter in the same way as what (1) and       *
1533 *                   what (2)                                        *
1534 *                        default: default-Lund or corresponding to  *
1535 *                                 the set given in HADRONIZE        *
1536 *                                                                   *
1537 *********************************************************************
1538
1539   470 CONTINUE
1540       IF (WHAT(1).GT.ZERO) THEN
1541          NPARU = NPARU+1
1542          IPARU(NPARU) = INT(WHAT(1))
1543          PARUX(NPARU) = WHAT(2)
1544       ENDIF
1545       IF (WHAT(3).GT.ZERO) THEN
1546          NPARU = NPARU+1
1547          IPARU(NPARU) = INT(WHAT(3))
1548          PARUX(NPARU) = WHAT(4)
1549       ENDIF
1550       IF (WHAT(5).GT.ZERO) THEN
1551          NPARU = NPARU+1
1552          IPARU(NPARU) = INT(WHAT(5))
1553          PARUX(NPARU) = WHAT(6)
1554       ENDIF
1555       GOTO 10
1556
1557 *********************************************************************
1558 *                                                                   *
1559 *               control card:  codewd = OUTLEVEL                    *
1560 *                                                                   *
1561 *                    output control switches                        *
1562 *                                                                   *
1563 *       what (1) =  internal rejection informations  default: 0     *
1564 *       what (2) =  energy-momentum conservation check output       *
1565 *                                                    default: 0     *
1566 *       what (3) =  internal warning messages        default: 0     *
1567 *       what (4..6), sdum    not yet used                           *
1568 *                                                                   *
1569 *********************************************************************
1570
1571   480 CONTINUE
1572       DO 481 K=1,6
1573          IOULEV(K) = INT(WHAT(K))
1574   481 CONTINUE
1575       GOTO 10
1576
1577 *********************************************************************
1578 *                                                                   *
1579 *               control card:  codewd = FRAME                       *
1580 *                                                                   *
1581 *          frame in which final state is given in DTEVT1            *
1582 *                                                                   *
1583 *       what (1) = 1  target rest frame (laboratory)                *
1584 *                = 2  nucleon-nucleon cms                           *
1585 *                                                    default: 1     *
1586 *                                                                   *
1587 *********************************************************************
1588
1589   490 CONTINUE
1590       KFRAME = INT(WHAT(1))
1591       IF ((KFRAME.GE.1).AND.(KFRAME.LE.2)) IFRAME = KFRAME
1592       GOTO 10
1593
1594 *********************************************************************
1595 *                                                                   *
1596 *               control card:  codewd = L-TAG                       *
1597 *                                                                   *
1598 *                        lepton tagger:                             *
1599 *   definition of kinematical cuts for radiated photon and          *
1600 *   outgoing lepton detection in lepton-nucleus interactions        *
1601 *                                                                   *
1602 *       what (1) = y_min                                            *
1603 *       what (2) = y_max                                            *
1604 *       what (3) = Q^2_min                                          *
1605 *       what (4) = Q^2_max                                          *
1606 *       what (5) = theta_min  (Lab)                                 *
1607 *       what (6) = theta_max  (Lab)                                 *
1608 *                                       default: no cuts            *
1609 *       sdum    no meaning                                          *
1610 *                                                                   *
1611 *********************************************************************
1612
1613   500 CONTINUE
1614       YMIN  = WHAT(1)
1615       YMAX  = WHAT(2)
1616       Q2MIN = WHAT(3)
1617       Q2MAX = WHAT(4)
1618       THMIN = WHAT(5)
1619       THMAX = WHAT(6)
1620       GOTO 10
1621
1622 *********************************************************************
1623 *                                                                   *
1624 *               control card:  codewd = L-ETAG                      *
1625 *                                                                   *
1626 *                        lepton tagger:                             *
1627 *       what (1) = min. outgoing lepton energy  (in Lab)            *
1628 *       what (2) = min. photon energy           (in Lab)            *
1629 *       what (3) = max. photon energy           (in Lab)            *
1630 *                                       default: no cuts            *
1631 *       what (2..6), sdum    no meaning                             *
1632 *                                                                   *
1633 *********************************************************************
1634
1635   510 CONTINUE
1636       ELMIN = MAX(WHAT(1),ZERO)
1637       EGMIN = MAX(WHAT(2),ZERO)
1638       EGMAX = MAX(WHAT(3),ZERO)
1639       GOTO 10
1640
1641 *********************************************************************
1642 *                                                                   *
1643 *               control card:  codewd = ECMS-CUT                    *
1644 *                                                                   *
1645 *     what (1) = min. c.m. energy to be sampled                     *
1646 *     what (2) = max. c.m. energy to be sampled                     *
1647 *     what (3) = min x_Bj         to be sampled                     *
1648 *                                       default: no cuts            *
1649 *     what (3..6), sdum    no meaning                               *
1650 *                                                                   *
1651 *********************************************************************
1652
1653   520 CONTINUE
1654       ECMIN  = WHAT(1)
1655       ECMAX  = WHAT(2)
1656       IF (ECMIN.GT.ECMAX) ECMIN = ECMAX
1657       XBJMIN = MAX(WHAT(3),ZERO)
1658       GOTO 10
1659
1660 *********************************************************************
1661 *                                                                   *
1662 *               control card:  codewd = VDM-PAR1                    *
1663 *                                                                   *
1664 *      parameters in gamma-nucleus cross section calculation        *
1665 *                                                                   *
1666 *       what (1) =  Lambda^2                       default: 2.      *
1667 *       what (2)    lower limit in M^2 integration                  *
1668 *                =  1  (3m_pi)^2                                    *
1669 *                =  2  (m_rho0)^2                                   *
1670 *                =  3  (m_phi)^2                   default: 1       *
1671 *       what (3)    upper limit in M^2 integration                  *
1672 *                =  1   s/2                                         *
1673 *                =  2   s/4                                         *
1674 *                =  3   s                          default: 3       *
1675 *       what (4)    CKMT F_2 structure function                     *
1676 *                =  2212  proton                                    *
1677 *                =  100   deuteron                 default: 2212    *
1678 *       what (5)    calculation of gamma-nucleon xsections          *
1679 *                =  1  according to CKMT-parametrization of F_2     *
1680 *                =  2  integrating SIGVP over M^2                   *
1681 *                =  3  using SIGGA                                  *
1682 *                =  4  PHOJET cross sections       default:  4      *
1683 *                                                                   *
1684 *       what (6), sdum    no meaning                                *
1685 *                                                                   *
1686 *********************************************************************
1687
1688   530 CONTINUE
1689       IF (WHAT(1).GE.ZERO) RL2 = WHAT(1)
1690       IF ((WHAT(2).GE.1).AND.(WHAT(2).LE.3)) INTRGE(1) = INT(WHAT(2))
1691       IF ((WHAT(3).GE.1).AND.(WHAT(3).LE.3)) INTRGE(2) = INT(WHAT(3))
1692       IF ((WHAT(4).EQ.2212).OR.(WHAT(4).EQ.100)) IDPDF = INT(WHAT(4))
1693       IF ((WHAT(5).GE.1).AND.(WHAT(5).LE.4)) MODEGA = INT(WHAT(5))
1694       GOTO 10
1695
1696 *********************************************************************
1697 *                                                                   *
1698 *               control card:  codewd = HISTOGRAM                   *
1699 *                                                                   *
1700 *           activate different classes of histograms                *
1701 *                                                                   *
1702 *                                default: no histograms             *
1703 *                                                                   *
1704 *********************************************************************
1705
1706   540 CONTINUE
1707       DO 541 J=1,6
1708          IF ((WHAT(J).GE.100).AND.(WHAT(J).LE.150)) THEN
1709             IHISPP(INT(WHAT(J))-100) = 1
1710          ELSEIF ((ABS(WHAT(J)).GE.200).AND.(ABS(WHAT(J)).LE.250)) THEN
1711             IHISXS(INT(ABS(WHAT(J)))-200) = 1
1712             IF (WHAT(J).LT.ZERO) IXSTBL = 1
1713          ENDIF
1714   541 CONTINUE
1715       GOTO 10
1716
1717 *********************************************************************
1718 *                                                                   *
1719 *               control card:  codewd = XS-TABLE                    *
1720 *                                                                   *
1721 *    output of cross section table for requested interaction        *
1722 *              - particle production deactivated ! -                *
1723 *                                                                   *
1724 *       what (1)      lower energy limit for tabulation             *
1725 *                > 0  Lab. frame                                    *
1726 *                < 0  nucleon-nucleon cms                           *
1727 *       what (2)      upper energy limit for tabulation             *
1728 *                > 0  Lab. frame                                    *
1729 *                < 0  nucleon-nucleon cms                           *
1730 *       what (3) > 0  # of equidistant lin. bins in E               *
1731 *                < 0  # of equidistant log. bins in E               *
1732 *       what (4)      lower limit of particle virtuality (photons)  *
1733 *       what (5)      upper limit of particle virtuality (photons)  *
1734 *       what (6) > 0  # of equidistant lin. bins in Q^2             *
1735 *                < 0  # of equidistant log. bins in Q^2             *
1736 *                                                                   *
1737 *********************************************************************
1738
1739   550 CONTINUE
1740       IF (WHAT(1).EQ.99999.0D0) THEN
1741          IRATIO = INT(WHAT(2))
1742          GOTO 10
1743       ENDIF
1744       CMENER = ABS(WHAT(2))
1745       IF (.NOT.LXSTAB) THEN
1746          CALL DT_BERTTP
1747          CALL DT_INCINI
1748       ENDIF
1749       IF ((.NOT.LXSTAB).OR.(CMENER.NE.CMEOLD)) THEN
1750          CMEOLD = CMENER
1751          IF (WHAT(2).GT.ZERO)
1752      &      CMENER = SQRT(2.0D0*AAM(1)**2+2.0D0*WHAT(2)*AAM(1))
1753          EPN = ZERO
1754          PPN = ZERO
1755 C        WRITE(LOUT,*) 'CMENER = ',CMENER
1756          CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,CMENER,1)
1757          CALL DT_PHOINI
1758       ENDIF
1759       CALL DT_XSTABL(WHAT,IXSQEL,IRATIO)
1760       IXSQEL = 0
1761       LXSTAB = .TRUE.
1762       GOTO 10
1763
1764 *********************************************************************
1765 *                                                                   *
1766 *               control card:  codewd = GLAUB-PAR                   *
1767 *                                                                   *
1768 *                parameters in Glauber-formalism                    *
1769 *                                                                   *
1770 *    what (1)  # of nucleon configurations sampled in integration   *
1771 *              over nuclear desity                default: 1000     *
1772 *    what (2)  # of bins for integration over impact-parameter and  *
1773 *              for profile-function calculation   default: 49       *
1774 *    what (3)  = 1 calculation of tot., el. and qel. cross sections *
1775 *                                                 default: 0        *
1776 *    what (4)  = 1   read pre-calculated impact-parameter distrib.  *
1777 *                    from "sdum".glb                                *
1778 *              =-1   dump pre-calculated impact-parameter distrib.  *
1779 *                    into "sdum".glb                                *
1780 *              = 100 read pre-calculated impact-parameter distrib.  *
1781 *                    for variable projectile/target/energy runs     *
1782 *                    from "sdum".glb                                *
1783 *                                                 default: 0        *
1784 *    what (5..6)   no meaning                                       *
1785 *    sdum      if |what (4)| = 1 name of in/output-file (sdum.glb)  *
1786 *                                                                   *
1787 *********************************************************************
1788
1789   560 CONTINUE
1790       IF (WHAT(1).GT.ZERO) JSTATB = INT(WHAT(1))
1791       IF (WHAT(2).GT.ZERO) JBINSB = INT(WHAT(2))
1792       IF (WHAT(3).EQ.ONE) LPROD = .FALSE.
1793       IF ((ABS(WHAT(4)).EQ.ONE).OR.(WHAT(4).EQ.100)) THEN
1794          IOGLB = INT(WHAT(4))
1795          CGLB  = SDUM
1796       ENDIF
1797       GOTO 10
1798
1799 *********************************************************************
1800 *                                                                   *
1801 *               control card:  codewd = GLAUB-INI                   *
1802 *                                                                   *
1803 *             pre-initialization of profile function                *
1804 *                                                                   *
1805 *       what (1)      lower energy limit for initialization         *
1806 *                > 0  Lab. frame                                    *
1807 *                < 0  nucleon-nucleon cms                           *
1808 *       what (2)      upper energy limit for initialization         *
1809 *                > 0  Lab. frame                                    *
1810 *                < 0  nucleon-nucleon cms                           *
1811 *       what (3) > 0  # of equidistant lin. bins in E               *
1812 *                < 0  # of equidistant log. bins in E               *
1813 *       what (4)      maximum projectile mass number for which the  *
1814 *                     Glauber data are initialized for each         *
1815 *                     projectile mass number                        *
1816 *                     (if <= mass given with the PROJPAR-card)      *
1817 *                                              default: 18          *
1818 *       what (5)      steps in mass number starting from what (4)   *
1819 *                     up to mass number defined with PROJPAR-card   *
1820 *                     for which Glauber data are initialized        *
1821 *                                              default: 5           *
1822 *       what (6)      no meaning                                    *
1823 *       sdum          no meaning                                    *
1824 *                                                                   *
1825 *********************************************************************
1826
1827   565 CONTINUE
1828       IOGLB = -100
1829       CALL DT_GLBINI(WHAT)
1830       GOTO 10
1831
1832 *********************************************************************
1833 *                                                                   *
1834 *               control card:  codewd = VDM-PAR2                    *
1835 *                                                                   *
1836 *      parameters in gamma-nucleus cross section calculation        *
1837 *                                                                   *
1838 *      what (1) = 0 no suppression of shadowing by direct photon    *
1839 *                   processes                                       *
1840 *               = 1 suppression ..                   default: 1     *
1841 *      what (2) = 0 no suppression of shadowing by anomalous        *
1842 *                   component if photon-F_2                         *
1843 *               = 1 suppression ..                   default: 1     *
1844 *      what (3) = 0 no suppression of shadowing by coherence        *
1845 *                   length of the photon                            *
1846 *               = 1 suppression ..                   default: 1     *
1847 *      what (4) = 1 longitudinal polarized photons are taken into   *
1848 *                   account                                         *
1849 *                   eps*R*Q^2/M^2 = what(4)*Q^2/M^2  default: 0     *
1850 *      what (5..6), sdum    no meaning                              *
1851 *                                                                   *
1852 *********************************************************************
1853
1854   570 CONTINUE
1855       IF ((WHAT(1).EQ.ZERO).OR.(WHAT(1).EQ.ONE)) ISHAD(1) = INT(WHAT(1))
1856       IF ((WHAT(2).EQ.ZERO).OR.(WHAT(2).EQ.ONE)) ISHAD(2) = INT(WHAT(2))
1857       IF ((WHAT(3).EQ.ZERO).OR.(WHAT(3).EQ.ONE)) ISHAD(3) = INT(WHAT(3))
1858       EPSPOL  = WHAT(4)
1859       GOTO 10
1860
1861 *********************************************************************
1862 *                                                                   *
1863 *               control card:  XS-QELPRO                            *
1864 *                                                                   *
1865 *     what (1..6), sdum    no meaning                               *
1866 *                                                                   *
1867 *********************************************************************
1868
1869   580 CONTINUE
1870       IXSQEL = ABS(WHAT(1))
1871       GOTO 10
1872
1873 *********************************************************************
1874 *                                                                   *
1875 *               control card:  RNDMINIT                             *
1876 *                                                                   *
1877 *           initialization of random number generator               *
1878 *                                                                   *
1879 *     what (1..4)    values for initialization (= 1..168)           *
1880 *     what (5..6), sdum    no meaning                               *
1881 *                                                                   *
1882 *********************************************************************
1883
1884   590 CONTINUE
1885       IF ((WHAT(1).LT.1.0D0).OR.(WHAT(1).GT.168.0D0)) THEN
1886          NA1 = 22
1887       ELSE
1888          NA1 = WHAT(1)
1889       ENDIF
1890       IF ((WHAT(2).LT.1.0D0).OR.(WHAT(2).GT.168.0D0)) THEN
1891          NA2 = 54
1892       ELSE
1893          NA2 = WHAT(2)
1894       ENDIF
1895       IF ((WHAT(3).LT.1.0D0).OR.(WHAT(3).GT.168.0D0)) THEN
1896          NA3 = 76
1897       ELSE
1898          NA3 = WHAT(3)
1899       ENDIF
1900       IF ((WHAT(4).LT.1.0D0).OR.(WHAT(4).GT.168.0D0)) THEN
1901          NA4 = 92
1902       ELSE
1903          NA4 = WHAT(4)
1904       ENDIF
1905       CALL DT_RNDMST(NA1,NA2,NA3,NA4)
1906       GOTO 10
1907
1908 *********************************************************************
1909 *                                                                   *
1910 *               control card:  codewd = LEPTO-CUT                   *
1911 *                                                                   *
1912 *          set parameter CUT in LEPTO-common /LEPTOU/               *
1913 *                                                                   *
1914 *       what (1) =  index in CUT-array                              *
1915 *       what (2) =  new value of CUT( int(what(1)) )                *
1916 *       what (3), what(4) and what (5), what(6) further             *
1917 *                   parameter in the same way as what (1) and       *
1918 *                   what (2)                                        *
1919 *                        default: default-LEPTO parameters          *
1920 *                                                                   *
1921 *********************************************************************
1922
1923   600 CONTINUE
1924       IF (WHAT(1).GT.ZERO) CUT(INT(WHAT(1))) = WHAT(2)
1925       IF (WHAT(3).GT.ZERO) CUT(INT(WHAT(3))) = WHAT(4)
1926       IF (WHAT(5).GT.ZERO) CUT(INT(WHAT(5))) = WHAT(6)
1927       GOTO 10
1928
1929 *********************************************************************
1930 *                                                                   *
1931 *               control card:  codewd = LEPTO-LST                   *
1932 *                                                                   *
1933 *          set parameter LST in LEPTO-common /LEPTOU/               *
1934 *                                                                   *
1935 *       what (1) =  index in LST-array                              *
1936 *       what (2) =  new value of LST( int(what(1)) )                *
1937 *       what (3), what(4) and what (5), what(6) further             *
1938 *                   parameter in the same way as what (1) and       *
1939 *                   what (2)                                        *
1940 *                        default: default-LEPTO parameters          *
1941 *                                                                   *
1942 *********************************************************************
1943
1944   610 CONTINUE
1945       IF (WHAT(1).GT.ZERO) LST(INT(WHAT(1))) = INT(WHAT(2))
1946       IF (WHAT(3).GT.ZERO) LST(INT(WHAT(3))) = INT(WHAT(4))
1947       IF (WHAT(5).GT.ZERO) LST(INT(WHAT(5))) = INT(WHAT(6))
1948       GOTO 10
1949
1950 *********************************************************************
1951 *                                                                   *
1952 *               control card:  codewd = LEPTO-PARL                  *
1953 *                                                                   *
1954 *          set parameter PARL in LEPTO-common /LEPTOU/              *
1955 *                                                                   *
1956 *       what (1) =  index in PARL-array                             *
1957 *       what (2) =  new value of PARL( int(what(1)) )               *
1958 *       what (3), what(4) and what (5), what(6) further             *
1959 *                   parameter in the same way as what (1) and       *
1960 *                   what (2)                                        *
1961 *                        default: default-LEPTO parameters          *
1962 *                                                                   *
1963 *********************************************************************
1964
1965   620 CONTINUE
1966       IF (WHAT(1).GT.ZERO) PARL(INT(WHAT(1))) = WHAT(2)
1967       IF (WHAT(3).GT.ZERO) PARL(INT(WHAT(3))) = WHAT(4)
1968       IF (WHAT(5).GT.ZERO) PARL(INT(WHAT(5))) = WHAT(6)
1969       GOTO 10
1970
1971 *********************************************************************
1972 *                                                                   *
1973 *               control card:  codewd = START                       *
1974 *                                                                   *
1975 *       what (1) =   number of events                default: 100.  *
1976 *       what (2) = 0 Glauber initialization follows                 *
1977 *                = 1 Glauber initialization supressed, fitted       *
1978 *                    results are used instead                       *
1979 *                    (this does not apply if emulsion-treatment     *
1980 *                     is requested)                                 *
1981 *                = 2 Glauber initialization is written to           *
1982 *                    output-file shmakov.out                        *
1983 *                = 3 Glauber initialization is read from input-file *
1984 *                    shmakov.out                     default: 0     *
1985 *       what (3..6)  no meaning                                     *
1986 *       what (3..6)  no meaning                                     *
1987 *                                                                   *
1988 *********************************************************************
1989
1990   630 CONTINUE
1991
1992 * check for cross-section table output only
1993       IF (LXSTAB) STOP
1994
1995       NCASES = INT(WHAT(1))
1996       IF (NCASES.LE.0) NCASES = 100
1997       IGLAU = INT(WHAT(2))
1998       IF ((IGLAU.NE.1).AND.(IGLAU.NE.2).AND.(IGLAU.NE.3))
1999      &                                            IGLAU = 0
2000
2001       NPMASS = IP
2002       NPCHAR = IPZ
2003       NTMASS = IT
2004       NTCHAR = ITZ
2005       IDP    = IJPROJ
2006       IDT    = IJTARG
2007       IF (IDP.LE.0) IDP = 1
2008 * muon neutrinos: temporary (missing index)
2009 * (new patch in projpar: therefore the following this is probably not
2010 *  necessary anymore..)
2011 C     IF (IDP.EQ.26) IDP = 5
2012 C     IF (IDP.EQ.27) IDP = 6
2013
2014 * redefine collision energy
2015       IF (LEINP) THEN
2016          IF (ABS(VAREHI).GT.ZERO) THEN
2017             PDUM = ZERO
2018             IF (VARELO.LT.EHADLO) VARELO = EHADLO
2019             CALL DT_LTINI(IDP,IDT,VARELO,PDUM,VARCLO,1)
2020             PDUM = ZERO
2021             CALL DT_LTINI(IDP,IDT,VAREHI,PDUM,VARCHI,1)
2022          ENDIF
2023          CALL DT_LTINI(IDP,IDT,EPN,PPN,CMENER,1)
2024       ELSE
2025          WRITE(LOUT,1003)
2026  1003    FORMAT(1X,'INIT:   collision energy not defined!',/,
2027      &          1X,'              -program stopped-      ')
2028          STOP
2029       ENDIF
2030
2031 * switch off evaporation (even if requested) if central coll. requ.
2032       IF ((ICENTR.EQ.-1).OR.(ICENTR.GT.0).OR.(XSFRAC.LT.0.5D0)) THEN
2033          IF (LEVPRT) THEN
2034             WRITE(LOUT,1004)
2035  1004       FORMAT(1X,/,'Warning!  Evaporation request rejected since',
2036      &             ' central collisions forced.')
2037             LEVPRT = .FALSE.
2038             LDEEXG = .FALSE.
2039             LHEAVY = .FALSE.
2040          ENDIF
2041       ENDIF
2042
2043 * initialization of evaporation-module
2044
2045       WRITE(LOUT,1010)
2046  1010 FORMAT(1X,/,'Warning!  No evaporation performed since',
2047      &       ' evaporation modules not available with this version.')
2048       LEVPRT = .FALSE.
2049       LDEEXG = .FALSE.
2050       LHEAVY = .FALSE.
2051       LFRMBK = .FALSE.
2052       IFISS  = 0
2053       IEVFSS = 0
2054       CALL DT_BERTTP
2055       CALL DT_INCINI
2056
2057 * save the default JETSET-parameter
2058       CALL DT_JSPARA(0)
2059
2060 * force use of phojet for g-A
2061       IF ((IDP.EQ.7).AND.(MCGENE.NE.3)) MCGENE = 2
2062 * initialization of nucleon-nucleon event generator
2063       IF (MCGENE.EQ.2) CALL DT_PHOINI
2064 * initialization of LEPTO event generator
2065       IF (MCGENE.EQ.3) THEN
2066
2067          STOP ' This version does not contain LEPTO !'
2068
2069       ENDIF
2070
2071 * initialization of quasi-elastic neutrino scattering
2072       IF (MCGENE.EQ.4) THEN
2073          IF (IJPROJ.EQ.5) THEN
2074             NEUTYP = 1
2075          ELSEIF (IJPROJ.EQ.6) THEN
2076             NEUTYP = 2
2077          ELSEIF (IJPROJ.EQ.135) THEN
2078             NEUTYP = 3
2079          ELSEIF (IJPROJ.EQ.136) THEN
2080             NEUTYP = 4
2081          ELSEIF (IJPROJ.EQ.133) THEN
2082             NEUTYP = 5
2083          ELSEIF (IJPROJ.EQ.134) THEN
2084             NEUTYP = 6
2085          ENDIF
2086       ENDIF
2087
2088 * normalize fractions of emulsion components
2089       IF (NCOMPO.GT.0) THEN
2090          SUMFRA = ZERO
2091          DO 491 I=1,NCOMPO
2092             SUMFRA = SUMFRA+EMUFRA(I)
2093   491    CONTINUE
2094          IF (SUMFRA.GT.ZERO) THEN
2095             DO 492 I=1,NCOMPO
2096                EMUFRA(I) = EMUFRA(I)/SUMFRA
2097   492       CONTINUE
2098          ENDIF
2099       ENDIF
2100
2101 * disallow Cronin's multiple scattering for nucleus-nucleus interactions
2102       IF ((IP.GT.1).AND. (IT.GT.1) .AND. (MKCRON.GT.0)) THEN
2103          WRITE(LOUT,1005)
2104  1005    FORMAT(/,1X,'INIT:  multiple scattering disallowed',/)
2105          MKCRON = 0
2106       ENDIF
2107
2108 * initialization of Glauber-formalism (moved to xAEVT, sr 26.3.96)
2109 C     IF (NCOMPO.LE.0) THEN
2110 C        CALL DT_SHMAKI(IP,IPZ,IT,ITZ,IDP,PPN,IGLAU)
2111 C     ELSE
2112 C        DO 493 I=1,NCOMPO
2113 C           CALL DT_SHMAKI(IP,IPZ,IEMUMA(I),IEMUCH(I),IDP,PPN,0)
2114 C 493    CONTINUE
2115 C     ENDIF
2116
2117 * pre-tabulation of elastic cross-sections
2118       CALL DT_SIGTBL(JDUM,JDUM,DUM,DUM,-1)
2119
2120       CALL DT_XTIME
2121
2122       RETURN
2123
2124 *********************************************************************
2125 *                                                                   *
2126 *               control card:  codewd = STOP                        *
2127 *                                                                   *
2128 *               stop of the event generation                        *
2129 *                                                                   *
2130 *       what (1..6)  no meaning                                     *
2131 *                                                                   *
2132 *********************************************************************
2133
2134  9999 CONTINUE
2135       WRITE(LOUT,9000)
2136  9000 FORMAT(1X,'---> unexpected end of input !')
2137
2138   640 CONTINUE
2139       STOP
2140
2141       END
2142
2143 *$ CREATE DT_KKINC.FOR
2144 *COPY DT_KKINC
2145 *
2146 *===kkinc==============================================================*
2147 *
2148       SUBROUTINE DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,
2149      &                                                         IREJ)
2150
2151 ************************************************************************
2152 * Treatment of complete nucleus-nucleus or hadron-nucleus scattering   *
2153 * This subroutine is an update of the previous version written         *
2154 * by J. Ranft/ H.-J. Moehring.                                         *
2155 * This version dated 19.11.95 is written by S. Roesler                 *
2156 ************************************************************************
2157
2158       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2159       SAVE
2160       PARAMETER ( LINP = 10 ,
2161      &            LOUT = 6 ,
2162      &            LDAT = 9 )
2163       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY5=1.0D-5,
2164      &           TINY2=1.0D-2,TINY3=1.0D-3)
2165
2166       LOGICAL LFZC
2167
2168 * event history
2169
2170       PARAMETER (NMXHEP=4000)
2171       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2172      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
2173      &                VHEP(4,NMXHEP), NSD1, NSD2, NDD
2174
2175       PARAMETER (NMXHKK=200000)
2176       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2177      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2178      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2179 * extended event history
2180       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2181      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2182      &                IHIST(2,NMXHKK)
2183 * particle properties (BAMJET index convention)
2184       CHARACTER*8  ANAME
2185       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2186      &                IICH(210),IIBAR(210),K1(210),K2(210)
2187 * properties of interacting particles
2188       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2189 * Lorentz-parameters of the current interaction
2190       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
2191      &                UMO,PPCM,EPROJ,PPROJ
2192 * flags for input different options
2193       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2194       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2195      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2196 * flags for particle decays
2197       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2198      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2199      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2200 * cuts for variable energy runs
2201       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2202 * Glauber formalism: flags and parameters for statistics
2203       LOGICAL LPROD
2204       CHARACTER*8 CGLB
2205       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2206
2207       DIMENSION WHAT(6)
2208
2209       IREJ  = 0
2210       ILOOP = 0
2211       NSD1  = 0
2212       NSD2  = 0
2213       NDD   = 0
2214   100 CONTINUE
2215       IF (ILOOP.EQ.4) THEN
2216          WRITE(LOUT,1000) NEVHKK
2217  1000    FORMAT(1X,'KKINC: event ',I8,' rejected!')
2218          GOTO 9999
2219       ENDIF
2220       ILOOP = ILOOP+1
2221
2222 * variable energy-runs, recalculate parameters for LT's
2223       IF ((ABS(VAREHI).GT.ZERO).OR.(IOGLB.EQ.100)) THEN
2224          PDUM = ZERO
2225          CDUM = ZERO
2226          CALL DT_LTINI(IDP,1,EPN,PDUM,CDUM,1)
2227       ENDIF
2228       IF (EPN.GT.EPROJ) THEN
2229          WRITE(LOUT,'(A,E9.3,2A,E9.3,A)')
2230      &      ' Requested energy (',EPN,'GeV) exceeds',
2231      &      ' initialization energy (',EPROJ,'GeV) !'
2232          STOP
2233       ENDIF
2234
2235 * re-initialize /DTPRTA/
2236       IP  = NPMASS
2237       IPZ = NPCHAR
2238       IT  = NTMASS
2239       ITZ = NTCHAR
2240       IJPROJ = IDP
2241       IBPROJ = IIBAR(IJPROJ)
2242
2243 * calculate nuclear potentials (common /DTNPOT/)
2244       CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
2245
2246 * initialize treatment for residual nuclei
2247       CALL DT_RESNCL(EPN,NLOOP,1)
2248
2249 * sample hadron/nucleus-nucleus interaction
2250       CALL DT_KKEVNT(KKMAT,IREJ1)
2251       IF (IREJ1.GT.0) THEN
2252          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKINC'
2253          GOTO 9999
2254       ENDIF
2255
2256       IF ((NPMASS.GT.1).OR.(NTMASS.GT.1)) THEN
2257
2258 * intranuclear cascade of final state particles for KTAUGE generations
2259 * of secondaries
2260          CALL DT_FOZOCA(LFZC,IREJ1)
2261          IF (IREJ1.GT.0) THEN
2262             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKINC'
2263             GOTO 9999
2264          ENDIF
2265
2266 * baryons unable to escape the nuclear potential are treated as
2267 * excited nucleons (ISTHKK=15,16)
2268          CALL DT_SCN4BA
2269
2270 * decay of resonances produced in intranuclear cascade processes
2271 **sr 15-11-95 should be obsolete
2272 C        IF (LFZC) CALL DT_DECAY1
2273
2274   101    CONTINUE
2275 * treatment of residual nuclei
2276          CALL DT_RESNCL(EPN,NLOOP,2)
2277
2278 * evaporation / fission / fragmentation
2279 * (if intranuclear cascade was sampled only)
2280          IF (LFZC) THEN
2281             CALL DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ1)
2282             IF (IREJ1.GT.1) GOTO 101
2283             IF (IREJ1.EQ.1) GOTO 100
2284          ENDIF
2285
2286       ENDIF
2287
2288 * rejection of unphysical configurations
2289       CALL DT_REJUCO(1,IREJ1)
2290       IF (IREJ1.GT.0) THEN
2291          IF (IOULEV(1).GT.0)
2292      &      WRITE(LOUT,*) 'rejected 3 in KKINC: too large x'
2293          GOTO 100
2294       ENDIF
2295
2296 * transform finale state into Lab.
2297       IFLAG = 2
2298       CALL DT_BEAMPR(WHAT,DUM,IFLAG)
2299       IF ((IFRAME.EQ.1).AND.(IFLAG.EQ.-1)) CALL DT_LT2LAB
2300
2301       IF (IPI0.EQ.1) CALL DT_DECPI0
2302
2303 C     IF (NEVHKK.EQ.5) CALL DT_EVTOUT(4)
2304       RETURN
2305  9999 CONTINUE
2306       IREJ = 1
2307
2308       RETURN
2309       END
2310
2311 *$ CREATE DT_DEFAUL.FOR
2312 *COPY DT_DEFAUL
2313 *
2314 *===defaul=============================================================*
2315 *
2316       SUBROUTINE DT_DEFAUL(EPN,PPN)
2317
2318 ************************************************************************
2319 * Variables are set to default values.                                 *
2320 * This version dated 8.5.95 is written by S. Roesler.                  *
2321 ************************************************************************
2322
2323       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2324       SAVE
2325       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
2326       PARAMETER (TWOPI  = 6.283185307179586454D+00)
2327
2328 * particle properties (BAMJET index convention)
2329       CHARACTER*8  ANAME
2330       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2331      &                IICH(210),IIBAR(210),K1(210),K2(210)
2332 * nuclear potential
2333       LOGICAL LFERMI
2334       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
2335      &                EBINDP(2),EBINDN(2),EPOT(2,210),
2336      &                ETACOU(2),ICOUL,LFERMI
2337 * interface HADRIN-DPM
2338       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
2339 * central particle production, impact parameter biasing
2340       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
2341 * properties of interacting particles
2342       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2343 * properties of photon/lepton projectiles
2344       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2345       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2346 * emulsion treatment
2347       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2348      &                NCOMPO,IEMUL
2349 * parameter for intranuclear cascade
2350       LOGICAL LPAULI
2351       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
2352 * various options for treatment of partons (DTUNUC 1.x)
2353 * (chain recombination, Cronin,..)
2354       LOGICAL LCO2CR,LINTPT
2355       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
2356      &                LCO2CR,LINTPT
2357 * threshold values for x-sampling (DTUNUC 1.x)
2358       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
2359      &                SSMIMQ,VVMTHR
2360 * flags for input different options
2361       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2362       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2363      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2364 * n-n cross section fluctuations
2365       PARAMETER (NBINS = 1000)
2366       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
2367 * flags for particle decays
2368       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2369      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2370      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2371 * diquark-breaking mechanism
2372       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
2373 * nucleon-nucleon event-generator
2374       CHARACTER*8 CMODEL
2375       LOGICAL LPHOIN
2376       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2377 * flags for diffractive interactions (DTUNUC 1.x)
2378       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
2379 * VDM parameter for photon-nucleus interactions
2380       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
2381 * Glauber formalism: flags and parameters for statistics
2382       LOGICAL LPROD
2383       CHARACTER*8 CGLB
2384       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2385 * kinematical cuts for lepton-nucleus interactions
2386       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2387      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2388 * flags for activated histograms
2389       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2390 * cuts for variable energy runs
2391       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2392 * parameters for hA-diffraction
2393       COMMON /DTDIHA/ DIBETA,DIALPH
2394 * LEPTO
2395       REAL RPPN
2396       COMMON /LEPTOI/ RPPN,LEPIN,INTER
2397 * steering flags for qel neutrino scattering modules
2398       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
2399 * event flag
2400       COMMON /DTEVNO/ NEVENT,ICASCA
2401
2402       DATA POTMES /0.002D0/
2403
2404 * common /DTNPOT/
2405       DO 10 I=1,2
2406          PFERMP(I) = ZERO
2407          PFERMN(I) = ZERO
2408          EBINDP(I) = ZERO
2409          EBINDN(I) = ZERO
2410          DO 11 J=1,210
2411             EPOT(I,J) = ZERO
2412    11    CONTINUE
2413 * nucleus independent meson potential
2414          EPOT(I,13) = POTMES
2415          EPOT(I,14) = POTMES
2416          EPOT(I,15) = POTMES
2417          EPOT(I,16) = POTMES
2418          EPOT(I,23) = POTMES
2419          EPOT(I,24) = POTMES
2420          EPOT(I,25) = POTMES
2421    10 CONTINUE
2422       FERMOD    = 0.55D0
2423       ETACOU(1) = ZERO
2424       ETACOU(2) = ZERO
2425       ICOUL     = 1
2426       LFERMI    = .TRUE.
2427
2428 * common /HNTHRE/
2429       EHADTH = -99.0D0
2430       EHADLO = 4.06D0
2431       EHADHI = 6.0D0
2432       INTHAD = 1
2433       IDXTA  = 2
2434
2435 * common /DTIMPA/
2436       ICENTR = 0
2437       BIMIN  = ZERO
2438       BIMAX  = 1.0D10
2439       XSFRAC = 1.0D0
2440
2441 * common /DTPRTA/
2442       IP  = 1
2443       IPZ = 1
2444       IT  = 1
2445       ITZ = 1
2446       IJPROJ = 1
2447       IBPROJ = 1
2448       IJTARG = 1
2449       IBTARG = 1
2450 * common /DTGPRO/
2451       VIRT = ZERO
2452       DO 14 I=1,4
2453          PGAMM(I)  = ZERO
2454          PLEPT0(I) = ZERO
2455          PLEPT1(I) = ZERO
2456          PNUCL(I)  = ZERO
2457    14 CONTINUE
2458       IDIREC   = 0
2459
2460 * common /DTFOTI/
2461 **sr 7.4.98: changed after corrected B-sampling
2462 C     TAUFOR = 4.4D0
2463       TAUFOR = 3.5D0
2464       KTAUGE = 25
2465       ITAUVE = 1
2466       INCMOD = 1
2467       LPAULI = .TRUE.
2468
2469 * common /DTCHAI/
2470       SEASQ  = ONE
2471       MKCRON = 1
2472       CRONCO = 0.64D0
2473       ISICHA = 0
2474       CUTOF  = 100.0D0
2475       LCO2CR = .FALSE.
2476       IRECOM = 1
2477       LINTPT = .TRUE.
2478
2479 * common /DTXCUT/
2480 *  definition of soft quark distributions
2481       XSEACU = 0.05D0
2482       UNON   = 2.0D0
2483       UNOM   = 1.5D0
2484       UNOSEA = 5.0D0
2485 *  cutoff parameters for x-sampling
2486       CVQ    = 1.0D0
2487       CDQ    = 2.0D0
2488 C     CSEA   = 0.3D0
2489       CSEA   = 0.1D0
2490       SSMIMA = 1.2D0
2491       SSMIMQ = SSMIMA**2
2492       VVMTHR = 2.0D0
2493
2494 * common /DTXSFL/
2495       IFLUCT = 0
2496
2497 * common /DTFRPA/
2498       PDB = 0.15D0
2499       PDBSEA(1) = 0.0D0
2500       PDBSEA(2) = 0.0D0
2501       PDBSEA(3) = 0.0D0
2502       ISIG0 = 0
2503       IPI0  = 0
2504       NMSTU = 0
2505       NPARU = 0
2506       NMSTJ = 0
2507       NPARJ = 0
2508
2509 * common /DTDIQB/
2510       DO 15 I=1,8
2511          DBRKR(1,I) = 5.0D0
2512          DBRKR(2,I) = 5.0D0
2513          DBRKR(3,I) = 10.0D0
2514          DBRKA(1,I) = ZERO
2515          DBRKA(2,I) = ZERO
2516          DBRKA(3,I) = ZERO
2517    15 CONTINUE
2518       CHAM1 = 0.2D0
2519       CHAM3 = 0.5D0
2520       CHAB1 = 0.7D0
2521       CHAB3 = 1.0D0
2522
2523 * common /DTFLG3/
2524       ISINGD = 0
2525       IDOUBD = 0
2526       IFLAGD = 0
2527       IDIFF  = 0
2528
2529 * common /DTMODL/
2530       MCGENE    = 2
2531       CMODEL(1) = 'DTUNUC  '
2532       CMODEL(2) = 'PHOJET  '
2533       CMODEL(3) = 'LEPTO   '
2534       CMODEL(4) = 'QNEUTRIN'
2535       LPHOIN    = .TRUE.
2536       ELOJET    = 5.0D0
2537
2538 * common /DTLCUT/
2539       ECMIN  = 3.5D0
2540       ECMAX  = 1.0D10
2541       XBJMIN = ZERO
2542       ELMIN = ZERO
2543       EGMIN = ZERO
2544       EGMAX = 1.0D10
2545       YMIN  = TINY10
2546       YMAX  = 0.999D0
2547       Q2MIN = TINY10
2548       Q2MAX = 10.0D0
2549       THMIN = ZERO
2550       THMAX = TWOPI
2551       Q2LI  = ZERO
2552       Q2HI  = 1.0D10
2553       ECMLI = ZERO
2554       ECMHI = 1.0D10
2555
2556 * common /DTVDMP/
2557       RL2       = 2.0D0
2558       INTRGE(1) = 1
2559       INTRGE(2) = 3
2560       IDPDF     = 2212
2561       MODEGA    = 4
2562       ISHAD(1)  = 1
2563       ISHAD(2)  = 1
2564       ISHAD(3)  = 1
2565       EPSPOL    = ZERO
2566
2567 * common /DTGLGP/
2568       JSTATB = 1000
2569       JBINSB = 49
2570       CGLB   = '        '
2571       IF (ITRSPT.EQ.1) THEN
2572          IOGLB  = 100
2573       ELSE
2574          IOGLB  = 0
2575       ENDIF
2576       LPROD  = .TRUE.
2577
2578 * common /DTHIS3/
2579       DO 16 I=1,50
2580          IHISPP(I) = 0
2581          IHISXS(I) = 0
2582    16 CONTINUE
2583       IXSTBL = 0
2584
2585 * common /DTVARE/
2586       VARELO = ZERO
2587       VAREHI = ZERO
2588       VARCLO = ZERO
2589       VARCHI = ZERO
2590
2591 * common /DTDIHA/
2592       DIBETA = -1.0D0
2593       DIALPH = ZERO
2594
2595 * common /LEPTOI/
2596       RPPN  = 0.0
2597       LEPIN = 0
2598       INTER = 0
2599
2600 * common /QNEUTO/
2601       NEUTYP = 1
2602       NEUDEC = 0
2603
2604 * common /DTEVNO/
2605       NEVENT = 1
2606       IF (ITRSPT.EQ.1) THEN
2607          ICASCA = 1
2608       ELSE
2609          ICASCA = 0
2610       ENDIF
2611
2612 * default Lab.-energy
2613       EPN = 200.0D0
2614       PPN = SQRT((EPN-AAM(IJPROJ))*(EPN+AAM(IJPROJ)))
2615
2616       RETURN
2617       END
2618
2619 *$ CREATE DT_AAEVT.FOR
2620 *COPY DT_AAEVT
2621 *
2622 *===aaevt==============================================================*
2623 *
2624       SUBROUTINE DT_AAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2625      &                                             IDP,IGLAU)
2626
2627 ************************************************************************
2628 * This version dated 22.03.96 is written by S. Roesler.                *
2629 ************************************************************************
2630
2631       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2632       SAVE
2633       PARAMETER ( LINP = 10 ,
2634      &            LOUT = 6 ,
2635      &            LDAT = 9 )
2636
2637       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2638 * emulsion treatment
2639       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2640      &                NCOMPO,IEMUL
2641 * event flag
2642       COMMON /DTEVNO/ NEVENT,ICASCA
2643       CHARACTER*8 DATE,HHMMSS
2644       DIMENSION IDMNYR(3)
2645       NSD1 = 0
2646       NSD2 = 0
2647       NDD  = 0
2648       KKMAT  = 1
2649       NMSG   = MAX(NEVTS/100,1)
2650
2651 * initialization of run-statistics and histograms
2652       CALL DT_STATIS(1)
2653       CALL PHO_PHIST(1000,DUM)
2654
2655 * initialization of Glauber-formalism
2656       IF (NCOMPO.LE.0) THEN
2657          CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2658       ELSE
2659          DO 1 I=1,NCOMPO
2660             CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2661     1    CONTINUE
2662       ENDIF
2663       CALL DT_SIGEMU
2664
2665       CALL IDATE(IDMNYR)
2666       WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2667      &   IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2668       CALL ITIME(IDMNYR)
2669       WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2670      &   IDMNYR(1),IDMNYR(2),IDMNYR(3)
2671       WRITE(LOUT,1001) DATE,HHMMSS
2672  1001 FORMAT(/,' DT_AAEVT: Initialisation finished. ( Date: ',A8,
2673      &       '   Time: ',A8,' )')
2674
2675 * generate NEVTS events
2676       DO 2 IEVT=1,NEVTS
2677
2678 *  print run-status message
2679          IF (MOD(IEVT,NMSG).EQ.0) THEN
2680             CALL IDATE(IDMNYR)
2681             WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2682      &         IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2683             CALL ITIME(IDMNYR)
2684             WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2685      &         IDMNYR(1),IDMNYR(2),IDMNYR(3)
2686             WRITE(LOUT,1000) IEVT-1,NEVTS,DATE,HHMMSS
2687  1000       FORMAT(/,1X,I8,' out of ',I8,' events sampled ( Date: ',A,
2688      &             '   Time: ',A,' )',/)
2689 C           WRITE(LOUT,1000) IEVT-1
2690 C1000       FORMAT(1X,I8,' events sampled')
2691          ENDIF
2692          NEVENT = IEVT
2693 *  treat nuclear emulsions
2694          IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
2695 *  composite targets only
2696          KKMAT = -KKMAT
2697 *  sample this event
2698          CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,IREJ)
2699
2700          CALL PHO_PHIST(2000,DUM)
2701
2702          write(6,*) "Diffractive collisions", NSD1, NSD2, NDD
2703
2704     2 CONTINUE
2705
2706 * print run-statistics and histograms to output-unit 6
2707       CALL PHO_PHIST(3000,DUM)
2708       CALL DT_STATIS(2)
2709       RETURN
2710       END
2711
2712 *$ CREATE DT_LAEVT.FOR
2713 *COPY DT_LAEVT
2714 *
2715 *===laevt==============================================================*
2716 *
2717       SUBROUTINE DT_LAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2718      &                                             IDP,IGLAU)
2719
2720 ************************************************************************
2721 * Interface to run DPMJET for lepton-nucleus interactions.             *
2722 * Kinematics is sampled using the equivalent photon approximation      *
2723 * Based on GPHERA-routine by R. Engel.                                 *
2724 * This version dated 23.03.96 is written by S. Roesler.                *
2725 ************************************************************************
2726
2727       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2728       SAVE
2729       PARAMETER ( LINP = 10 ,
2730      &            LOUT = 6 ,
2731      &            LDAT = 9 )
2732       PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,
2733      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
2734       PARAMETER (TWOPI  = 6.283185307179586454D+00,
2735      &           PI     = TWOPI/TWO,
2736      &           ALPHEM = ONE/137.0D0)
2737
2738 C     CHARACTER*72 HEADER
2739
2740 * particle properties (BAMJET index convention)
2741       CHARACTER*8  ANAME
2742       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2743      &                IICH(210),IIBAR(210),K1(210),K2(210)
2744 * event history
2745       PARAMETER (NMXHKK=200000)
2746       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2747      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2748      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2749 * extended event history
2750       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2751      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2752      &                IHIST(2,NMXHKK)
2753 * kinematical cuts for lepton-nucleus interactions
2754       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2755      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2756 * properties of interacting particles
2757       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2758 * properties of photon/lepton projectiles
2759       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2760 * kinematics at lepton-gamma vertex
2761       COMMON /DTLGVX/ PPL0(4),PPL1(4),PPG(4),PPA(4)
2762 * flags for activated histograms
2763       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2764       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2765 * emulsion treatment
2766       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2767      &                NCOMPO,IEMUL
2768 * Glauber formalism: cross sections
2769       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
2770      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
2771      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
2772      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
2773      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
2774      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
2775      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
2776      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
2777      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
2778      &                BSLOPE,NEBINI,NQBINI
2779 * nucleon-nucleon event-generator
2780       CHARACTER*8 CMODEL
2781       LOGICAL LPHOIN
2782       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2783 * flags for input different options
2784       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2785       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2786      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2787 * event flag
2788       COMMON /DTEVNO/ NEVENT,ICASCA
2789
2790       DIMENSION XDUMB(40),BGTA(4)
2791
2792 * LEPTO
2793       IF (MCGENE.EQ.3) THEN
2794          STOP ' This version does not contain LEPTO !'
2795       ENDIF
2796
2797       KKMAT  = 1
2798       NMSG   = MAX(NEVTS/10,1)
2799
2800 * mass of incident lepton
2801       AMLPT  = AAM(IDP)
2802       AMLPT2 = AMLPT**2
2803       IDPPDG = IDT_IPDGHA(IDP)
2804
2805 * consistency of kinematical limits
2806       Q2MIN  = MAX(Q2MIN,TINY10)
2807       Q2MAX  = MAX(Q2MAX,TINY10)
2808       YMIN   = MIN(MAX(YMIN,TINY10),0.999D0)
2809       YMAX   = MIN(MAX(YMAX,TINY10),0.999D0)
2810
2811 * total energy of the lepton-nucleon system
2812       PTOTLN = SQRT( (PLEPT0(1)+PNUCL(1))**2+(PLEPT0(2)+PNUCL(2))**2
2813      &                                      +(PLEPT0(3)+PNUCL(3))**2 )
2814       ETOTLN = PLEPT0(4)+PNUCL(4)
2815       ECMLN  = SQRT((ETOTLN-PTOTLN)*(ETOTLN+PTOTLN))
2816       ECMAX  = MIN(ECMAX,ECMLN)
2817       WRITE(LOUT,1003) ECMIN,ECMAX,YMIN,YMAX,Q2MIN,Q2MAX,EGMIN,
2818      &                 THMIN,THMAX,ELMIN
2819  1003 FORMAT(1X,'LAEVT:',16X,'kinematical cuts',/,22X,
2820      &       '------------------',/,9X,'W (min)   =',
2821      &       F7.1,' GeV    (max) =',F7.1,' GeV',/,9X,'y (min)   =',
2822      &       F7.3,8X,'(max) =',F7.3,/,9X,'Q^2 (min) =',F7.1,
2823      &       ' GeV^2  (max) =',F7.1,' GeV^2',/,' (Lab)   E_g (min) ='
2824      &       ,F7.1,' GeV',/,' (Lab) theta (min) =',F7.4,8X,'(max) =',
2825      &       F7.4,'   for E_lpt >',F7.1,' GeV',/)
2826
2827 * Lorentz-parameter for transf. into Lab
2828       BGTA(1) = PNUCL(1)/AAM(1)
2829       BGTA(2) = PNUCL(2)/AAM(1)
2830       BGTA(3) = PNUCL(3)/AAM(1)
2831       BGTA(4) = PNUCL(4)/AAM(1)
2832 * LT of incident lepton into Lab and dump it in DTEVT1
2833       CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
2834      &            PLEPT0(1),PLEPT0(2),PLEPT0(3),PLEPT0(4),
2835      &            PLTOT,PPL0(1),PPL0(2),PPL0(3),PPL0(4))
2836       CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
2837      &            PNUCL(1),PNUCL(2),PNUCL(3),PNUCL(4),
2838      &            PLTOT,PPA(1),PPA(2),PPA(3),PPA(4))
2839 * maximum energy of photon nucleon system
2840       PTOTGN = SQRT((YMAX*PPL0(1)+PPA(1))**2+(YMAX*PPL0(2)+PPA(2))**2
2841      &                                      +(YMAX*PPL0(3)+PPA(3))**2)
2842       ETOTGN = YMAX*PPL0(4)+PPA(4)
2843       EGNMAX = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
2844       EGNMAX = MIN(EGNMAX,ECMAX)
2845 * minimum energy of photon nucleon system
2846       PTOTGN = SQRT((YMIN*PPL0(1)+PPA(1))**2+(YMIN*PPL0(2)+PPA(2))**2
2847      &                                      +(YMIN*PPL0(3)+PPA(3))**2)
2848       ETOTGN = YMIN*PPL0(4)+PPA(4)
2849       EGNMIN = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
2850       EGNMIN = MAX(EGNMIN,ECMIN)
2851
2852 * limits for Glauber-initialization
2853       Q2LI  = Q2MIN
2854       Q2HI  = MAX(Q2LI,MIN(Q2HI,Q2MAX))
2855       ECMLI = MAX(EGNMIN,THREE)
2856       ECMHI = EGNMAX
2857       WRITE(LOUT,1004) EGNMIN,EGNMAX,ECMLI,ECMHI,Q2LI,Q2HI
2858  1004 FORMAT(1X,'resulting limits:',/,9X,'W (min)   =',F7.1,
2859      &       ' GeV    (max) =',F7.1,' GeV',/,/,' limits for ',
2860      &       'Glauber-initialization:',/,9X,'W (min)   =',F7.1,
2861      &       ' GeV    (max) =',F7.1,' GeV',/,9X,'Q^2 (min) =',F7.1,
2862      &       ' GeV^2  (max) =',F7.1,' GeV^2',/)
2863 * initialization of Glauber-formalism
2864       IF (NCOMPO.LE.0) THEN
2865          CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2866       ELSE
2867          DO 9 I=1,NCOMPO
2868             CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2869     9    CONTINUE
2870       ENDIF
2871       CALL DT_SIGEMU
2872
2873 * initialization of run-statistics and histograms
2874       CALL DT_STATIS(1)
2875       CALL PHO_PHIST(1000,DUM)
2876
2877 * maximum photon-nucleus cross section
2878       I1  = 1
2879       I2  = 1
2880       RAT = ONE
2881       IF (EGNMAX.GE.ECMNN(NEBINI)) THEN
2882          I1  = NEBINI
2883          I2  = NEBINI
2884          RAT = ONE
2885       ELSEIF (EGNMAX.GT.ECMNN(1)) THEN
2886          DO 5 I=2,NEBINI
2887             IF (EGNMAX.LT.ECMNN(I)) THEN
2888                I1  = I-1
2889                I2  = I
2890                RAT = (EGNMAX-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
2891                GOTO 6
2892             ENDIF
2893     5    CONTINUE
2894     6    CONTINUE
2895       ENDIF
2896       SIGMAX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
2897       EGNXX  = EGNMAX
2898       I1  = 1
2899       I2  = 1
2900       RAT = ONE
2901       IF (EGNMIN.GE.ECMNN(NEBINI)) THEN
2902          I1  = NEBINI
2903          I2  = NEBINI
2904          RAT = ONE
2905       ELSEIF (EGNMIN.GT.ECMNN(1)) THEN
2906          DO 7 I=2,NEBINI
2907             IF (EGNMIN.LT.ECMNN(I)) THEN
2908                I1  = I-1
2909                I2  = I
2910                RAT = (EGNMIN-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
2911                GOTO 8
2912             ENDIF
2913     7    CONTINUE
2914     8    CONTINUE
2915       ENDIF
2916       SIGXX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
2917       IF (SIGXX.GT.SIGMAX) EGNXX = EGNMIN
2918       SIGMAX = MAX(SIGMAX,SIGXX)
2919       WRITE(LOUT,'(9X,A,F8.3,A)') 'Sigma_tot (max) =',SIGMAX,' mb'
2920
2921 * plot photon flux table
2922       AYMIN = LOG(YMIN)
2923       AYMAX = LOG(YMAX)
2924       AYRGE = AYMAX-AYMIN
2925       MAXTAB = 50
2926       ADY    = LOG(YMAX/YMIN)/DBLE(MAXTAB-1)
2927 C     WRITE(LOUT,'(/,1X,A)') 'LAEVT:   photon flux '
2928       DO 1 I=1,MAXTAB
2929          Y     = EXP(AYMIN+ADY*DBLE(I-1))
2930          Q2LOW = MAX(Q2MIN,AMLPT2*Y**2/(ONE-Y))
2931          FF1   = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2932      &                           -TWO*AMLPT2*Y*(ONE/Q2LOW-ONE/Q2MAX))
2933          FF2   = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2934      &                           -TWO*(ONE-Y)/Y*(ONE-Q2LOW/Q2MAX))
2935 C        WRITE(LOUT,'(5X,3E15.4)') Y,FF1,FF2
2936     1 CONTINUE
2937
2938 * maximum residual weight for flux sampling (dy/y)
2939       YY     = YMIN
2940       Q2LOW  = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
2941       WGHMAX = (ONE+(ONE-YY)**2)*LOG(Q2MAX/Q2LOW)
2942      &         -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
2943
2944       CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY0)
2945       CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY1)
2946       CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY2)
2947       CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ0)
2948       CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ1)
2949       CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ2)
2950       CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE0)
2951       CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE1)
2952       CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE2)
2953       CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU0)
2954       CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU1)
2955       CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU2)
2956       XBLOW = 0.001D0
2957       CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX0)
2958       CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX1)
2959       CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX2)
2960
2961       ITRY = 0
2962       ITRW = 0
2963       NC0  = 0
2964       NC1  = 0
2965
2966 * generate events
2967       DO 2 IEVT=1,NEVTS
2968          IF (MOD(IEVT,NMSG).EQ.0) THEN
2969 C           OPEN(LDAT,FILE='/scrtch3/hr/sroesler/statusd5.out',
2970 C    &                                         STATUS='UNKNOWN')
2971             WRITE(LOUT,'(1X,I8,A)') IEVT-1,' events sampled'
2972 C           CLOSE(LDAT)
2973          ENDIF
2974          NEVENT = IEVT
2975
2976   100    CONTINUE
2977          ITRY = ITRY+1
2978
2979 *  sample y
2980   101    CONTINUE
2981          ITRW  = ITRW+1
2982          YY    = EXP(AYRGE*DT_RNDM(RAT)+AYMIN)
2983          Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
2984          Q2LOG = LOG(Q2MAX/Q2LOW)
2985          WGH   = (ONE+(ONE-YY)**2)*Q2LOG
2986      &           -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
2987          IF (WGHMAX.LT.WGH) WRITE(LOUT,1000) YY,WGHMAX,WGH
2988  1000    FORMAT(1X,'LAEVT:   weight error!',3E12.5)
2989          IF (DT_RNDM(YY)*WGHMAX.GT.WGH) GOTO 101
2990
2991 *  sample Q2
2992          YEFF = ONE+(ONE-YY)**2
2993   102    CONTINUE
2994          Q2  = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
2995          WGH = (YEFF-TWO*(ONE-YY)*Q2LOW/Q2)/YEFF
2996          IF (WGH.LT.DT_RNDM(Q2)) GOTO 102
2997
2998 c        NC0 = NC0+1
2999 c        CALL DT_FILHGR(YY,ONE,IHFLY0,NC0)
3000 c        CALL DT_FILHGR(Q2,ONE,IHFLQ0,NC0)
3001
3002 *  kinematics at lepton-photon vertex
3003 *   scattered electron
3004          YQ2 = SQRT((ONE-YY)*Q2)
3005          Q2E = Q2/(4.0D0*PLEPT0(4))
3006          E1Y = (ONE-YY)*PLEPT0(4)
3007          CALL DT_DSFECF(SIF,COF)
3008          PLEPT1(1) = YQ2*COF
3009          PLEPT1(2) = YQ2*SIF
3010          PLEPT1(3) = E1Y-Q2E
3011          PLEPT1(4) = E1Y+Q2E
3012 C        THETA = ACOS( (E1Y-Q2E)/(E1Y+Q2E) )
3013 *   radiated photon
3014          PGAMM(1) = -PLEPT1(1)
3015          PGAMM(2) = -PLEPT1(2)
3016          PGAMM(3) = PLEPT0(3)-PLEPT1(3)
3017          PGAMM(4) = PLEPT0(4)-PLEPT1(4)
3018 *   E_cm cut
3019          PTOTGN = SQRT( (PGAMM(1)+PNUCL(1))**2+(PGAMM(2)+PNUCL(2))**2
3020      &                                        +(PGAMM(3)+PNUCL(3))**2 )
3021          ETOTGN = PGAMM(4)+PNUCL(4)
3022          ECMGN  = (ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)
3023          IF (ECMGN.LT.0.1D0) GOTO 101
3024          ECMGN  = SQRT(ECMGN)
3025          IF ((ECMGN.LT.ECMIN).OR.(ECMGN.GT.ECMAX)) GOTO 101
3026
3027 *  Lorentz-transformation into nucleon-rest system
3028          CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3029      &               PGAMM(1),PGAMM(2),PGAMM(3),PGAMM(4),
3030      &               PGTOT,PPG(1),PPG(2),PPG(3),PPG(4))
3031          CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3032      &               PLEPT1(1),PLEPT1(2),PLEPT1(3),PLEPT1(4),
3033      &               PLTOT,PPL1(1),PPL1(2),PPL1(3),PPL1(4))
3034 *  temporary checks..
3035          Q2TMP = ABS(PPG(4)**2-PGTOT**2)
3036          IF (ABS(Q2-Q2TMP).GT.0.01D0) WRITE(LOUT,1001) Q2,Q2TMP
3037  1001    FORMAT(1X,'LAEVT:    inconsistent kinematics (Q2,Q2TMP) ',
3038      &          2F10.4)
3039          ECMTMP = SQRT((PPG(4)+AAM(1)-PGTOT)*(PPG(4)+AAM(1)+PGTOT))
3040          IF (ABS(ECMGN-ECMTMP).GT.TINY10) WRITE(LOUT,1002) ECMGN,ECMTMP
3041  1002    FORMAT(1X,'LAEVT:    inconsistent kinematics (ECMGN,ECMTMP) ',
3042      &          2F10.2)
3043          YYTMP = PPG(4)/PPL0(4)
3044          IF (ABS(YY-YYTMP).GT.0.01D0) WRITE(LOUT,1005) YY,YYTMP
3045  1005    FORMAT(1X,'LAEVT:    inconsistent kinematics (YY,YYTMP) ',
3046      &          2F10.4)
3047
3048 *  lepton tagger (Lab)
3049          THETA = ACOS( PPL1(3)/PLTOT )
3050          IF (PPL1(4).GT.ELMIN) THEN
3051             IF ((THETA.LT.THMIN).OR.(THETA.GT.THMAX)) GOTO 101
3052          ENDIF
3053 *  photon energy-cut (Lab)
3054          IF (PPG(4).LT.EGMIN) GOTO 101
3055          IF (PPG(4).GT.EGMAX) GOTO 101
3056 *   x_Bj cut
3057          XBJ = ABS(Q2/(1.876D0*PPG(4)))
3058          IF (XBJ.LT.XBJMIN) GOTO 101
3059
3060          NC0 = NC0+1
3061          CALL DT_FILHGR(    Q2,ONE,IHFLQ0,NC0)
3062          CALL DT_FILHGR(    YY,ONE,IHFLY0,NC0)
3063          CALL DT_FILHGR(   XBJ,ONE,IHFLX0,NC0)
3064          CALL DT_FILHGR(PPG(4),ONE,IHFLU0,NC0)
3065          CALL DT_FILHGR( ECMGN,ONE,IHFLE0,NC0)
3066
3067 *  rotation angles against z-axis
3068          COD = PPG(3)/PGTOT
3069 C        SID = SQRT((ONE-COD)*(ONE+COD))
3070          PPT = SQRT(PPG(1)**2+PPG(2)**2)
3071          SID = PPT/PGTOT
3072          COF = ONE
3073          SIF = ZERO
3074          IF (PGTOT*SID.GT.TINY10) THEN
3075             COF   = PPG(1)/(SID*PGTOT)
3076             SIF   = PPG(2)/(SID*PGTOT)
3077             ANORF = SQRT(COF*COF+SIF*SIF)
3078             COF   = COF/ANORF
3079             SIF   = SIF/ANORF
3080          ENDIF
3081
3082          IF (IXSTBL.EQ.0) THEN
3083 *  change to photon projectile
3084             IJPROJ = 7
3085 *  set virtuality
3086             VIRT = Q2
3087 *  re-initialize LTs with new kinematics
3088 *  !!PGAMM ist set in cms (ECMGN) along z
3089             EPN = ZERO
3090             PPN = ZERO
3091             CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,ECMGN,0)
3092 *  force Lab-system
3093             IFRAME = 1
3094 *  get emulsion component if requested
3095             IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
3096 *  convolute with cross section
3097             CALL DT_SIGGAT(Q2LOW,EGNXX,STOTX,KKMAT)
3098             CALL DT_SIGGAT(Q2,ECMGN,STOT,KKMAT)
3099             IF (STOTX.LT.STOT) WRITE(LOUT,'(1X,A,/,6E12.3)')
3100      &         'LAEVT: warning STOTX<STOT ! ',Q2LOW,EGNMAX,STOTX,
3101      &                                        Q2,ECMGN,STOT
3102             IF (DT_RNDM(Q2)*STOTX.GT.STOT) GOTO 100
3103             NC1 = NC1+1
3104             CALL DT_FILHGR(    Q2,ONE,IHFLQ1,NC1)
3105             CALL DT_FILHGR(    YY,ONE,IHFLY1,NC1)
3106             CALL DT_FILHGR(   XBJ,ONE,IHFLX1,NC1)
3107             CALL DT_FILHGR(PPG(4),ONE,IHFLU1,NC1)
3108             CALL DT_FILHGR( ECMGN,ONE,IHFLE1,NC1)
3109 *  composite targets only
3110             KKMAT = -KKMAT
3111 *  sample this event
3112             CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IJPROJ,EPN,KKMAT,
3113      &                                                            IREJ)
3114 *  rotate momenta of final state particles back in photon-nucleon syst.
3115             DO 4 I=NPOINT(4),NHKK
3116                IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
3117      &                                      (ISTHKK(I).EQ.1001)) THEN
3118                   PX = PHKK(1,I)
3119                   PY = PHKK(2,I)
3120                   PZ = PHKK(3,I)
3121                   CALL DT_MYTRAN(1,PX,PY,PZ,COD,SID,COF,SIF,
3122      &                        PHKK(1,I),PHKK(2,I),PHKK(3,I))
3123                ENDIF
3124     4       CONTINUE
3125          ENDIF
3126
3127          CALL DT_FILHGR(    Q2,ONE,IHFLQ2,NC1)
3128          CALL DT_FILHGR(    YY,ONE,IHFLY2,NC1)
3129          CALL DT_FILHGR(   XBJ,ONE,IHFLX2,NC1)
3130          CALL DT_FILHGR(PPG(4),ONE,IHFLU2,NC1)
3131          CALL DT_FILHGR( ECMGN,ONE,IHFLE2,NC1)
3132
3133 *  dump this event to histograms
3134          CALL PHO_PHIST(2000,DUM)
3135
3136     2 CONTINUE
3137
3138       WGY    = ALPHEM/TWOPI*WGHMAX*DBLE(ITRY)/DBLE(ITRW)
3139       WGY    = WGY*LOG(YMAX/YMIN)
3140       WEIGHT = WGY*SIGMAX*DBLE(NEVTS)/DBLE(ITRY)
3141
3142 C     HEADER = ' LAEVT:  Q^2 distribution 0'
3143 C     CALL DT_OUTHGR(IHFLQ0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3144 C     HEADER = ' LAEVT:  Q^2 distribution 1'
3145 C     CALL DT_OUTHGR(IHFLQ1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3146 C     HEADER = ' LAEVT:  Q^2 distribution 2'
3147 C     CALL DT_OUTHGR(IHFLQ2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3148 C     HEADER = ' LAEVT:  y   distribution 0'
3149 C     CALL DT_OUTHGR(IHFLY0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3150 C     HEADER = ' LAEVT:  y   distribution 1'
3151 C     CALL DT_OUTHGR(IHFLY1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3152 C     HEADER = ' LAEVT:  y   distribution 2'
3153 C     CALL DT_OUTHGR(IHFLY2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3154 C     HEADER = ' LAEVT:  x   distribution 0'
3155 C     CALL DT_OUTHGR(IHFLX0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3156 C     HEADER = ' LAEVT:  x   distribution 1'
3157 C     CALL DT_OUTHGR(IHFLX1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3158 C     HEADER = ' LAEVT:  x   distribution 2'
3159 C     CALL DT_OUTHGR(IHFLX2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3160 C     HEADER = ' LAEVT:  E_g distribution 0'
3161 C     CALL DT_OUTHGR(IHFLU0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3162 C     HEADER = ' LAEVT:  E_g distribution 1'
3163 C     CALL DT_OUTHGR(IHFLU1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3164 C     HEADER = ' LAEVT:  E_g distribution 2'
3165 C     CALL DT_OUTHGR(IHFLU2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3166 C     HEADER = ' LAEVT:  E_c distribution 0'
3167 C     CALL DT_OUTHGR(IHFLE0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3168 C     HEADER = ' LAEVT:  E_c distribution 1'
3169 C     CALL DT_OUTHGR(IHFLE1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3170 C     HEADER = ' LAEVT:  E_c distribution 2'
3171 C     CALL DT_OUTHGR(IHFLE2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3172
3173 * print run-statistics and histograms to output-unit 6
3174       CALL PHO_PHIST(3000,DUM)
3175       IF (IXSTBL.EQ.0) CALL DT_STATIS(2)
3176
3177       RETURN
3178       END
3179
3180 *$ CREATE DT_DTUINI.FOR
3181 *COPY DT_DTUINI
3182 *
3183 *===dtuini=============================================================*
3184 *
3185       SUBROUTINE DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
3186      &                                               IDP,IEMU)
3187
3188       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3189       SAVE
3190
3191       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
3192 * emulsion treatment
3193       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
3194      &                NCOMPO,IEMUL
3195 * Glauber formalism: flags and parameters for statistics
3196       LOGICAL LPROD
3197       CHARACTER*8 CGLB
3198       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
3199
3200       CALL DT_INIT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IGLAU)
3201       CALL DT_STATIS(1)
3202       CALL PHO_PHIST(1000,DUM)
3203       IF (NCOMPO.LE.0) THEN
3204          CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
3205       ELSE
3206          DO 1 I=1,NCOMPO
3207             CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
3208     1    CONTINUE
3209       ENDIF
3210       IF (IOGLB.NE.100) CALL DT_SIGEMU
3211       IEMU = IEMUL
3212
3213       RETURN
3214       END
3215
3216 *$ CREATE DT_DTUOUT.FOR
3217 *COPY DT_DTUOUT
3218 *
3219 *===dtuout=============================================================*
3220 *
3221       SUBROUTINE DT_DTUOUT
3222
3223       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3224       SAVE
3225
3226       CALL PHO_PHIST(3000,DUM)
3227       CALL DT_STATIS(2)
3228
3229       RETURN
3230       END
3231
3232 *$ CREATE DT_BEAMPR.FOR
3233 *COPY DT_BEAMPR
3234 *
3235 *===beampr=============================================================*
3236 *
3237       SUBROUTINE DT_BEAMPR(WHAT,PLAB,MODE)
3238
3239 ************************************************************************
3240 * Initialization of event generation                                   *
3241 * This version dated  7.4.98  is written by S. Roesler.                *
3242 ************************************************************************
3243
3244       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3245       SAVE
3246
3247       PARAMETER ( LINP = 10 ,
3248      &            LOUT = 6 ,
3249      &            LDAT = 9 )
3250       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3251       PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3252
3253       LOGICAL LBEAM
3254
3255 * event history
3256       PARAMETER (NMXHKK=200000)
3257       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3258      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3259      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3260 * extended event history
3261       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3262      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3263      &                IHIST(2,NMXHKK)
3264 * properties of interacting particles
3265       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3266 * particle properties (BAMJET index convention)
3267       CHARACTER*8  ANAME
3268       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3269      &                IICH(210),IIBAR(210),K1(210),K2(210)
3270 * beam momenta
3271       COMMON /DTBEAM/ P1(4),P2(4)
3272
3273 C     DIMENSION WHAT(6),P1(4),P2(4),P1CMS(4),P2CMS(4)
3274       DIMENSION WHAT(6),P1CMS(4),P2CMS(4)
3275
3276       DATA LBEAM /.FALSE./
3277
3278       GOTO (1,2) MODE
3279
3280     1 CONTINUE
3281
3282       E1  = WHAT(1)
3283       IF (E1.LT.ZERO) E1 = DBLE(IPZ)/DBLE(IP)*ABS(WHAT(1))
3284       E2  = WHAT(2)
3285       IF (E2.LT.ZERO) E2 = DBLE(ITZ)/DBLE(IT)*ABS(WHAT(2))
3286       PP1 = SQRT( (E1+AAM(IJPROJ))*(E1-AAM(IJPROJ)) )
3287       PP2 = SQRT( (E2+AAM(IJTARG))*(E2-AAM(IJTARG)) )
3288       TH  = 1.D-6*WHAT(3)/2.D0
3289       PH  = WHAT(4)*BOG
3290       P1(1) = PP1*SIN(TH)*COS(PH)
3291       P1(2) = PP1*SIN(TH)*SIN(PH)
3292       P1(3) = PP1*COS(TH)
3293       P1(4) = E1
3294       P2(1) = PP2*SIN(TH)*COS(PH)
3295       P2(2) = PP2*SIN(TH)*SIN(PH)
3296       P2(3) = -PP2*COS(TH)
3297       P2(4) = E2
3298       ECM  = SQRT( (P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
3299      &                                              -(P1(3)+P2(3))**2 )
3300       ELAB = (ECM**2-AAM(IJPROJ)**2-AAM(IJTARG)**2)/(2.0D0*AAM(IJTARG))
3301       PLAB = SQRT( (ELAB+AAM(IJPROJ))*(ELAB-AAM(IJPROJ)) )
3302       BGX  = (P1(1)+P2(1))/ECM
3303       BGY  = (P1(2)+P2(2))/ECM
3304       BGZ  = (P1(3)+P2(3))/ECM
3305       BGE  = (P1(4)+P2(4))/ECM
3306       CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P1(1),P1(2),P1(3),P1(4),
3307      &            P1TOT,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4))
3308       CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P2(1),P2(2),P2(3),P2(4),
3309      &            P2TOT,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4))
3310       COD = P1CMS(3)/P1TOT
3311 C     SID = SQRT((ONE-COD)*(ONE+COD))
3312       PPT = SQRT(P1CMS(1)**2+P1CMS(2)**2)
3313       SID = PPT/P1TOT
3314       COF = ONE
3315       SIF = ZERO
3316       IF (P1TOT*SID.GT.TINY10) THEN
3317          COF   = P1CMS(1)/(SID*P1TOT)
3318          SIF   = P1CMS(2)/(SID*P1TOT)
3319          ANORF = SQRT(COF*COF+SIF*SIF)
3320          COF   = COF/ANORF
3321          SIF   = SIF/ANORF
3322       ENDIF
3323 **check
3324 C     WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3325 C     WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3326 C     WRITE(LOUT,'(5E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),P1TOT
3327 C     WRITE(LOUT,'(5E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),P2TOT
3328 C     PAX = ZERO
3329 C     PAY = ZERO
3330 C     PAZ = P1TOT
3331 C     PAE = SQRT(AAM(IJPROJ)**2+PAZ**2)
3332 C     PBX = ZERO
3333 C     PBY = ZERO
3334 C     PBZ = -P2TOT
3335 C     PBE = SQRT(AAM(IJTARG)**2+PBZ**2)
3336 C     WRITE(LOUT,'(4E15.4)') PAX,PAY,PAZ,PAE
3337 C     WRITE(LOUT,'(4E15.4)') PBX,PBY,PBZ,PBE
3338 C     CALL DT_MYTRAN(1,PAX,PAY,PAZ,COD,SID,COF,SIF,
3339 C    &            P1CMS(1),P1CMS(2),P1CMS(3))
3340 C     CALL DT_MYTRAN(1,PBX,PBY,PBZ,COD,SID,COF,SIF,
3341 C    &            P2CMS(1),P2CMS(2),P2CMS(3))
3342 C     WRITE(LOUT,'(4E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4)
3343 C     WRITE(LOUT,'(4E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4)
3344 C     CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),
3345 C    &            P1TOT,P1(1),P1(2),P1(3),P1(4))
3346 C     CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),
3347 C    &            P2TOT,P2(1),P2(2),P2(3),P2(4))
3348 C     WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3349 C     WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3350 C     STOP
3351 **
3352
3353       LBEAM = .TRUE.
3354
3355       RETURN
3356
3357     2 CONTINUE
3358
3359       IF (LBEAM) THEN
3360          IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3361          DO 20 I=NPOINT(4),NHKK
3362             IF ((ABS(ISTHKK(I)).EQ.1)  .OR.
3363      &           (ABS(ISTHKK(I)).EQ.2) .OR.
3364      &           (ISTHKK(I).EQ.1000)   .OR.
3365      &           (ISTHKK(I).EQ.1001)) THEN
3366
3367                CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I),
3368      &                     COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS)
3369                PECMS = PHKK(4,I)
3370                CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS,
3371      &                     PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I))
3372             ENDIF
3373    20    CONTINUE
3374       ELSE
3375          MODE = -1
3376       ENDIF
3377
3378       RETURN
3379       END
3380
3381 *$ CREATE DT_REJUCO.FOR
3382 *COPY DT_REJUCO
3383 *
3384 *===rejuco=============================================================*
3385 *
3386       SUBROUTINE DT_REJUCO(MODE,IREJ)
3387
3388 ************************************************************************
3389 * REJection of Unphysical COnfigurations                               *
3390 *     MODE = 1  rejection of particles with unphysically large energy  *
3391 *                                                                      *
3392 * This version dated 27.12.2006 is written by S. Roesler.              *
3393 ************************************************************************
3394
3395       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3396       SAVE
3397
3398       PARAMETER ( LINP = 10 ,
3399      &            LOUT = 6 ,
3400      &            LDAT = 9 )
3401       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3402       PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3403
3404 * maximum x_cms of final state particle
3405       PARAMETER (XCMSMX = 1.4D0)
3406
3407 * event history
3408       PARAMETER (NMXHKK=200000)
3409       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3410      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3411      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3412 * extended event history
3413       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3414      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3415      &                IHIST(2,NMXHKK)
3416 * Lorentz-parameters of the current interaction
3417       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
3418      &                UMO,PPCM,EPROJ,PPROJ
3419
3420       IREJ = 0
3421
3422       IF (MODE.EQ.1) THEN
3423          IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3424          ECMHLF = UMO/2.0D0
3425          DO 10 I=NPOINT(4),NHKK
3426             IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDHKK(I).NE.80000)) THEN
3427                XCMS = ABS(PHKK(4,I))/ECMHLF
3428                IF (XCMS.GT.XCMSMX) GOTO 9999
3429             ENDIF
3430    10    CONTINUE
3431       ENDIF
3432
3433       RETURN
3434  9999 CONTINUE
3435       IREJ = 1
3436       RETURN
3437       END
3438
3439 *$ CREATE DT_EVENTB.FOR
3440 *COPY DT_EVENTB
3441 *
3442 *===eventb=============================================================*
3443 *
3444       SUBROUTINE DT_EVENTB(NCSY,IREJ)
3445
3446 ************************************************************************
3447 * Treatment of nucleon-nucleon interactions with full two-component    *
3448 * Dual Parton Model.                                                   *
3449 *          NCSY     number of nucleon-nucleon interactions             *
3450 *          IREJ     rejection flag                                     *
3451 * This version dated 14.01.2000 is written by S. Roesler               *
3452 ************************************************************************
3453
3454       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3455       SAVE
3456       PARAMETER ( LINP = 10 ,
3457      &            LOUT = 6 ,
3458      &            LDAT = 9 )
3459       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
3460
3461 * event history
3462       PARAMETER (NMXHKK=200000)
3463       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3464      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3465      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3466 * extended event history
3467       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3468      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3469      &                IHIST(2,NMXHKK)
3470 *! uncomment this line for internal phojet-fragmentation
3471 C #include "dtu_dtevtp.inc"
3472 * particle properties (BAMJET index convention)
3473       CHARACTER*8  ANAME
3474       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3475      &                IICH(210),IIBAR(210),K1(210),K2(210)
3476 * flags for input different options
3477       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
3478       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
3479      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
3480 * rejection counter
3481       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
3482      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
3483      &                IREXCI(3),IRDIFF(2),IRINC
3484 * properties of interacting particles
3485       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3486 * properties of photon/lepton projectiles
3487       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
3488 * various options for treatment of partons (DTUNUC 1.x)
3489 * (chain recombination, Cronin,..)
3490       LOGICAL LCO2CR,LINTPT
3491       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
3492      &                LCO2CR,LINTPT
3493 * statistics
3494       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
3495      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
3496      &                ICEVTG(8,0:30)
3497 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
3498       COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
3499 * Glauber formalism: collision properties
3500       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
3501      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
3502 * flags for diffractive interactions (DTUNUC 1.x)
3503       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
3504 * statistics: double-Pomeron exchange
3505       COMMON /DTFLG2/ INTFLG,IPOPO
3506 * flags for particle decays
3507       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
3508      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
3509      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
3510 * nucleon-nucleon event-generator
3511       CHARACTER*8 CMODEL
3512       LOGICAL LPHOIN
3513       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
3514 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
3515       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
3516       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
3517       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
3518      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
3519 C  model switches and parameters
3520       CHARACTER*8 MDLNA
3521       INTEGER ISWMDL,IPAMDL
3522       DOUBLE PRECISION PARMDL
3523       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3524 C  initial state parton radiation (internal part)
3525       INTEGER MXISR3,MXISR4
3526       PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
3527       INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
3528       DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
3529       COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
3530      &                ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
3531      &                IFL1(2,MXISR3),IFL2(2,MXISR3),
3532      &                IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
3533 C  event debugging information
3534       INTEGER NMAXD
3535       PARAMETER (NMAXD=100)
3536       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3537      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3538       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3539      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3540 C  general process information
3541       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3542       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3543
3544       DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4),
3545      &          PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4),
3546      &          PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4),
3547      &          KPRON(15),ISINGL(2000)
3548
3549 * initial values for max. number of phojet scatterings and dtunuc chains
3550 * to be fragmented with one pyexec call
3551       DATA MXPHFR,MXDTFR /10,100/
3552
3553       IREJ      = 0
3554 * pointer to first parton of the first chain in dtevt common
3555       NPOINT(3) = NHKK+1
3556 * special flag for double-Pomeron statistics
3557       IPOPO = 1
3558 * counter for low-mass (DTUNUC) interactions
3559       NDTUSC = 0
3560 * counter for interactions treated by PHOJET
3561       NPHOSC = 0
3562
3563 * scan interactions for single nucleon-nucleon interactions
3564 * (this has to be checked here because Cronin modifies parton momenta)
3565       NC = NPOINT(2)
3566       IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! '
3567       DO 8 I=1,NCSY
3568          ISINGL(I) = 0
3569          MOP = JMOHKK(1,NC)
3570          MOT = JMOHKK(1,NC+1)
3571          DIFF1 = ABS(PHKK(4,MOP)-PHKK(4,  NC)-PHKK(4,NC+2))
3572          DIFF2 = ABS(PHKK(4,MOT)-PHKK(4,NC+1)-PHKK(4,NC+3))
3573          IF ((DIFF1.LT.TINY10).AND.(DIFF2.LT.TINY10)) ISINGL(I) = 1
3574          NC = NC+4
3575     8 CONTINUE
3576
3577 * multiple scattering of chain ends
3578       IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
3579       IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
3580
3581 * switch to PHOJET-settings for JETSET parameter
3582       CALL DT_INITJS(1)
3583
3584 * loop over nucleon-nucleon interaction
3585       NC = NPOINT(2)
3586       DO 2 I=1,NCSY
3587 *
3588 *   pick up one nucleon-nucleon interaction from DTEVT1
3589 *     ppnn  / ptnn   - momenta of the interacting nucleons (cms)
3590 *     ptotnn         - total momentum of the interacting nucleons (cms)
3591 *     pp1,2 / pt1,2  - momenta of the four partons
3592 *     pp    / pt     - total momenta of the proj / targ partons
3593 *     ptot           - total momentum of the four partons
3594          MOP = JMOHKK(1,NC)
3595          MOT = JMOHKK(1,NC+1)
3596          DO 3 K=1,4
3597             PPNN(K)   = PHKK(K,MOP)
3598             PTNN(K)   = PHKK(K,MOT)
3599             PTOTNN(K) = PPNN(K)+PTNN(K)
3600             PP1(K)    = PHKK(K,NC)
3601             PT1(K)    = PHKK(K,NC+1)
3602             PP2(K)    = PHKK(K,NC+2)
3603             PT2(K)    = PHKK(K,NC+3)
3604             PP(K)     = PP1(K)+PP2(K)
3605             PT(K)     = PT1(K)+PT2(K)
3606             PTOT(K)   = PP(K)+PT(K)
3607     3    CONTINUE
3608 *
3609 *-----------------------------------------------------------------------
3610 *   this is a complete nucleon-nucleon interaction
3611 *
3612          IF (ISINGL(I).EQ.1) THEN
3613 *
3614 *     initialize PHOJET-variables for remnant/valence-partons
3615             IHFLD(1,1) = 0
3616             IHFLD(1,2) = 0
3617             IHFLD(2,1) = 0
3618             IHFLD(2,2) = 0
3619             IHFLS(1) = 1
3620             IHFLS(2) = 1
3621 *     save current settings of PHOJET process and min. bias flags
3622             DO 9 K=1,11
3623                KPRON(K) = IPRON(K,1)
3624     9       CONTINUE
3625             ISWSAV   = ISWMDL(2)
3626 *
3627 *     check if forced sampling of diffractive interaction requested
3628             IF (ISINGD.LT.-1) THEN
3629                DO 90 K=1,11
3630                   IPRON(K,1) = 0
3631    90          CONTINUE
3632                IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-3)) IPRON(5,1) = 1
3633                IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-4)) IPRON(6,1) = 1
3634                IF (ISINGD.EQ.-5) IPRON(4,1) = 1
3635             ENDIF
3636 *
3637 *     for photons: a direct/anomalous interaction is not sampled
3638 *     in PHOJET but already in Glauber-formalism. Here we check if such
3639 *     an interaction is requested
3640             IF (IJPROJ.EQ.7) THEN
3641 *       first switch off direct interactions
3642                IPRON(8,1) = 0
3643 *       this is a direct interactions
3644                IF (IDIREC.EQ.1) THEN
3645                   DO 12 K=1,11
3646                      IPRON(K,1) = 0
3647    12             CONTINUE
3648                   IPRON(8,1) = 1
3649 *       this is an anomalous interactions
3650 *         (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) )
3651                ELSEIF (IDIREC.EQ.2) THEN
3652                   ISWMDL(2) = 0
3653                ENDIF
3654             ELSE
3655                IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! '
3656             ENDIF
3657 *
3658 *     make sure that total momenta of partons, pp and pt, are on mass
3659 *     shell (Cronin may have srewed this up..)
3660             CALL DT_MASHEL(PP,PT,PHKK(5,MOP),PHKK(5,MOT),PPNN,PTNN,IR1)
3661             IF (IR1.NE.0) THEN
3662                IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)')
3663      &              'EVENTB:  mass shell correction rejected'
3664                GOTO 9999
3665             ENDIF
3666 *
3667 *     initialize the incoming particles in PHOJET
3668             IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3669                CALL PHO_SETPAR(1,22,0,VIRT)
3670             ELSE
3671                CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO)
3672             ENDIF
3673             CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO)
3674 *
3675 *     initialize rejection loop counter for anomalous processes
3676             IRJANO = 0
3677   800       CONTINUE
3678             IRJANO = IRJANO+1
3679 *
3680 *     temporary fix for ifano problem
3681             IFANO(1) = 0
3682             IFANO(2) = 0
3683 *
3684 *     generate complete hadron/nucleon/photon-nucleon event with PHOJET
3685             CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1)
3686 *
3687 *     for photons: special consistency check for anomalous interactions
3688             IF (IJPROJ.EQ.7) THEN
3689                IF (IRJANO.LT.30) THEN
3690                   IF (IFANO(1).NE.0) THEN
3691 *       here, an anomalous interaction was generated. Check if it
3692 *       was also requested. Otherwise reject this event.
3693                      IF (IDIREC.EQ.0) GOTO 800
3694                   ELSE
3695 *       here, an anomalous interaction was not generated. Check if it
3696 *       was requested in which case we need to reject this event.
3697                      IF (IDIREC.EQ.2) GOTO 800
3698                   ENDIF
3699                ELSE
3700                   WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ',
3701      &                          IRJANO,IDIREC,NEVHKK
3702                ENDIF
3703             ENDIF
3704 *
3705 *     copy back original settings of PHOJET process and min. bias flags
3706             DO 10 K=1,11
3707                IPRON(K,1) = KPRON(K)
3708    10       CONTINUE
3709             ISWMDL(2) = ISWSAV
3710 *
3711 *     check if PHOJET has rejected this event
3712             IF (IREJ1.NE.0) THEN
3713 C              IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3714                WRITE(LOUT,'(1X,A,I4)')
3715      &            'EVENTB:  chain system rejected',IDIREC
3716                CALL PHO_PREVNT(0)
3717                GOTO 9999
3718             ENDIF
3719 *
3720 *     copy partons and strings from PHOJET common back into DTEVT for
3721 *     external fragmentation
3722             MO1 = NC
3723             MO2 = NC+3
3724 *!      uncomment this line for internal phojet-fragmentation
3725 C           CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1)
3726             NPHOSC = NPHOSC+1
3727             CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1)
3728             IF (IREJ1.NE.0) THEN
3729                IF (IOULEV(1).GT.0)
3730      &         WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1'
3731                GOTO 9999
3732             ENDIF
3733 *
3734 *     update statistics counter
3735             ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1
3736 *
3737 *-----------------------------------------------------------------------
3738 *   this interaction involves "remnants"
3739 *
3740          ELSE
3741 *
3742 *     total mass of this system
3743             PPTOT  = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2)
3744             AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT)
3745             IF (AMTOT2.LT.ZERO) THEN
3746                AMTOT = ZERO
3747             ELSE
3748                AMTOT = SQRT(AMTOT2)
3749             ENDIF
3750 *
3751 *     systems with masses larger than elojet are treated with PHOJET
3752             IF (AMTOT.GT.ELOJET) THEN
3753 *
3754 *     initialize PHOJET-variables for remnant/valence-partons
3755 *       projectile parton flavors and valence flag
3756                IHFLD(1,1) = IDHKK(NC)
3757                IHFLD(1,2) = IDHKK(NC+2)
3758                IHFLS(1)   = 0
3759                IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7)
3760      &                            .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1
3761 *       target parton flavors and valence flag
3762                IHFLD(2,1) = IDHKK(NC+1)
3763                IHFLD(2,2) = IDHKK(NC+3)
3764                IHFLS(2)   = 0
3765                IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5)
3766      &                            .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1
3767 *       flag signalizing PHOJET how to treat the remnant:
3768 *         iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld
3769 *         iremn > -1 valence remnant: PHOJET assumes flavors according
3770 *                    to mother particle
3771                IREMN1 = IHFLS(1)-1
3772                IREMN2 = IHFLS(2)-1
3773 *
3774 *     initialize the incoming particles in PHOJET
3775                IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3776                   CALL PHO_SETPAR(1,22,IREMN1,VIRT)
3777                ELSE
3778                   CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO)
3779                ENDIF
3780                CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO)
3781 *
3782 *     calculate Lorentz parameter of the nucleon-nucleon cm-system
3783                PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2)
3784                AMNN   = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) )
3785                BGX    = PTOTNN(1)/AMNN
3786                BGY    = PTOTNN(2)/AMNN
3787                BGZ    = PTOTNN(3)/AMNN
3788                GAM    = PTOTNN(4)/AMNN
3789 *     transform interacting nucleons into nucleon-nucleon cm-system
3790                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3791      &                     PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS,
3792      &                     PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4))
3793                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3794      &                     PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS,
3795      &                     PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4))
3796 *     transform (total) momenta of the proj and targ partons into
3797 *     nucleon-nucleon cm-system
3798                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3799      &                     PP(1),PP(2),PP(3),PP(4),
3800      &                     PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4))
3801                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3802      &                     PT(1),PT(2),PT(3),PT(4),
3803      &                     PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4))
3804 *     energy fractions of the proj and targ partons
3805                XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE)
3806                XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE)
3807 ***
3808 * testprint
3809 c              PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
3810 c    &                        (PPTCMS(2)+PTTCMS(2))**2 +
3811 c    &                        (PPTCMS(3)+PTTCMS(3))**2 )
3812 c              EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
3813 c    &                        (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
3814 c              PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
3815 c    &                        (PPSUB(2)+PTSUB(2))**2 +
3816 c    &                        (PPSUB(3)+PTSUB(3))**2 )
3817 c              EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
3818 c    &                        (PPSUB(4)+PTSUB(4)+PTOTSU) )
3819 ***
3820 *
3821 *     save current settings of PHOJET process and min. bias flags
3822                DO 7 K=1,11
3823                   KPRON(K) = IPRON(K,1)
3824     7          CONTINUE
3825 *     disallow direct photon int. (does not make sense here anyway)
3826                IPRON(8,1) = 0
3827 *     disallow double pomeron processes (due to technical problems
3828 *     in PHOJET, needs to be solved sometime)
3829                IPRON(4,1) = 0
3830 *     disallow diffraction for sea-diquarks
3831                IF ((IABS(IHFLD(1,1)).GT.1100).AND.
3832      &             (IABS(IHFLD(1,2)).GT.1100)) THEN
3833                   IPRON(3,1) = 0
3834                   IPRON(6,1) = 0
3835                ENDIF
3836                IF ((IABS(IHFLD(2,1)).GT.1100).AND.
3837      &             (IABS(IHFLD(2,2)).GT.1100)) THEN
3838                   IPRON(3,1) = 0
3839                   IPRON(5,1) = 0
3840                ENDIF
3841 *
3842 *     we need massless partons: transform them on mass shell
3843                XMP = ZERO
3844                XMT = ZERO
3845                DO 6 K=1,4
3846                   PPTMP(K) = PPSUB(K)
3847                   PTTMP(K) = PTSUB(K)
3848     6          CONTINUE
3849                CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1)
3850                PPSUTO  = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2)
3851                PTSUTO  = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2)
3852                PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+
3853      &                  (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2)
3854 *     total energy of the subsysten after mass transformation
3855 *      (should be the same as before..)
3856                SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)*
3857      &                      (PPSUB(4)+PTSUB(4)+PSUTOT) )
3858 *
3859 *     after mass shell transformation the x_sub - relation has to be
3860 *     corrected. We therefore create "pseudo-momenta" of mother-nucleons.
3861 *
3862 *     The old version was to scale based on the original x_sub and the
3863 *     4-momenta of the subsystem. At very high energy this could lead to
3864 *     "pseudo-cm energies" of the parent system considerably exceeding
3865 *     the true cm energy. Now we keep the true cm energy and calculate
3866 *     new x_sub instead.
3867 C old version  PPTCMS(4) = PPSUB(4)/XPSUB
3868                PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4))
3869                XPSUB = PPSUB(4)/PPTCMS(4)
3870                IF (IJPROJ.EQ.7) THEN
3871                   AMP2  = PHKK(5,MOT)**2
3872                   PTOT1 = SQRT(PPTCMS(4)**2-AMP2)
3873                ELSE
3874 *???????
3875                   PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP))
3876      &                        *(PPTCMS(4)+PHKK(5,MOP)))
3877 C                 PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT))
3878 C    &                        *(PPTCMS(4)+PHKK(5,MOT)))
3879                ENDIF
3880 C old version  PTTCMS(4) = PTSUB(4)/XTSUB
3881                PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4))
3882                XTSUB = PTSUB(4)/PTTCMS(4)
3883                PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT))
3884      &                     *(PTTCMS(4)+PHKK(5,MOT)))
3885                DO 4 K=1,3
3886                   PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO
3887                   PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO
3888     4          CONTINUE
3889 ***
3890 * testprint
3891 *
3892 *     ppnn  / ptnn   - momenta of the int. nucleons (cms, negl. Fermi)
3893 *     ptotnn         - total momentum of the int. nucleons (cms, negl. Fermi)
3894 *     pptcms/ pttcms - momenta of the interacting nucleons (cms)
3895 *     pp1,2 / pt1,2  - momenta of the four partons
3896 *
3897 *     pp    / pt     - total momenta of the pr/ta partons (cms, negl. Fermi)
3898 *     ptot           - total momentum of the four partons (cms, negl. Fermi)
3899 *     ppsub / ptsub  - total momenta of the proj / targ partons (cms)
3900 *
3901 c              PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
3902 c    &                        (PPTCMS(2)+PTTCMS(2))**2 +
3903 c    &                        (PPTCMS(3)+PTTCMS(3))**2 )
3904 c              ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
3905 c    &                        (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
3906 c              PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
3907 c    &                        (PPSUB(2)+PTSUB(2))**2 +
3908 c    &                        (PPSUB(3)+PTSUB(3))**2 )
3909 c              ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
3910 c    &                        (PPSUB(4)+PTSUB(4)+PTOTSU) )
3911 c              IF (ENEWCM/EOLDCM.GT.1.1D0) THEN
3912 c                 WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM
3913 c                 WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU
3914 c                 WRITE(*,*) ' XPSUB,  XTSUB  : ',XPSUB,XTSUB
3915 c              ENDIF
3916 c              BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM
3917 c              BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM
3918 c              BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM
3919 c              BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM
3920 *     transform interacting nucleons into nucleon-nucleon cm-system
3921 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3922 c    &                    PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT,
3923 c    &                     PPNEW1,PPNEW2,PPNEW3,PPNEW4)
3924 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3925 c    &                    PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT,
3926 c    &                     PTNEW1,PTNEW2,PTNEW3,PTNEW4)
3927 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3928 c    &                     PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT,
3929 c    &                     PPSUB1,PPSUB2,PPSUB3,PPSUB4)
3930 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3931 c    &                     PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT,
3932 c    &                     PTSUB1,PTSUB2,PTSUB3,PTSUB4)
3933 c              PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 +
3934 c    &                        (PPNEW2+PTNEW2)**2 +
3935 c    &                        (PPNEW3+PTNEW3)**2 )
3936 c              ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) *
3937 c    &                        (PPNEW4+PTNEW4+PTSTCM) )
3938 c              PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 +
3939 c    &                        (PPSUB2+PTSUB2)**2 +
3940 c    &                        (PPSUB3+PTSUB3)**2 )
3941 c              ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) *
3942 c    &                        (PPSUB4+PTSUB4+PTSTSU) )
3943 C              WRITE(*,*) ' mother cmE :'
3944 C              WRITE(*,*) ETSTCM,ENEWCM
3945 C              WRITE(*,*) ' subsystem cmE :'
3946 C              WRITE(*,*) ETSTSU,ENEWSU
3947 C              WRITE(*,*) ' projectile mother :'
3948 C              WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4
3949 C              WRITE(*,*) ' target mother :'
3950 C              WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4
3951 C              WRITE(*,*) ' projectile subsystem:'
3952 C              WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4
3953 C              WRITE(*,*) ' target subsystem:'
3954 C              WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4
3955 C              WRITE(*,*) ' projectile subsystem should be:'
3956 C              WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0,
3957 C    &                    XPSUB*ETSTCM/2.0D0
3958 C              WRITE(*,*) ' target subsystem should be:'
3959 C              WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0,
3960 C    &                    XTSUB*ETSTCM/2.0D0
3961 C              WRITE(*,*) ' subsystem cmE should be: '
3962 C              WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB
3963 ***
3964 *
3965 *     generate complete remnant - nucleon/remnant event with PHOJET
3966                CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1)
3967 *
3968 *     copy back original settings of PHOJET process flags
3969                DO 11 K=1,11
3970                   IPRON(K,1) = KPRON(K)
3971    11          CONTINUE
3972 *
3973 *     check if PHOJET has rejected this event
3974                IF (IREJ1.NE.0) THEN
3975                   IF (IOULEV(1).GT.0)
3976      &            WRITE(LOUT,'(1X,A)') 'EVENTB:  chain system rejected'
3977                   WRITE(LOUT,*)
3978      &                 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT
3979                   CALL PHO_PREVNT(0)
3980                   GOTO 9999
3981                ENDIF
3982 *
3983 *     copy partons and strings from PHOJET common back into DTEVT for
3984 *     external fragmentation
3985                MO1 = NC
3986                MO2 = NC+3
3987 *!      uncomment this line for internal phojet-fragmentation
3988 C              CALL DT_GETFSP(MO1,MO2,PP,PT,1)
3989                NPHOSC = NPHOSC+1
3990                CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1)
3991                IF (IREJ1.NE.0) THEN
3992                   IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3993      &               'EVENTB: chain system rejected 2'
3994                   GOTO 9999
3995                ENDIF
3996 *
3997 *     update statistics counter
3998                ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1
3999 *
4000 *-----------------------------------------------------------------------
4001 * two-chain approx. for smaller systems
4002 *
4003             ELSE
4004 *
4005                NDTUSC = NDTUSC+1
4006 *   special flag for double-Pomeron statistics
4007                IPOPO = 0
4008 *
4009 *   pick up flavors at the ends of the two chains
4010                IFP1 = IDHKK(NC)
4011                IFT1 = IDHKK(NC+1)
4012                IFP2 = IDHKK(NC+2)
4013                IFT2 = IDHKK(NC+3)
4014 *   ..and the indices of the mothers
4015                MOP1 = NC
4016                MOT1 = NC+1
4017                MOP2 = NC+2
4018                MOT2 = NC+3
4019                CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
4020      &                     IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
4021 *
4022 *   check if this chain system was rejected
4023                IF (IREJ1.GT.0) THEN
4024                   IF (IOULEV(1).GT.0) THEN
4025                      WRITE(LOUT,*) 'rejected 1 in EVENTB'
4026                      WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)')
4027      &                  IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT
4028                   ENDIF
4029                   IRHHA = IRHHA+1
4030                   GOTO 9999
4031                ENDIF
4032 *   the following lines are for sea-sea chains rejected in GETCSY
4033                IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1
4034                ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1
4035             ENDIF
4036 *
4037          ENDIF
4038 *
4039 *     update statistics counter
4040          ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1
4041 *
4042          NC = NC+4
4043 *
4044     2 CONTINUE
4045 *
4046 *-----------------------------------------------------------------------
4047 * treatment of low-mass chains (if there are any)
4048 *
4049       IF (NDTUSC.GT.0) THEN
4050 *
4051 *   correct chains of very low masses for possible resonances
4052          IF (IRESCO.EQ.1) THEN
4053             CALL DT_EVTRES(IREJ1)
4054             IF (IREJ1.GT.0) THEN
4055                IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB'
4056                IRRES(1) = IRRES(1)+1
4057                GOTO 9999
4058             ENDIF
4059          ENDIF
4060 *   fragmentation of low-mass chains
4061 *!  uncomment this line for internal phojet-fragmentation
4062 *   (of course it will still be fragmented by DPMJET-routines but it
4063 *    has to be done here instead of further below)
4064 C        CALL DT_EVTFRA(IREJ1)
4065 C        IF (IREJ1.GT.0) THEN
4066 C           IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB'
4067 C           IRFRAG = IRFRAG+1
4068 C           GOTO 9999
4069 C        ENDIF
4070       ELSE
4071 *! uncomment this line for internal phojet-fragmentation
4072 C        NPOINT(4) = NHKK+1
4073          IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
4074       ENDIF
4075 *
4076 *-----------------------------------------------------------------------
4077 * new di-quark breaking mechanisms
4078 *
4079       MXLEFT = 2
4080       CALL DT_CHASTA(0)
4081       IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
4082      &                        .OR.(PDBSEA(3).GT.0.0D0)) THEN
4083          CALL DT_DIQBRK
4084          MXLEFT = 4
4085       ENDIF
4086 *
4087 *-----------------------------------------------------------------------
4088 * hadronize this event
4089 *
4090 *   hadronize PHOJET chain systems
4091       NPYMAX = 0
4092       NPJE   = NPHOSC/MXPHFR
4093       IF (MXPHFR.LT.MXLEFT) MXLEFT = 2
4094       IF (NPJE.GT.1) THEN
4095          NLEFT = NPHOSC-NPJE*MXPHFR
4096          DO 20 JFRG=1,NPJE
4097             NFRG = JFRG*MXPHFR
4098             IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN
4099                CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4100                IF (IREJ1.GT.0) GOTO 22
4101                NLEFT = 0
4102             ELSE
4103                CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1)
4104                IF (IREJ1.GT.0) GOTO 22
4105             ENDIF
4106             IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4107    20    CONTINUE
4108          IF (NLEFT.GT.0) THEN
4109             CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4110             IF (IREJ1.GT.0) GOTO 22
4111             IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4112          ENDIF
4113       ELSE
4114          CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4115          IF (IREJ1.GT.0) GOTO 22
4116          IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4117       ENDIF
4118 *
4119 *   check max. filling level of jetset common and
4120 *   reduce mxphfr if necessary
4121       IF (NPYMAX.GT.3000) THEN
4122          IF (NPYMAX.GT.3500) THEN
4123             MXPHFR = MAX(1,MXPHFR-2)
4124          ELSE
4125             MXPHFR = MAX(1,MXPHFR-1)
4126          ENDIF
4127 C        WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR
4128       ENDIF
4129 *
4130 *   hadronize DTUNUC chain systems
4131    23 CONTINUE
4132       IBACK = MXDTFR
4133       CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2)
4134       IF (IREJ2.GT.0) GOTO 22
4135 *
4136 *   check max. filling level of jetset common and
4137 *   reduce mxdtfr if necessary
4138       IF (NPYMEM.GT.3000) THEN
4139          IF (NPYMEM.GT.3500) THEN
4140             MXDTFR = MAX(1,MXDTFR-20)
4141          ELSE
4142             MXDTFR = MAX(1,MXDTFR-10)
4143          ENDIF
4144 C        WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR
4145       ENDIF
4146 *
4147       IF (IBACK.EQ.-1) GOTO 23
4148 *
4149    22 CONTINUE
4150 C     CALL DT_EVTFRG(1,IREJ1)
4151 C     CALL DT_EVTFRG(2,IREJ2)
4152       IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN
4153          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB'
4154          IRFRAG = IRFRAG+1
4155          GOTO 9999
4156       ENDIF
4157 *
4158 * get final state particles from /DTEVTP/
4159 *! uncomment this line for internal phojet-fragmentation
4160 C     CALL DT_GETFSP(IDUM,IDUM,PP,PT,2)
4161
4162       IF (IJPROJ.NE.7)
4163      &   CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3)
4164 C     IF (IREJ3.NE.0) GOTO 9999
4165
4166       RETURN
4167
4168  9999 CONTINUE
4169       IREVT = IREVT+1
4170       IREJ  = 1
4171       RETURN
4172       END
4173
4174 *$ CREATE DT_GETPJE.FOR
4175 *COPY DT_GETPJE
4176 *
4177 *===getpje=============================================================*
4178 *
4179       SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ)
4180
4181 ************************************************************************
4182 * This subroutine copies PHOJET partons and strings from POEVT1 into   *
4183 * DTEVT1.                                                              *
4184 *      MO1,MO2   indices of first and last mother-parton in DTEVT1     *
4185 *      PP,PT     4-momenta of projectile/target being handled by       *
4186 *                PHOJET                                                *
4187 * This version dated 11.12.99 is written by S. Roesler                 *
4188 ************************************************************************
4189
4190       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4191       SAVE
4192       PARAMETER ( LINP = 10 ,
4193      &            LOUT = 6 ,
4194      &            LDAT = 9 )
4195       PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1,
4196      &           ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0)
4197
4198       LOGICAL LFLIP
4199
4200 * event history
4201       PARAMETER (NMXHKK=200000)
4202       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4203      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4204      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4205 * extended event history
4206       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4207      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4208      &                IHIST(2,NMXHKK)
4209 * Lorentz-parameters of the current interaction
4210       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4211      &                UMO,PPCM,EPROJ,PPROJ
4212 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
4213       COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
4214 * flags for input different options
4215       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4216       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4217      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4218 * statistics: double-Pomeron exchange
4219       COMMON /DTFLG2/ INTFLG,IPOPO
4220 * statistics
4221       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
4222      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
4223      &                ICEVTG(8,0:30)
4224 * rejection counter
4225       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
4226      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
4227      &                IREXCI(3),IRDIFF(2),IRINC
4228 C  standard particle data interface
4229       INTEGER NMXHEP
4230       PARAMETER (NMXHEP=4000)
4231       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
4232       DOUBLE PRECISION PHEP,VHEP
4233       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
4234      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
4235      &                VHEP(4,NMXHEP), NSD1, NSD2, NDD
4236 C  extension to standard particle data interface (PHOJET specific)
4237       INTEGER IMPART,IPHIST,ICOLOR
4238       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
4239 C  color string configurations including collapsed strings and hadrons
4240       INTEGER MSTR
4241       PARAMETER (MSTR=500)
4242       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
4243       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
4244      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
4245      &                NNCH(MSTR),IBHAD(MSTR),ISTR
4246 C  general process information
4247       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4248       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4249 C  model switches and parameters
4250       CHARACTER*8 MDLNA
4251       INTEGER ISWMDL,IPAMDL
4252       DOUBLE PRECISION PARMDL
4253       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4254 C  event debugging information
4255       INTEGER NMAXD
4256       PARAMETER (NMAXD=100)
4257       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4258      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4259       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4260      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4261
4262       DIMENSION PP(4),PT(4)
4263       DATA MAXLOP /10000/
4264
4265       INHKK = NHKK
4266       LFLIP = .TRUE.
4267     1 CONTINUE
4268       NPVAL = 0
4269       NTVAL = 0
4270       IREJ  = 0
4271
4272 *   store initial momenta for energy-momentum conservation check
4273       IF (LEMCCK) THEN
4274          CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2)
4275          CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2)
4276       ENDIF
4277 * copy partons and strings from POEVT1 into DTEVT1
4278       DO 11 I=1,ISTR
4279 C        IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN
4280          IF (NCODE(I).EQ.-99) THEN
4281             IDXSTG = NPOS(1,I)
4282             IDSTG  = IDHEP(IDXSTG)
4283             PX = PHEP(1,IDXSTG)
4284             PY = PHEP(2,IDXSTG)
4285             PZ = PHEP(3,IDXSTG)
4286             PE = PHEP(4,IDXSTG)
4287             IF (MODE.LT.0) THEN
4288                ISTAT = 70000+IPJE
4289                CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE,
4290      &                        11,IDSTG,0)
4291                IF (LEMCCK) THEN
4292                   PX = -PX
4293                   PY = -PY
4294                   PZ = -PZ
4295                   PE = -PE
4296                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4297                ENDIF
4298             ELSE
4299                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4300      &                        PPX,PPY,PPZ,PPE)
4301                ISTAT = 70000+IPJE
4302                CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE,
4303      &                        11,IDSTG,0)
4304                IF (LEMCCK) THEN
4305                   PX = -PPX
4306                   PY = -PPY
4307                   PZ = -PPZ
4308                   PE = -PPE
4309                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4310                ENDIF
4311             ENDIF
4312             NOBAM(NHKK)   = 0
4313             IHIST(1,NHKK) = IPHIST(1,IDXSTG)
4314             IHIST(2,NHKK) = 0
4315          ELSEIF (NCODE(I).GE.0) THEN
4316 *   indices of partons and string in POEVT1
4317             IDX1 = ABS(JMOHEP(1,NPOS(1,I)))
4318             IDX2 = ABS(JMOHEP(2,NPOS(1,I)))
4319             IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN
4320                WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2,
4321      &         ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! '
4322                STOP ' GETPJE 1'
4323             ENDIF
4324             IDXSTG = NPOS(1,I)
4325 *   find "mother" string of the string
4326             IDXMS1 = ABS(JMOHEP(1,IDX1))
4327             IDXMS2 = ABS(JMOHEP(1,IDX2))
4328             IF (IDXMS1.NE.IDXMS2) THEN
4329                IDXMS1 = IDXSTG
4330                IDXMS2 = IDXSTG
4331 C              STOP ' GETPJE: IDXMS1.NE.IDXMS2 !'
4332             ENDIF
4333 *   search POEVT1 for the original hadron of the parton
4334             ILOOP = 0
4335             IPOM1 = 0
4336    14       CONTINUE
4337             ILOOP = ILOOP+1
4338             IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1
4339             IDXMS1 = ABS(JMOHEP(1,IDXMS1))
4340             IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND.
4341      &          (ILOOP.LT.MAXLOP)) GOTO 14
4342             IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! '
4343             IPOM2 = 0
4344             ILOOP = 0
4345    15       CONTINUE
4346             ILOOP = ILOOP+1
4347             IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1
4348             IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN
4349                IDXMS2 = ABS(JMOHEP(2,IDXMS2))
4350             ELSE
4351                IDXMS2 = ABS(JMOHEP(1,IDXMS2))
4352             ENDIF
4353             IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND.
4354      &          (ILOOP.LT.MAXLOP)) GOTO 15
4355             IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! '
4356 *   parton 1
4357             IF (IDXMS1.EQ.1) THEN
4358                ISPTN1 = ISTHKK(MO1)
4359                M1PTN1 = MO1
4360                M2PTN1 = MO1+2
4361             ELSE
4362                ISPTN1 = ISTHKK(MO2)
4363                M1PTN1 = MO2-2
4364                M2PTN1 = MO2
4365             ENDIF
4366 *   parton 2
4367             IF (IDXMS2.EQ.1) THEN
4368                ISPTN2 = ISTHKK(MO1)
4369                M1PTN2 = MO1
4370                M2PTN2 = MO1+2
4371             ELSE
4372                ISPTN2 = ISTHKK(MO2)
4373                M1PTN2 = MO2-2
4374                M2PTN2 = MO2
4375             ENDIF
4376 *   check for mis-identified mothers and switch mother indices if necessary
4377             IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6)
4378      &          .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND.
4379      &          (LFLIP)) THEN
4380                IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN
4381                   ISPTN1 = ISTHKK(MO1)
4382                   M1PTN1 = MO1
4383                   M2PTN1 = MO1+2
4384                   ISPTN2 = ISTHKK(MO2)
4385                   M1PTN2 = MO2-2
4386                   M2PTN2 = MO2
4387                ELSE
4388                   ISPTN1 = ISTHKK(MO2)
4389                   M1PTN1 = MO2-2
4390                   M2PTN1 = MO2
4391                   ISPTN2 = ISTHKK(MO1)
4392                   M1PTN2 = MO1
4393                   M2PTN2 = MO1+2
4394                ENDIF
4395             ENDIF
4396 *   register partons in temporary common
4397 *     parton at chain end
4398             PX = PHEP(1,IDX1)
4399             PY = PHEP(2,IDX1)
4400             PZ = PHEP(3,IDX1)
4401             PE = PHEP(4,IDX1)
4402 * flag only partons coming from Pomeron with 41/42
4403 C           IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4404             IF (IPOM1.NE.0) THEN
4405                ISTX = ABS(ISPTN1)/10
4406                IMO  = ABS(ISPTN1)-10*ISTX
4407                ISPTN1 = -(40+IMO)
4408             ELSE
4409                IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN
4410                   ISTX = ABS(ISPTN1)/10
4411                   IMO  = ABS(ISPTN1)-10*ISTX
4412                   IF ((IDHEP(IDX1).EQ.21).OR.
4413      &                (ABS(IPHIST(1,IDX1)).GE.100)) THEN
4414                      ISPTN1 = -(60+IMO)
4415                   ELSE
4416                      ISPTN1 = -(50+IMO)
4417                   ENDIF
4418                ENDIF
4419             ENDIF
4420             IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1
4421             IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1
4422             IF (MODE.LT.0) THEN
4423                CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY,
4424      &                        PZ,PE,0,0,0)
4425             ELSE
4426                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4427      &                        PPX,PPY,PPZ,PPE)
4428                CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY,
4429      &                        PPZ,PPE,0,0,0)
4430             ENDIF
4431             IHIST(1,NHKK) = IPHIST(1,IDX1)
4432             IHIST(2,NHKK) = 0
4433             DO 19 KK=1,4
4434                VHKK(KK,NHKK) = VHKK(KK,M2PTN1)
4435                WHKK(KK,NHKK) = WHKK(KK,M1PTN1)
4436    19       CONTINUE
4437             VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB
4438             WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB
4439             M1STRG = NHKK
4440 *     gluon kinks
4441             NGLUON = IDX2-IDX1-1
4442             IF (NGLUON.GT.0) THEN
4443                DO 17 IGLUON=1,NGLUON
4444                   IDX   = IDX1+IGLUON
4445                   IDXMS = ABS(JMOHEP(1,IDX))
4446                   IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN
4447                      ILOOP = 0
4448    16                CONTINUE
4449                      ILOOP = ILOOP+1
4450                      IDXMS = ABS(JMOHEP(1,IDXMS))
4451                      IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND.
4452      &                   (ILOOP.LT.MAXLOP)) GOTO 16
4453                      IF (ILOOP.EQ.MAXLOP)
4454      &                  WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! '
4455                   ENDIF
4456                   IF (IDXMS.EQ.1) THEN
4457                      ISPTN = ISTHKK(MO1)
4458                      M1PTN = MO1
4459                      M2PTN = MO1+2
4460                   ELSE
4461                      ISPTN = ISTHKK(MO2)
4462                      M1PTN = MO2-2
4463                      M2PTN = MO2
4464                   ENDIF
4465                   PX = PHEP(1,IDX)
4466                   PY = PHEP(2,IDX)
4467                   PZ = PHEP(3,IDX)
4468                   PE = PHEP(4,IDX)
4469                   IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN
4470                      ISTX = ABS(ISPTN)/10
4471                      IMO  = ABS(ISPTN)-10*ISTX
4472                      IF ((IDHEP(IDX).EQ.21).OR.
4473      &                   (ABS(IPHIST(1,IDX)).GE.100)) THEN
4474                         ISPTN = -(60+IMO)
4475                      ELSE
4476                         ISPTN = -(50+IMO)
4477                      ENDIF
4478                   ENDIF
4479                   IF (ISPTN.EQ.-21) NPVAL = NPVAL+1
4480                   IF (ISPTN.EQ.-22) NTVAL = NTVAL+1
4481                   IF (MODE.LT.0) THEN
4482                      CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4483      &                              PX,PY,PZ,PE,0,0,0)
4484                   ELSE
4485                      CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4486      &                              PPX,PPY,PPZ,PPE)
4487                      CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4488      &                              PPX,PPY,PPZ,PPE,0,0,0)
4489                   ENDIF
4490                   IHIST(1,NHKK) = IPHIST(1,IDX)
4491                   IHIST(2,NHKK) = 0
4492                   DO 20 KK=1,4
4493                      VHKK(KK,NHKK) = VHKK(KK,M2PTN)
4494                      WHKK(KK,NHKK) = WHKK(KK,M1PTN)
4495    20             CONTINUE
4496                   VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB
4497                   WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB
4498    17          CONTINUE
4499             ENDIF
4500 *     parton at chain end
4501             PX = PHEP(1,IDX2)
4502             PY = PHEP(2,IDX2)
4503             PZ = PHEP(3,IDX2)
4504             PE = PHEP(4,IDX2)
4505 * flag only partons coming from Pomeron with 41/42
4506 C           IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4507             IF (IPOM2.NE.0) THEN
4508                ISTX = ABS(ISPTN2)/10
4509                IMO  = ABS(ISPTN2)-10*ISTX
4510                ISPTN2 = -(40+IMO)
4511             ELSE
4512                IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN
4513                   ISTX = ABS(ISPTN2)/10
4514                   IMO  = ABS(ISPTN2)-10*ISTX
4515                   IF ((IDHEP(IDX2).EQ.21).OR.
4516      &                (ABS(IPHIST(1,IDX2)).GE.100)) THEN
4517                      ISPTN2 = -(60+IMO)
4518                   ELSE
4519                      ISPTN2 = -(50+IMO)
4520                   ENDIF
4521                ENDIF
4522             ENDIF
4523             IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1
4524             IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1
4525             IF (MODE.LT.0) THEN
4526                CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4527      &                        PX,PY,PZ,PE,0,0,0)
4528             ELSE
4529                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4530      &                        PPX,PPY,PPZ,PPE)
4531                CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4532      &                        PPX,PPY,PPZ,PPE,0,0,0)
4533             ENDIF
4534             IHIST(1,NHKK) = IPHIST(1,IDX2)
4535             IHIST(2,NHKK) = 0
4536             DO 21 KK=1,4
4537                VHKK(KK,NHKK) = VHKK(KK,M2PTN2)
4538                WHKK(KK,NHKK) = WHKK(KK,M1PTN2)
4539    21       CONTINUE
4540             VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB
4541             WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB
4542             M2STRG = NHKK
4543 *   register string
4544             JSTRG = 100*IPROCE+NCODE(I)
4545             PX = PHEP(1,IDXSTG)
4546             PY = PHEP(2,IDXSTG)
4547             PZ = PHEP(3,IDXSTG)
4548             PE = PHEP(4,IDXSTG)
4549             IF (MODE.LT.0) THEN
4550                ISTAT = 70000+IPJE
4551                CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4552      &                        PX,PY,PZ,PE,0,0,0)
4553                IF (LEMCCK) THEN
4554                   PX = -PX
4555                   PY = -PY
4556                   PZ = -PZ
4557                   PE = -PE
4558                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4559                ENDIF
4560             ELSE
4561                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4562      &                        PPX,PPY,PPZ,PPE)
4563                ISTAT = 70000+IPJE
4564                CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4565      &                        PPX,PPY,PPZ,PPE,0,0,0)
4566                IF (LEMCCK) THEN
4567                   PX = -PPX
4568                   PY = -PPY
4569                   PZ = -PPZ
4570                   PE = -PPE
4571                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4572                ENDIF
4573             ENDIF
4574             NOBAM(NHKK)   = 0
4575             IHIST(1,NHKK) = 0
4576             IHIST(2,NHKK) = 0
4577             DO 18 KK=1,4
4578                VHKK(KK,NHKK) = VHKK(KK,MO2)
4579                WHKK(KK,NHKK) = WHKK(KK,MO1)
4580    18       CONTINUE
4581             VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
4582             WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
4583          ENDIF
4584    11 CONTINUE
4585
4586       IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN
4587          NHKK  = INHKK
4588          LFLIP = .FALSE.
4589          GOTO 1
4590       ENDIF
4591
4592       IF (LEMCCK) THEN
4593          IF (UMO.GT.1.0D5) THEN
4594             CHKLEV = 1.0D0
4595          ELSE
4596             CHKLEV = TINY1
4597          ENDIF
4598          CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2)
4599          IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0)
4600       ENDIF
4601
4602 * internal statistics
4603 *   dble-Po statistics.
4604       IF (IPROCE.NE.4) IPOPO = 0
4605
4606       INTFLG = IPROCE
4607       IDCHSY = IDCH(MO1)
4608       IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN
4609          ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1
4610       ELSE
4611          WRITE(LOUT,1000) IPROCE,NEVHKK,MO1
4612  1000    FORMAT(1X,'GETFSP:   warning! incons. process id. (',I2,
4613      &          ') at evt(chain) ',I6,'(',I2,')')
4614       ENDIF
4615       IF (IPROCE.EQ.5) THEN
4616          IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN
4617             ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1
4618          ELSE
4619 C           WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4620  1001       FORMAT(1X,'GETFSP:   warning! incons. diffrac. id. ',
4621      &             '(IPROCE,IDIFR1,IDIFR2=',3I3,')')
4622          ENDIF
4623       ELSEIF (IPROCE.EQ.6) THEN
4624          IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4625             ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1
4626          ELSE
4627 C           WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4628          ENDIF
4629       ELSEIF (IPROCE.EQ.7) THEN
4630          IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND.
4631      &       (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4632             IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1))
4633      &         ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1
4634             IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2))
4635      &         ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1
4636             IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2))
4637      &         ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1
4638             IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1))
4639      &         ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1
4640          ELSE
4641             WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4642          ENDIF
4643       ENDIF
4644       IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3))
4645      &                                                       THEN
4646          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4647          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4648          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4649       ENDIF
4650       ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM
4651       ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM
4652       ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG
4653       ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG)
4654       ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO)
4655
4656       RETURN
4657
4658  9999 CONTINUE
4659       IREJ = 1
4660       RETURN
4661       END
4662
4663 *$ CREATE DT_PHOINI.FOR
4664 *COPY DT_PHOINI
4665 *
4666 *===phoini=============================================================*
4667 *
4668       SUBROUTINE DT_PHOINI
4669
4670 ************************************************************************
4671 * Initialization PHOJET-event generator for nucleon-nucleon interact.  *
4672 * This version dated 16.11.95 is written by S. Roesler                 *
4673 *                                                                      *
4674 * Last change 27.12.2006 by S. Roesler.                                *
4675 ************************************************************************
4676
4677       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4678       SAVE
4679       PARAMETER ( LINP = 10 ,
4680      &            LOUT = 6 ,
4681      &            LDAT = 9 )
4682       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
4683
4684 * nucleon-nucleon event-generator
4685       CHARACTER*8 CMODEL
4686       LOGICAL LPHOIN
4687       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
4688 * particle properties (BAMJET index convention)
4689       CHARACTER*8  ANAME
4690       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
4691      &                IICH(210),IIBAR(210),K1(210),K2(210)
4692 * Lorentz-parameters of the current interaction
4693       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4694      &                UMO,PPCM,EPROJ,PPROJ
4695 * properties of interacting particles
4696       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
4697 * properties of photon/lepton projectiles
4698       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
4699       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
4700 * emulsion treatment
4701       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
4702      &                NCOMPO,IEMUL
4703 * VDM parameter for photon-nucleus interactions
4704       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
4705 * nuclear potential
4706       LOGICAL LFERMI
4707       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
4708      &                EBINDP(2),EBINDN(2),EPOT(2,210),
4709      &                ETACOU(2),ICOUL,LFERMI
4710 * Glauber formalism: flags and parameters for statistics
4711       LOGICAL LPROD
4712       CHARACTER*8 CGLB
4713       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
4714 *
4715 * parameters for cascade calculations:
4716 * maximum mumber of PDF's which can be defined in phojet (limited
4717 * by the dimension of ipdfs in pho_setpdf)
4718       PARAMETER (MAXPDF = 20)
4719 * PDF parametrization and number of set for the first 30 hadrons in
4720 * the bamjet-code list
4721 *   negative numbers mean that the PDF is set in phojet,
4722 *   zero stands for "not a hadron"
4723       DIMENSION IPARPD(30),ISETPD(30)
4724 * PDF parametrization
4725       DATA IPARPD /
4726      &  -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5,
4727      &   5, 5,-5, 5, 5, 0, 0, 0, 0, 0/
4728 * number of set
4729       DATA ISETPD /
4730      &  -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6,
4731      &   6, 6,-2, 2, 2, 0, 0, 0, 0, 0/
4732
4733 **PHOJET105a
4734 C     COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
4735 C     PARAMETER ( MAXPRO = 16 )
4736 C     PARAMETER ( MAXTAB = 20 )
4737 C     COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO),
4738 C    &                MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB
4739 C     CHARACTER*8 MDLNA
4740 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
4741 C     COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15)
4742 **PHOJET110
4743 C  global event kinematics and particle IDs
4744       INTEGER IFPAP,IFPAB
4745       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
4746       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
4747 C  hard cross sections and MC selection weights
4748       INTEGER Max_pro_2
4749       PARAMETER ( Max_pro_2 = 16 )
4750       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
4751      &  MH_acc_1,MH_acc_2
4752       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
4753       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
4754      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
4755      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
4756      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
4757      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
4758 C  model switches and parameters
4759       CHARACTER*8 MDLNA
4760       INTEGER ISWMDL,IPAMDL
4761       DOUBLE PRECISION PARMDL
4762       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4763 C  general process information
4764       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4765       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4766 **
4767       DIMENSION PP(4),PT(4)
4768
4769       LOGICAL LSTART
4770       DATA LSTART /.TRUE./
4771
4772       IJP = IJPROJ
4773       IJT = IJTARG
4774       Q2  = VIRT
4775 * lepton-projectiles: initialize real photon instead
4776       IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN
4777          IJP = 7
4778          Q2  = ZERO
4779       ENDIF
4780       IF (LPHOIN) CALL PHO_INIT(-1,LOUT,IDUM)
4781 * switch Reggeon off
4782 C     IPAMDL(3)= 0
4783       IF (IP.EQ.1) THEN
4784          IFPAP(1) = IDT_IPDGHA(IJP)
4785          IFPAB(1) = IJP
4786       ELSE
4787          IFPAP(1) = 2212
4788          IFPAB(1) = IDT_ICIHAD(IFPAP(1))
4789       ENDIF
4790       PMASS(1) = AAM(IFPAB(1))-SQRT(Q2)
4791       PVIRT(1) = PMASS(1)**2
4792       IF (IT.EQ.1) THEN
4793          IFPAP(2) = IDT_IPDGHA(IJT)
4794          IFPAB(2) = IJT
4795       ELSE
4796          IFPAP(2) = 2212
4797          IFPAB(2) = IDT_ICIHAD(IFPAP(2))
4798       ENDIF
4799       PMASS(2) = AAM(IFPAB(2))
4800       PVIRT(2) = ZERO
4801       DO 1 K=1,4
4802          PP(K) = ZERO
4803          PT(K) = ZERO
4804     1 CONTINUE
4805 * get max. possible momenta of incoming particles to be used for PHOJET ini.
4806       PPF = ZERO
4807       PTF = ZERO
4808       SCPF= 1.5D0
4809       IF (UMO.GE.1.E5) THEN
4810          SCPF= 5.0D0
4811       ENDIF
4812       IF (NCOMPO.GT.0) THEN
4813          DO 2 I=1,NCOMPO
4814             IF (IT.GT.1) THEN
4815                CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0)
4816             ELSE
4817                CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0)
4818             ENDIF
4819             PPFTMP = MAX(PFERMP(1),PFERMN(1))
4820             PTFTMP = MAX(PFERMP(2),PFERMN(2))
4821             IF (PPFTMP.GT.PPF) PPF = PPFTMP
4822             IF (PTFTMP.GT.PTF) PTF = PTFTMP
4823     2    CONTINUE
4824       ELSE
4825          CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
4826          PPF = MAX(PFERMP(1),PFERMN(1))
4827          PTF = MAX(PFERMP(2),PFERMN(2))
4828       ENDIF
4829       PTF = -PTF
4830       PPF = SCPF*PPF
4831       PTF = SCPF*PTF
4832       IF (IJP.EQ.7) THEN
4833          AMP2  = SIGN(PMASS(1)**2,PMASS(1))
4834          PP(3) = PPCM
4835          PP(4) = SQRT(AMP2+PP(3)**2)
4836       ELSE
4837          EPF = SQRT(PPF**2+PMASS(1)**2)
4838          CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2)
4839       ENDIF
4840       ETF = SQRT(PTF**2+PMASS(2)**2)
4841       CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3)
4842       ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
4843      &              (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
4844       IF (LSTART) THEN
4845          WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP
4846  1001    FORMAT(
4847      &      ' DT_PHOINI:    PHOJET initialized for projectile A,Z = ',
4848      &      I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
4849          IF (NCOMPO.GT.0) THEN
4850             WRITE(LOUT,1002) SCPF,PTF,PT
4851          ELSE
4852             WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT
4853          ENDIF
4854  1002    FORMAT(
4855      &      ' DT_PHOINI:    PHOJET initialized for target emulsion  ',
4856      &          /,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
4857  1003    FORMAT(
4858      &      ' DT_PHOINI:    PHOJET initialized for target     A,Z = ',
4859      &      I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
4860          WRITE(LOUT,1004) ECMINI
4861  1004    FORMAT(' E_cm = ',E10.3)
4862          IF (IJP.EQ.8) WRITE(LOUT,1005)
4863  1005    FORMAT(
4864      &      ' DT_PHOINI: warning! proton parameters used for neutron',
4865      &          ' projectile')
4866          LSTART = .FALSE.
4867       ENDIF
4868 * switch off new diffractive cross sections at low energies for nuclei
4869 * (temporary solution)
4870       IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN
4871          WRITE(LOUT,'(1X,A)')
4872      &      ' DT_PHOINI: model-switch 30 for nuclei re-set !'
4873          CALL PHO_SETMDL(30,0,1)
4874       ENDIF
4875 *
4876 C     IF (IJP.EQ.7) THEN
4877 C        AMP2  = SIGN(PMASS(1)**2,PMASS(1))
4878 C        PP(3) = PPCM
4879 C        PP(4) = SQRT(AMP2+PP(3)**2)
4880 C     ELSE
4881 C        PFERMX = ZERO
4882 C        IF (IP.GT.1) PFERMX = 0.5D0
4883 C        EFERMX = SQRT(PFERMX**2+PMASS(1)**2)
4884 C        CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2)
4885 C     ENDIF
4886 C     PFERMX = ZERO
4887 C     IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0
4888 C     EFERMX = SQRT(PFERMX**2+PMASS(2)**2)
4889 C     CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3)
4890 **sr 26.10.96
4891       ISAV = IPAMDL(13)
4892       IF ((ISHAD(2).EQ.1).AND.
4893      &   ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR.
4894      &    (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1
4895 **
4896       CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1)
4897 **sr 26.10.96
4898       IPAMDL(13) = ISAV
4899 **
4900 *
4901 * patch for cascade calculations:
4902 * define parton distribution functions for other hadrons, i.e. other
4903 * then defined already in phojet
4904       IF (IOGLB.EQ.100) THEN
4905          WRITE(LOUT,1006)
4906  1006    FORMAT(/,1X,'PHOINI: additional parton distribution functions',
4907      &          ' assiged (ID,IPAR,ISET)',/)
4908          NPDF = 0
4909          DO 3 I=1,30
4910             IF (IPARPD(I).NE.0) THEN
4911                NPDF = NPDF+1
4912                IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !'
4913                IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN
4914                   IDPDG = IDT_IPDGHA(I)
4915                   IPAR  = IPARPD(I)
4916                   ISET  = ISETPD(I)
4917                   WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET
4918                   CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1)
4919                ENDIF
4920             ENDIF
4921     3    CONTINUE
4922       ENDIF
4923
4924 C     CALL PHO_PHIST(-1,SIGMAX)
4925       IF (IREJ1.NE.0) THEN
4926          WRITE(LOUT,1000)
4927  1000    FORMAT(1X,'PHOINI:   PHOJET event-initialization failed!')
4928          STOP
4929       ENDIF
4930
4931       RETURN
4932       END
4933
4934 *$ CREATE DT_EVENTD.FOR
4935 *COPY DT_EVENTD
4936 *
4937 *===eventd=============================================================*
4938 *
4939       SUBROUTINE DT_EVENTD(IREJ)
4940
4941 ************************************************************************
4942 * Quasi-elastic neutrino nucleus scattering.                           *
4943 * This version dated 29.04.00 is written by S. Roesler.                *
4944 ************************************************************************
4945
4946       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4947       SAVE
4948       PARAMETER ( LINP = 10 ,
4949      &            LOUT = 6 ,
4950      &            LDAT = 9 )
4951       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5)
4952       PARAMETER (SQTINF=1.0D+15)
4953
4954       LOGICAL LFIRST
4955
4956 * event history
4957       PARAMETER (NMXHKK=200000)
4958       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4959      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4960      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4961 * extended event history
4962       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4963      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4964      &                IHIST(2,NMXHKK)
4965 * flags for input different options
4966       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4967       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4968      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4969       PARAMETER (MAXLND=4000)
4970       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
4971 * properties of interacting particles
4972       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
4973 * Lorentz-parameters of the current interaction
4974       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4975      &                UMO,PPCM,EPROJ,PPROJ
4976 * nuclear potential
4977       LOGICAL LFERMI
4978       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
4979      &                EBINDP(2),EBINDN(2),EPOT(2,210),
4980      &                ETACOU(2),ICOUL,LFERMI
4981 * steering flags for qel neutrino scattering modules
4982       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
4983       COMMON /QNPOL/ POLARX(4),PMODUL
4984       INTEGER PYK
4985
4986       DATA LFIRST /.TRUE./
4987
4988       IREJ = 0
4989
4990       IF (LFIRST) THEN
4991          LFIRST = .FALSE.
4992          CALL DT_MASS_INI
4993       ENDIF
4994
4995 * JETSET parameter
4996       CALL DT_INITJS(0)
4997
4998 * interacting target nucleon
4999       LTYP = NEUTYP
5000       IF (NEUDEC.LE.9) THEN
5001          IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN
5002             NUCTYP = 2112
5003             NUCTOP = 2
5004          ELSE
5005             NUCTYP = 2212
5006             NUCTOP = 1
5007          ENDIF
5008       ELSE
5009          RTYP  = DT_RNDM(RTYP)
5010          ZFRAC = DBLE(ITZ)/DBLE(IT)
5011          IF (RTYP.LE.ZFRAC) THEN
5012             NUCTYP = 2212
5013             NUCTOP = 1
5014          ELSE
5015             NUCTYP = 2112
5016             NUCTOP = 2
5017          ENDIF
5018       ENDIF
5019
5020 * select first nucleon in list with matching id and reset all other
5021 * nucleons which have been marked as "wounded" by ININUC
5022       IFOUND = 0
5023       DO 1 I=1,NHKK
5024          IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN
5025             ISTHKK(I) = 12
5026             IFOUND    = 1
5027             IDX = I
5028          ELSE
5029             IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14
5030          ENDIF
5031     1 CONTINUE
5032       IF (IFOUND.EQ.0)
5033      &   STOP ' EVENTD: interacting target nucleon not found! '
5034
5035 * correct position of proj. lepton: assume position of target nucleon
5036       DO 3 I=1,4
5037          VHKK(I,1) = VHKK(I,IDX)
5038          WHKK(I,1) = WHKK(I,IDX)
5039     3 CONTINUE
5040
5041 * load initial momenta for conservation check
5042       IF (LEMCCK) THEN
5043          CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM)
5044          CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX),
5045      &                                                      2,IDUM,IDUM)
5046       ENDIF
5047
5048 * quasi-elastic scattering
5049       IF (NEUDEC.LT.9) THEN
5050          CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),
5051      &                                          PHKK(4,IDX),PHKK(5,IDX))
5052 *  CC event on p or n
5053       ELSEIF (NEUDEC.EQ.10) THEN
5054          CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX),
5055      &                     PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5056 *  NC event on p or n
5057       ELSEIF (NEUDEC.EQ.11) THEN
5058          CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX),
5059      &                     PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5060       ENDIF
5061
5062 * get final state particles from Lund-common and write them into HKKEVT
5063       NPOINT(1) = NHKK+1
5064       NPOINT(4) = NHKK+1
5065       NLINES = PYK(0,1)
5066       NHKK0  = NHKK+1
5067       DO 4 I=4,NLINES
5068          IF (K(I,1).EQ.1) THEN
5069             ID = K(I,2)
5070             PX = P(I,1)
5071             PY = P(I,2)
5072             PZ = P(I,3)
5073             PE = P(I,4)
5074             CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0)
5075             IDBJ = IDT_ICIHAD(ID)
5076             EKIN = PHKK(4,NHKK)-PHKK(5,NHKK)
5077             IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN
5078                IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16
5079             ENDIF
5080             VHKK(1,NHKK) = VHKK(1,IDX)
5081             VHKK(2,NHKK) = VHKK(2,IDX)
5082             VHKK(3,NHKK) = VHKK(3,IDX)
5083             VHKK(4,NHKK) = VHKK(4,IDX)
5084 C           IF (I.EQ.4) THEN
5085 C              WHKK(1,NHKK) = POLARX(1)
5086 C              WHKK(2,NHKK) = POLARX(2)
5087 C              WHKK(3,NHKK) = POLARX(3)
5088 C              WHKK(4,NHKK) = POLARX(4)
5089 C           ELSE
5090                WHKK(1,NHKK) = WHKK(1,IDX)
5091                WHKK(2,NHKK) = WHKK(2,IDX)
5092                WHKK(3,NHKK) = WHKK(3,IDX)
5093                WHKK(4,NHKK) = WHKK(4,IDX)
5094 C           ENDIF
5095             IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
5096          ENDIF
5097     4 CONTINUE
5098
5099       IF (LEMCCK) THEN
5100          CHKLEV = TINY5
5101          CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1)
5102          IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
5103       ENDIF
5104
5105 * transform momenta into cms (as required for inc etc.)
5106       DO 5 I=NHKK0,NHKK
5107          IF (ISTHKK(I).EQ.1) THEN
5108             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3)
5109             PHKK(3,I) = PZ
5110             PHKK(4,I) = PE
5111          ENDIF
5112     5 CONTINUE
5113
5114       RETURN
5115       END
5116
5117 *$ CREATE DT_KKEVNT.FOR
5118 *COPY DT_KKEVNT
5119 *
5120 *===kkevnt=============================================================*
5121 *
5122       SUBROUTINE DT_KKEVNT(KKMAT,IREJ)
5123
5124 ************************************************************************
5125 * Treatment of complete nucleus-nucleus or hadron-nucleus scattering   *
5126 * without nuclear effects (one event).                                 *
5127 * This subroutine is an update of the previous version (KKEVT) written *
5128 * by J. Ranft/ H.-J. Moehring.                                         *
5129 * This version dated 20.04.95 is written by S. Roesler                 *
5130 ************************************************************************
5131
5132       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5133       SAVE
5134       PARAMETER ( LINP = 10 ,
5135      &            LOUT = 6 ,
5136      &            LDAT = 9 )
5137       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10)
5138
5139       PARAMETER ( MAXNCL = 260,
5140      &            MAXVQU = MAXNCL,
5141      &            MAXSQU = 20*MAXVQU,
5142      &            MAXINT = MAXVQU+MAXSQU)
5143 * event history
5144       PARAMETER (NMXHKK=200000)
5145       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5146      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5147      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5148 * extended event history
5149       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5150      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5151      &                IHIST(2,NMXHKK)
5152 * flags for input different options
5153       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5154       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5155      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5156 * rejection counter
5157       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
5158      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
5159      &                IREXCI(3),IRDIFF(2),IRINC
5160 * statistics
5161       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5162      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5163      &                ICEVTG(8,0:30)
5164 * properties of interacting particles
5165       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5166 * Lorentz-parameters of the current interaction
5167       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5168      &                UMO,PPCM,EPROJ,PPROJ
5169 * flags for diffractive interactions (DTUNUC 1.x)
5170       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5171 * interface HADRIN-DPM
5172       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5173 * nucleon-nucleon event-generator
5174       CHARACTER*8 CMODEL
5175       LOGICAL LPHOIN
5176       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
5177 * coordinates of nucleons
5178       COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
5179 * interface between Glauber formalism and DPM
5180       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
5181      &                INTER1(MAXINT),INTER2(MAXINT)
5182 * Glauber formalism: collision properties
5183       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5184      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
5185      &                NCP,NCT
5186 * central particle production, impact parameter biasing
5187       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5188 **temporary
5189 * statistics: Glauber-formalism
5190       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5191 **
5192
5193       DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/
5194
5195       IREJ   = 0
5196       ICREQU = ICREQU+1
5197       NC     = 0
5198       NCP    = 0
5199       NCT    = 0
5200
5201     1 CONTINUE
5202       ICSAMP = ICSAMP+1
5203       NC     = NC+1
5204       IF (MOD(NC,10).EQ.0) THEN
5205          WRITE(LOUT,1000) NEVHKK
5206  1000    FORMAT(1X,'KKEVNT: event ',I8,' rejected!')
5207          GOTO 9999
5208       ENDIF
5209
5210 * initialize DTEVT1/DTEVT2
5211       CALL DT_EVTINI
5212
5213 * We need the following only in order to sample nucleon coordinates.
5214 * However we don't have parameters (cross sections, slope etc.)
5215 * for neutrinos available. Therefore switch projectile to proton
5216 * in this case.
5217       IF (MCGENE.EQ.4) THEN
5218          JJPROJ = 1
5219       ELSE
5220          JJPROJ = IJPROJ
5221       ENDIF
5222
5223    10 CONTINUE
5224       IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR.
5225 * make sure that Glauber-formalism is called each time the interaction
5226 * configuration changed
5227      &     (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR.
5228      &     (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN
5229 * sample number of nucleon-nucleon coll. according to Glauber-form.
5230          CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT)
5231          NWTSAM = NN
5232          NWASAM = NP
5233          NWBSAM = NT
5234          NEVOLD = NEVHKK
5235          IPOLD  = IP
5236          ITOLD  = IT
5237          JJPOLD = JJPROJ
5238          EPROLD = EPROJ
5239          DO 8 I=1, IP
5240             NCP = NCP+JSSH(I)
5241 *           WRITE(6,*)' PROJ.NUCL. ',I,' NCOLL = ',NCP
5242     8 CONTINUE
5243          DO 9 I=1, IT
5244             NCT = NCT+JTSH(I)
5245 *           WRITE(6,*)' TAR.NUCL. ',I,' NCOLL = ',NCT
5246     9 CONTINUE
5247       ENDIF
5248
5249 * force diffractive particle production in h-K interactions
5250       IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND.
5251      &    (IP.EQ.1).AND.(NN.NE.1)) THEN
5252          NEVOLD = 0
5253          GOTO 10
5254       ENDIF
5255
5256 * check number of involved proj. nucl. (NP) if central prod.is requested
5257       IF (ICENTR.GT.0) THEN
5258          CALL DT_CHKCEN(IP,IT,NP,NT,IBACK)
5259          IF (IBACK.GT.0) GOTO 10
5260       ENDIF
5261
5262 * get initial nucleon-configuration in projectile and target
5263 * rest-system (including Fermi-momenta if requested)
5264       CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1)
5265       MODE = 2
5266       IF (EPROJ.LE.EHADTH) MODE = 3
5267       CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE)
5268
5269       IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN
5270
5271 * activate HADRIN at low energies (implemented for h-N scattering only)
5272          IF (EPROJ.LE.EHADHI) THEN
5273             IF (EHADTH.LT.ZERO) THEN
5274 *   smooth transition btwn. DPM and HADRIN
5275                FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO)
5276                RR   = DT_RNDM(FRAC)
5277                IF (RR.GT.FRAC) THEN
5278                   IF (IP.EQ.1) THEN
5279                      CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5280                      IF (IREJ1.GT.0) GOTO 1
5281                      RETURN
5282                   ELSE
5283                      WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5284                   ENDIF
5285                ENDIF
5286             ELSE
5287 *   fixed threshold for onset of production via HADRIN
5288                IF (EPROJ.LE.EHADTH) THEN
5289                   IF (IP.EQ.1) THEN
5290                      CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5291                      IF (IREJ1.GT.0) GOTO 1
5292                      RETURN
5293                   ELSE
5294                      WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5295                   ENDIF
5296                ENDIF
5297             ENDIF
5298          ENDIF
5299  1001    FORMAT(1X,'KKEVNT:   warning! interaction of proj. (m=',
5300      &          I3,') with target (m=',I3,')',/,11X,
5301      &          'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1,
5302      &          'GeV) cannot be handled')
5303
5304 * sampling of momentum-x fractions & flavors of chain ends
5305          CALL DT_SPLPTN(NN)
5306
5307 * Lorentz-transformation of wounded nucleons into nucl.-nucl. cms
5308          CALL DT_NUC2CM
5309
5310 * collect momenta of chain ends and put them into DTEVT1
5311          CALL DT_GETPTN(IP,NN,NCSY,IREJ1)
5312          IF (IREJ1.NE.0) GOTO 1
5313
5314       ENDIF
5315
5316 * handle chains including fragmentation (two-chain approximation)
5317       IF (MCGENE.EQ.1) THEN
5318 *  two-chain approximation
5319          CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1)
5320          IF (IREJ1.NE.0) THEN
5321             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT'
5322             GOTO 1
5323          ENDIF
5324       ELSEIF (MCGENE.EQ.2) THEN
5325 *  multiple-Po exchange including minijets
5326          CALL DT_EVENTB(NCSY,IREJ1)
5327          IF (IREJ1.NE.0) THEN
5328             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT'
5329             GOTO 1
5330          ENDIF
5331       ELSEIF (MCGENE.EQ.3) THEN
5332          STOP ' This version does not contain LEPTO !'
5333       ELSEIF (MCGENE.EQ.4) THEN
5334 *  quasi-elastic neutrino scattering
5335          CALL DT_EVENTD(IREJ1)
5336          IF (IREJ1.NE.0) THEN
5337             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT'
5338             GOTO 1
5339          ENDIF
5340       ELSE
5341          WRITE(LOUT,1002) MCGENE
5342  1002    FORMAT(1X,'KKEVNT:   warning! event-generator',I4,
5343      &         ' not available - program stopped')
5344          STOP
5345       ENDIF
5346
5347       RETURN
5348
5349  9999 CONTINUE
5350       IREJ = 1
5351       RETURN
5352       END
5353
5354 *$ CREATE DT_CHKCEN.FOR
5355 *COPY DT_CHKCEN
5356 *
5357 *===chkcen=============================================================*
5358 *
5359       SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK)
5360
5361 ************************************************************************
5362 * Check of number of involved projectile nucleons if central production*
5363 * is requested.                                                        *
5364 * Adopted from a part of the old KKEVT routine which was written by    *
5365 * J. Ranft/H.-J.Moehring.                                              *
5366 * This version dated 13.01.95 is written by S. Roesler                 *
5367 ************************************************************************
5368
5369       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5370       SAVE
5371       PARAMETER ( LINP = 10 ,
5372      &            LOUT = 6 ,
5373      &            LDAT = 9 )
5374
5375 * statistics
5376       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5377      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5378      &                ICEVTG(8,0:30)
5379 * central particle production, impact parameter biasing
5380       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5381
5382       IBACK = 0
5383
5384 * old version
5385       IF (ICENTR.EQ.2) THEN
5386          IF (IP.LT.IT) THEN
5387             IF (IP.LE.8) THEN
5388                IF (NP.LT.IP-1) IBACK = 1
5389             ELSEIF (IP.LE.16) THEN
5390                IF (NP.LT.IP-2) IBACK = 1
5391             ELSEIF (IP.LE.32) THEN
5392                IF (NP.LT.IP-3) IBACK = 1
5393             ELSEIF (IP.GE.33) THEN
5394                IF (NP.LT.IP-5) IBACK = 1
5395             ENDIF
5396          ELSEIF (IP.EQ.IT) THEN
5397             IF (IP.EQ.32) THEN
5398                IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5399             ELSE
5400                IF (NP.LT.IP-IP/8) IBACK = 1
5401             ENDIF
5402          ELSEIF (ABS(IP-IT).LT.3) THEN
5403             IF (NP.LT.IP-IP/8) IBACK = 1
5404          ENDIF
5405       ELSE
5406 * new version (DPMJET, 5.6.99)
5407          IF (IP.LT.IT) THEN
5408             IF (IP.LE.8) THEN
5409                IF (NP.LT.IP-1) IBACK = 1
5410             ELSEIF (IP.LE.16) THEN
5411                IF (NP.LT.IP-2) IBACK = 1
5412             ELSEIF (IP.LT.32) THEN
5413                IF (NP.LT.IP-3) IBACK = 1
5414             ELSEIF (IP.GE.32) THEN
5415                IF (IT.LE.150) THEN
5416 *   Example: S-Ag
5417                   IF (NP.LT.IP-1) IBACK = 1
5418                ELSE
5419 *   Example: S-Au
5420                   IF (NP.LT.IP) IBACK = 1
5421                ENDIF
5422             ENDIF
5423          ELSEIF (IP.EQ.IT) THEN
5424 *   Example: S-S
5425            IF (IP.EQ.32) THEN
5426               IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5427 *   Example: Pb-Pb
5428            ELSE
5429               IF (NP.LT.IP-IP/4) IBACK = 1
5430            ENDIF
5431          ELSEIF (ABS(IP-IT).LT.3) THEN
5432             IF (NP.LT.IP-IP/8) IBACK = 1
5433          ENDIF
5434       ENDIF
5435
5436       ICCPRO = ICCPRO+1
5437
5438       RETURN
5439       END
5440
5441 *$ CREATE DT_ININUC.FOR
5442 *COPY DT_ININUC
5443 *
5444 *===ininuc=============================================================*
5445 *
5446       SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE)
5447
5448 ************************************************************************
5449 * Samples initial configuration of nucleons in nucleus with mass NMASS *
5450 * including Fermi-momenta (if reqested).                               *
5451 *          ID             BAMJET-code for hadrons (instead of nuclei)  *
5452 *          NMASS          mass number of nucleus (number of nucleons)  *
5453 *          NCH            charge of nucleus                            *
5454 *          COORD(3,NMASS) coordinates of nucleons inside nucleus in fm *
5455 *          JS(NMASS) > 0  nucleon undergoes nucleon-nucleon interact.  *
5456 *          IMODE = 1      projectile nucleus                           *
5457 *                = 2      target     nucleus                           *
5458 *                = 3      target     nucleus (E_lab<E_thr for HADRIN)  *
5459 * Adopted from a part of the old KKEVT routine which was written by    *
5460 * J. Ranft/H.-J.Moehring.                                              *
5461 * This version dated 13.01.95 is written by S. Roesler                 *
5462 ************************************************************************
5463
5464       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5465       SAVE
5466       PARAMETER ( LINP = 10 ,
5467      &            LOUT = 6 ,
5468      &            LDAT = 9 )
5469       PARAMETER (FM2MM=1.0D-12)
5470
5471       PARAMETER ( MAXNCL = 260,
5472      &            MAXVQU = MAXNCL,
5473      &            MAXSQU = 20*MAXVQU,
5474      &            MAXINT = MAXVQU+MAXSQU)
5475 * event history
5476       PARAMETER (NMXHKK=200000)
5477       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5478      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5479      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5480 * extended event history
5481       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5482      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5483      &                IHIST(2,NMXHKK)
5484 * flags for input different options
5485       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5486       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5487      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5488 * auxiliary common for chain system storage (DTUNUC 1.x)
5489       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5490 * nuclear potential
5491       LOGICAL LFERMI
5492       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5493      &                EBINDP(2),EBINDN(2),EPOT(2,210),
5494      &                ETACOU(2),ICOUL,LFERMI
5495 * properties of photon/lepton projectiles
5496       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5497 * particle properties (BAMJET index convention)
5498       CHARACTER*8  ANAME
5499       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5500      &                IICH(210),IIBAR(210),K1(210),K2(210)
5501 * Glauber formalism: collision properties
5502       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5503      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5504 * flavors of partons (DTUNUC 1.x)
5505       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5506      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5507      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
5508      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5509      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
5510      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5511      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
5512 * interface HADRIN-DPM
5513       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5514
5515       DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL)
5516
5517 * number of neutrons
5518       NNEU = NMASS-NCH
5519 * initializations
5520       NP = 0
5521       NN = 0
5522       DO 1 K=1,4
5523          PFTOT(K) = 0.0D0
5524     1 CONTINUE
5525       MODE   = IMODE
5526       IF (IMODE.GT.2) MODE = 2
5527 **sr 29.5. new NPOINT(1)-definition
5528 C     IF (IMODE.GE.2) NPOINT(1) = NHKK+1
5529 **
5530       NHADRI = 0
5531       NC     = NHKK
5532
5533 * get initial configuration
5534       DO 2 I=1,NMASS
5535          NHKK = NHKK+1
5536          IF (JS(I).GT.0) THEN
5537             ISTHKK(NHKK) = 10+MODE
5538             IF (IMODE.EQ.3) THEN
5539 *   additional treatment if HADRIN-generator is requested
5540                NHADRI = NHADRI+1
5541                IF (NHADRI.EQ.1) IDXTA  = NHKK
5542                IF (NHADRI.GT.1) ISTHKK(NHKK) = 14
5543             ENDIF
5544          ELSE
5545             ISTHKK(NHKK) = 12+MODE
5546          ENDIF
5547          IF (NMASS.GE.2) THEN
5548 *   treatment for nuclei
5549             FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS)
5550             RR   = DT_RNDM(FRAC)
5551             IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN
5552                IDX = 8
5553                NN  = NN+1
5554             ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN
5555                IDX = 1
5556                NP  = NP+1
5557             ELSEIF (NN.LT.NNEU) THEN
5558                IDX = 8
5559                NN  = NN+1
5560             ELSEIF (NP.LT.NCH)  THEN
5561                IDX = 1
5562                NP  = NP+1
5563             ENDIF
5564             IDHKK(NHKK) = IDT_IPDGHA(IDX)
5565             IDBAM(NHKK) = IDX
5566             IF (MODE.EQ.1) THEN
5567                IPOSP(I)  = NHKK
5568                KKPROJ(I) = IDX
5569             ELSE
5570                IPOST(I)  = NHKK
5571                KKTARG(I) = IDX
5572             ENDIF
5573             IF (IDX.EQ.1) THEN
5574                PFER = PFERMP(MODE)
5575                PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1))
5576             ELSE
5577                PFER = PFERMN(MODE)
5578                PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8))
5579             ENDIF
5580             CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX)
5581             DO 3 K=1,4
5582                PFTOT(K) = PFTOT(K)+PF(K)
5583                PHKK(K,NHKK) = PF(K)
5584     3       CONTINUE
5585             PHKK(5,NHKK) = AAM(IDX)
5586          ELSE
5587 *   treatment for hadrons
5588             IDHKK(NHKK)  = IDT_IPDGHA(ID)
5589             IDBAM(NHKK)  = ID
5590             PHKK(4,NHKK) = AAM(ID)
5591             PHKK(5,NHKK) = AAM(ID)
5592 C* VDM assumption
5593 C            IF (IDHKK(NHKK).EQ.22) THEN
5594 C               PHKK(4,NHKK) = AAM(33)
5595 C               PHKK(5,NHKK) = AAM(33)
5596 C            ENDIF
5597             IF (MODE.EQ.1) THEN
5598                IPOSP(I)  = NHKK
5599                KKPROJ(I) = ID
5600                PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
5601             ELSE
5602                IPOST(I)  = NHKK
5603                KKTARG(I) = ID
5604             ENDIF
5605          ENDIF
5606          DO 4 K=1,3
5607             VHKK(K,NHKK) = COORD(K,I)*FM2MM
5608             WHKK(K,NHKK) = COORD(K,I)*FM2MM
5609     4    CONTINUE
5610          IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM
5611          IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM
5612          VHKK(4,NHKK) = 0.0D0
5613          WHKK(4,NHKK) = 0.0D0
5614     2 CONTINUE
5615
5616 * balance Fermi-momenta
5617       IF (NMASS.GE.2) THEN
5618          DO 5 I=1,NMASS
5619             NC = NC+1
5620             DO 6 K=1,3
5621                PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
5622     6       CONTINUE
5623             PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
5624      &                        PHKK(2,NC)**2+PHKK(3,NC)**2)
5625     5    CONTINUE
5626       ENDIF
5627
5628       RETURN
5629       END
5630
5631 *$ CREATE DT_FER4M.FOR
5632 *COPY DT_FER4M
5633 *
5634 *===fer4m==============================================================*
5635 *
5636       SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
5637
5638 ************************************************************************
5639 * Sampling of nucleon Fermi-momenta from distributions at T=0.         *
5640 *                                   processed by S. Roesler, 17.10.95  *
5641 ************************************************************************
5642
5643       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5644       SAVE
5645       PARAMETER ( LINP = 10 ,
5646      &            LOUT = 6 ,
5647      &            LDAT = 9 )
5648
5649       LOGICAL LSTART
5650
5651 * particle properties (BAMJET index convention)
5652       CHARACTER*8  ANAME
5653       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5654      &                IICH(210),IIBAR(210),K1(210),K2(210)
5655 * nuclear potential
5656       LOGICAL LFERMI
5657       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5658      &                EBINDP(2),EBINDN(2),EPOT(2,210),
5659      &                ETACOU(2),ICOUL,LFERMI
5660
5661       DATA LSTART /.TRUE./
5662
5663       ILOOP = 0
5664       IF (LFERMI) THEN
5665          IF (LSTART) THEN
5666             WRITE(LOUT,1000)
5667  1000       FORMAT(/,1X,'FER4M:   sampling of Fermi-momenta activated')
5668             LSTART = .FALSE.
5669          ENDIF
5670     1    CONTINUE
5671          CALL DT_DFERMI(PABS)
5672          PABS = PFERM*PABS
5673 C        IF (PABS.GE.PBIND) THEN
5674 C           ILOOP = ILOOP+1
5675 C           IF (MOD(ILOOP,500).EQ.0) THEN
5676 C              WRITE(LOUT,1001) PABS,PBIND,ILOOP
5677 C1001          FORMAT(1X,'FER4M:    Fermi-mom. corr. for binding',
5678 C    &                ' energy ',2E12.3,I6)
5679 C           ENDIF
5680 C           GOTO 1
5681 C        ENDIF
5682          CALL DT_DPOLI(POLC,POLS)
5683          CALL DT_DSFECF(SFE,CFE)
5684          CXTA = POLS*CFE
5685          CYTA = POLS*SFE
5686          CZTA = POLC
5687          ET   = SQRT(PABS*PABS+AAM(KT)**2)
5688          PXT  = CXTA*PABS
5689          PYT  = CYTA*PABS
5690          PZT  = CZTA*PABS
5691       ELSE
5692          ET   = AAM(KT)
5693          PXT  = 0.0D0
5694          PYT  = 0.0D0
5695          PZT  = 0.0D0
5696       ENDIF
5697
5698       RETURN
5699       END
5700
5701 *$ CREATE DT_NUC2CM.FOR
5702 *COPY DT_NUC2CM
5703 *
5704 *===nuc2cm=============================================================*
5705 *
5706       SUBROUTINE DT_NUC2CM
5707
5708 ************************************************************************
5709 * Lorentz-transformation of all wounded nucleons from Lab. to nucl.-   *
5710 * nucl. cms. (This subroutine replaces NUCMOM.)                        *
5711 * This version dated 15.01.95 is written by S. Roesler                 *
5712 ************************************************************************
5713
5714       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5715       SAVE
5716       PARAMETER ( LINP = 10 ,
5717      &            LOUT = 6 ,
5718      &            LDAT = 9 )
5719       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
5720
5721 * event history
5722       PARAMETER (NMXHKK=200000)
5723       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5724      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5725      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5726 * extended event history
5727       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5728      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5729      &                IHIST(2,NMXHKK)
5730 * statistics
5731       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5732      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5733      &                ICEVTG(8,0:30)
5734 * properties of photon/lepton projectiles
5735       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5736 * particle properties (BAMJET index convention)
5737       CHARACTER*8  ANAME
5738       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5739      &                IICH(210),IIBAR(210),K1(210),K2(210)
5740 * Glauber formalism: collision properties
5741       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5742      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5743 **temporary
5744 * statistics: Glauber-formalism
5745       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5746 **
5747
5748       ICWP = 0
5749       ICWT = 0
5750       NWTACC = 0
5751       NWAACC = 0
5752       NWBACC = 0
5753
5754       NPOINT(1) = NHKK+1
5755       NEND      = NHKK
5756       DO 1 I=1,NEND
5757          IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN
5758             IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1
5759             IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1
5760             MODE = ISTHKK(I)-9
5761 C            IF (IDHKK(I).EQ.22) THEN
5762 C* VDM assumption
5763 C               PEIN = AAM(33)
5764 C               IDB  = 33
5765 C            ELSE
5766 C               PEIN = PHKK(4,I)
5767 C               IDB  = IDBAM(I)
5768 C            ENDIF
5769 C            CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
5770 C     &           PX,PY,PZ,PE,IDB,MODE)
5771             IF (PHKK(5,I).GT.ZERO) THEN
5772                CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
5773      &              PX,PY,PZ,PE,IDBAM(I),MODE)
5774             ELSE
5775                PX = PGAMM(1)
5776                PY = PGAMM(2)
5777                PZ = PGAMM(3)
5778                PE = PGAMM(4)
5779             ENDIF
5780             IST = ISTHKK(I)-2
5781             ID  = IDHKK(I)
5782 C* VDM assumption
5783 C            IF (ID.EQ.22) ID = 113
5784             CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0)
5785             IF (ISTHKK(I).EQ.11) ICWP = ICWP+1
5786             IF (ISTHKK(I).EQ.12) ICWT = ICWT+1
5787          ENDIF
5788     1 CONTINUE
5789
5790       NWTACC = MAX(NWAACC,NWBACC)
5791       ICDPR  = ICDPR+ICWP
5792       ICDTA  = ICDTA+ICWT
5793 **temporary
5794       IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
5795          CALL DT_EVTOUT(4)
5796          STOP
5797       ENDIF
5798
5799       RETURN
5800       END
5801
5802 *$ CREATE DT_SPLPTN.FOR
5803 *COPY DT_SPLPTN
5804 *
5805 *===splptn=============================================================*
5806 *
5807       SUBROUTINE DT_SPLPTN(NN)
5808
5809 ************************************************************************
5810 * SamPLing of ParToN momenta and flavors.                              *
5811 * This version dated 15.01.95 is written by S. Roesler                 *
5812 ************************************************************************
5813
5814       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5815       SAVE
5816       PARAMETER ( LINP = 10 ,
5817      &            LOUT = 6 ,
5818      &            LDAT = 9 )
5819
5820 * Lorentz-parameters of the current interaction
5821       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5822      &                UMO,PPCM,EPROJ,PPROJ
5823
5824 * sample flavors of sea-quarks
5825       CALL DT_SPLFLA(NN,1)
5826
5827 * sample x-values of partons at chain ends
5828       ECM = UMO
5829       CALL DT_XKSAMP(NN,ECM)
5830
5831 * samle flavors
5832       CALL DT_SPLFLA(NN,2)
5833
5834       RETURN
5835       END
5836
5837 *$ CREATE DT_SPLFLA.FOR
5838 *COPY DT_SPLFLA
5839 *
5840 *===splfla=============================================================*
5841 *
5842       SUBROUTINE DT_SPLFLA(NN,MODE)
5843
5844 ************************************************************************
5845 * SamPLing of FLAvors of partons at chain ends.                        *
5846 * This subroutine replaces FLKSAA/FLKSAM.                              *
5847 *            NN            number of nucleon-nucleon interactions      *
5848 *            MODE = 1      sea-flavors                                 *
5849 *                 = 2      valence-flavors                             *
5850 * Based on the original version written by J. Ranft/H.-J. Moehring.    *
5851 * This version dated 16.01.95 is written by S. Roesler                 *
5852 ************************************************************************
5853
5854       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5855       SAVE
5856       PARAMETER ( LINP = 10 ,
5857      &            LOUT = 6 ,
5858      &            LDAT = 9 )
5859
5860       PARAMETER ( MAXNCL = 260,
5861      &            MAXVQU = MAXNCL,
5862      &            MAXSQU = 20*MAXVQU,
5863      &            MAXINT = MAXVQU+MAXSQU)
5864 * flavors of partons (DTUNUC 1.x)
5865       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5866      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5867      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
5868      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5869      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
5870      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5871      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
5872 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5873       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
5874      &                IXPV,IXPS,IXTV,IXTS,
5875      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
5876      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
5877      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
5878      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
5879      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
5880      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
5881      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
5882      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
5883 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5884       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
5885      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
5886 * particle properties (BAMJET index convention)
5887       CHARACTER*8  ANAME
5888       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5889      &                IICH(210),IIBAR(210),K1(210),K2(210)
5890 * various options for treatment of partons (DTUNUC 1.x)
5891 * (chain recombination, Cronin,..)
5892       LOGICAL LCO2CR,LINTPT
5893       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
5894      &                LCO2CR,LINTPT
5895
5896       IF (MODE.EQ.1) THEN
5897 * sea-flavors
5898          DO 1 I=1,NN
5899             IPSQ(I)  = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5900             IPSAQ(I) = -IPSQ(I)
5901     1    CONTINUE
5902          DO 2 I=1,NN
5903             ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5904             ITSAQ(I)= -ITSQ(I)
5905     2    CONTINUE
5906       ELSEIF (MODE.EQ.2) THEN
5907 * valence flavors
5908          DO 3 I=1,IXPV
5909             CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
5910     3    CONTINUE
5911          DO 4 I=1,IXTV
5912             CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
5913     4    CONTINUE
5914       ENDIF
5915
5916       RETURN
5917       END
5918
5919 *$ CREATE DT_GETPTN.FOR
5920 *COPY DT_GETPTN
5921 *
5922 *===getptn=============================================================*
5923 *
5924       SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
5925
5926 ************************************************************************
5927 * This subroutine collects partons at chain ends from temporary        *
5928 * commons and puts them into DTEVT1.                                   *
5929 * This version dated 15.01.95 is written by S. Roesler                 *
5930 ************************************************************************
5931
5932       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5933       SAVE
5934       PARAMETER ( LINP = 10 ,
5935      &            LOUT = 6 ,
5936      &            LDAT = 9 )
5937       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
5938
5939       LOGICAL LCHK
5940
5941       PARAMETER ( MAXNCL = 260,
5942      &            MAXVQU = MAXNCL,
5943      &            MAXSQU = 20*MAXVQU,
5944      &            MAXINT = MAXVQU+MAXSQU)
5945 * event history
5946       PARAMETER (NMXHKK=200000)
5947       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5948      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5949      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5950 * extended event history
5951       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5952      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5953      &                IHIST(2,NMXHKK)
5954 * flags for input different options
5955       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5956       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5957      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5958 * auxiliary common for chain system storage (DTUNUC 1.x)
5959       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5960 * statistics
5961       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5962      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5963      &                ICEVTG(8,0:30)
5964 * flags for diffractive interactions (DTUNUC 1.x)
5965       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5966 * x-values of partons (DTUNUC 1.x)
5967       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
5968      &                XTVQ(MAXVQU),XTVD(MAXVQU),
5969      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
5970      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
5971 * flavors of partons (DTUNUC 1.x)
5972       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5973      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5974      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
5975      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5976      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
5977      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5978      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
5979 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5980       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
5981      &                IXPV,IXPS,IXTV,IXTS,
5982      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
5983      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
5984      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
5985      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
5986      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
5987      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
5988      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
5989      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
5990 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5991       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
5992      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
5993
5994       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
5995
5996       DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
5997
5998       IREJ      = 0
5999       NCSY      = 0
6000       NPOINT(2) = NHKK+1
6001
6002 * sea-sea chains
6003       DO 10 I=1,NSS
6004          IF (ISKPCH(1,I).EQ.99) GOTO 10
6005          ICCHAI(1,1) = ICCHAI(1,1)+2
6006          IDXP = INTSS1(I)
6007          IDXT = INTSS2(I)
6008          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6009          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6010          DO 11 K=1,4
6011             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6012             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6013             PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6014             PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6015    11    CONTINUE
6016          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6017      &                                  +(PP1(3)+PT1(3))**2)
6018          ECH   = PP1(4)+PT1(4)
6019          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6020          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6021      &                                  +(PP2(3)+PT2(3))**2)
6022          ECH   = PP2(4)+PT2(4)
6023          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6024          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6025             AM1 = SQRT(AM1)
6026             AM2 = SQRT(AM2)
6027             IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
6028 C              WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6029  5000          FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
6030             ENDIF
6031          ELSE
6032             WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6033          ENDIF
6034          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6035          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6036          IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6037          IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6038          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6039      &                                                    0,0,1)
6040          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6041      &                                                    0,0,1)
6042          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6043      &                                                    0,0,1)
6044          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6045      &                                                    0,0,1)
6046          NCSY = NCSY+1
6047    10 CONTINUE
6048
6049 * disea-sea chains
6050       DO 20 I=1,NDS
6051          IF (ISKPCH(2,I).EQ.99) GOTO 20
6052          ICCHAI(1,2) = ICCHAI(1,2)+2
6053          IDXP = INTDS1(I)
6054          IDXT = INTDS2(I)
6055          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6056          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6057          DO 21 K=1,4
6058             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6059             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6060             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6061             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6062    21    CONTINUE
6063          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6064      &                                  +(PP1(3)+PT1(3))**2)
6065          ECH   = PP1(4)+PT1(4)
6066          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6067          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6068      &                                  +(PP2(3)+PT2(3))**2)
6069          ECH   = PP2(4)+PT2(4)
6070          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6071          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6072             AM1 = SQRT(AM1)
6073             AM2 = SQRT(AM2)
6074             IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6075 C              WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6076  5001          FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
6077             ENDIF
6078          ELSE
6079             WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6080          ENDIF
6081          IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6082          IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6083          IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6084          IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6085          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6086      &                                                    0,0,2)
6087          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6088      &                                                    0,0,2)
6089          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6090      &                                                    0,0,2)
6091          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6092      &                                                    0,0,2)
6093          NCSY = NCSY+1
6094    20 CONTINUE
6095
6096 * sea-disea chains
6097       DO 30 I=1,NSD
6098          IF (ISKPCH(3,I).EQ.99) GOTO 30
6099          ICCHAI(1,3) = ICCHAI(1,3)+2
6100          IDXP = INTSD1(I)
6101          IDXT = INTSD2(I)
6102          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6103          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6104          DO 31 K=1,4
6105             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6106             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6107             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6108             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6109    31    CONTINUE
6110          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6111      &                                  +(PP1(3)+PT1(3))**2)
6112          ECH   = PP1(4)+PT1(4)
6113          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6114          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6115      &                                  +(PP2(3)+PT2(3))**2)
6116          ECH   = PP2(4)+PT2(4)
6117          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6118          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6119             AM1 = SQRT(AM1)
6120             AM2 = SQRT(AM2)
6121             IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6122 C              WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6123  5002          FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
6124             ENDIF
6125          ELSE
6126             WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6127          ENDIF
6128          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6129          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6130          IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6131          IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6132          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6133      &                                                    0,0,3)
6134          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6135      &                                                    0,0,3)
6136          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6137      &                                                    0,0,3)
6138          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6139      &                                                    0,0,3)
6140          NCSY = NCSY+1
6141    30 CONTINUE
6142
6143 * disea-valence chains
6144       DO 50 I=1,NDV
6145          IF (ISKPCH(5,I).EQ.99) GOTO 50
6146          ICCHAI(1,5) = ICCHAI(1,5)+2
6147          IDXP = INTDV1(I)
6148          IDXT = INTDV2(I)
6149          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6150          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6151          DO 51 K=1,4
6152             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6153             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6154             PT1(K) = XTVQ(IDXT) *PHKK(K,MOT)
6155             PT2(K) = XTVD(IDXT) *PHKK(K,MOT)
6156    51    CONTINUE
6157          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6158      &                                  +(PP1(3)+PT1(3))**2)
6159          ECH   = PP1(4)+PT1(4)
6160          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6161          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6162      &                                  +(PP2(3)+PT2(3))**2)
6163          ECH   = PP2(4)+PT2(4)
6164          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6165          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6166             AM1 = SQRT(AM1)
6167             AM2 = SQRT(AM2)
6168             IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6169 C              WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6170  5003          FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
6171             ENDIF
6172          ELSE
6173             WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6174          ENDIF
6175          IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6176          IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6177          IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6178          IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6179          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6180      &                                                    0,0,5)
6181          CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6182      &                                                    0,0,5)
6183          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6184      &                                                    0,0,5)
6185          CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6186      &                                                    0,0,5)
6187          NCSY = NCSY+1
6188    50 CONTINUE
6189
6190 * valence-sea chains
6191       DO 60 I=1,NVS
6192          IF (ISKPCH(6,I).EQ.99) GOTO 60
6193          ICCHAI(1,6) = ICCHAI(1,6)+2
6194          IDXP = INTVS1(I)
6195          IDXT = INTVS2(I)
6196          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6197          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6198          DO 61 K=1,4
6199             PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6200             PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6201             PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6202             PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6203    61    CONTINUE
6204          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6205          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6206          IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6207          IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6208          CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6209          IF (LCHK) THEN
6210             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6211      &                                                       0,0,6)
6212             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6213      &                                                       0,0,6)
6214             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6215      &                                                       0,0,6)
6216             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6217      &                                                       0,0,6)
6218             PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6219      &                                     +(PP1(3)+PT1(3))**2)
6220             ECH   = PP1(4)+PT1(4)
6221             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6222             PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6223      &                                     +(PP2(3)+PT2(3))**2)
6224             ECH   = PP2(4)+PT2(4)
6225             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6226          ELSE
6227             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6228      &                                                       0,0,6)
6229             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6230      &                                                       0,0,6)
6231             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6232      &                                                       0,0,6)
6233             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6234      &                                                       0,0,6)
6235             PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6236      &                                     +(PP1(3)+PT2(3))**2)
6237             ECH   = PP1(4)+PT2(4)
6238             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6239             PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6240      &                                     +(PP2(3)+PT1(3))**2)
6241             ECH   = PP2(4)+PT1(4)
6242             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6243          ENDIF
6244          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6245             AM1 = SQRT(AM1)
6246             AM2 = SQRT(AM2)
6247             IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
6248 C              WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6249  5004          FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
6250             ENDIF
6251          ELSE
6252             WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6253          ENDIF
6254          NCSY = NCSY+1
6255    60 CONTINUE
6256
6257 * sea-valence chains
6258       DO 40 I=1,NSV
6259          IF (ISKPCH(4,I).EQ.99) GOTO 40
6260          ICCHAI(1,4) = ICCHAI(1,4)+2
6261          IDXP = INTSV1(I)
6262          IDXT = INTSV2(I)
6263          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6264          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6265          DO 41 K=1,4
6266             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6267             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6268             PT1(K) = XTVD(IDXT) *PHKK(K,MOT)
6269             PT2(K) = XTVQ(IDXT) *PHKK(K,MOT)
6270    41    CONTINUE
6271          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6272      &                                  +(PP1(3)+PT1(3))**2)
6273          ECH   = PP1(4)+PT1(4)
6274          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6275          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6276      &                                  +(PP2(3)+PT2(3))**2)
6277          ECH   = PP2(4)+PT2(4)
6278          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6279          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6280             AM1 = SQRT(AM1)
6281             AM2 = SQRT(AM2)
6282             IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
6283 C              WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6284  5005          FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
6285             ENDIF
6286          ELSE
6287             WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6288          ENDIF
6289          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6290          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6291          IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6292          IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6293          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6294      &                                                    0,0,4)
6295          CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6296      &                                                    0,0,4)
6297          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6298      &                                                    0,0,4)
6299          CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6300      &                                                    0,0,4)
6301          NCSY = NCSY+1
6302    40 CONTINUE
6303
6304 * valence-disea chains
6305       DO 70 I=1,NVD
6306          IF (ISKPCH(7,I).EQ.99) GOTO 70
6307          ICCHAI(1,7) = ICCHAI(1,7)+2
6308          IDXP = INTVD1(I)
6309          IDXT = INTVD2(I)
6310          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6311          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6312          DO 71 K=1,4
6313             PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6314             PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6315             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6316             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6317    71    CONTINUE
6318          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6319          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6320          IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6321          IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6322          CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6323          IF (LCHK) THEN
6324             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6325      &                                                       0,0,7)
6326             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6327      &                                                       0,0,7)
6328             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6329      &                                                       0,0,7)
6330             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6331      &                                                       0,0,7)
6332             PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6333      &                                     +(PP1(3)+PT1(3))**2)
6334             ECH   = PP1(4)+PT1(4)
6335             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6336             PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6337      &                                     +(PP2(3)+PT2(3))**2)
6338             ECH   = PP2(4)+PT2(4)
6339             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6340          ELSE
6341             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6342      &                                                       0,0,7)
6343             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6344      &                                                       0,0,7)
6345             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6346      &                                                       0,0,7)
6347             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6348      &                                                       0,0,7)
6349             PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6350      &                                     +(PP1(3)+PT2(3))**2)
6351             ECH   = PP1(4)+PT2(4)
6352             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6353             PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6354      &                                     +(PP2(3)+PT1(3))**2)
6355             ECH   = PP2(4)+PT1(4)
6356             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6357          ENDIF
6358          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6359             AM1 = SQRT(AM1)
6360             AM2 = SQRT(AM2)
6361             IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6362 C              WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6363  5006          FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
6364             ENDIF
6365          ELSE
6366             WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6367          ENDIF
6368          NCSY = NCSY+1
6369    70 CONTINUE
6370
6371 * valence-valence chains
6372       DO 80 I=1,NVV
6373          IF (ISKPCH(8,I).EQ.99) GOTO 80
6374          ICCHAI(1,8) = ICCHAI(1,8)+2
6375          IDXP = INTVV1(I)
6376          IDXT = INTVV2(I)
6377          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6378          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6379          DO 81 K=1,4
6380             PP1(K) = XPVQ(IDXP)*PHKK(K,MOP)
6381             PP2(K) = XPVD(IDXP)*PHKK(K,MOP)
6382             PT1(K) = XTVD(IDXT)*PHKK(K,MOT)
6383             PT2(K) = XTVQ(IDXT)*PHKK(K,MOT)
6384    81    CONTINUE
6385          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6386          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6387          IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6388          IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6389
6390 * check for diffractive event
6391          IDIFF = 0
6392          IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
6393      &        (IP.EQ.1).AND.(NN.EQ.1)) THEN
6394             DO 800 K=1,4
6395                PP(K) = PP1(K)+PP2(K)
6396                PT(K) = PT1(K)+PT2(K)
6397   800       CONTINUE
6398             ISTCK = NHKK
6399             CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
6400      &                  IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
6401 C           IF (IREJ1.NE.0) GOTO 9999
6402             IF (IREJ1.NE.0) THEN
6403                IDIFF = 0
6404                NHKK  = ISTCK
6405             ENDIF
6406          ELSE
6407             IDIFF = 0
6408          ENDIF
6409
6410          IF (IDIFF.EQ.0) THEN
6411 *   valence-valence chain system
6412             CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6413             IF (LCHK) THEN
6414 *    baryon-baryon
6415                CALL DT_EVTPUT(-21,IFP1,MOP,0,
6416      &                     PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6417                CALL DT_EVTPUT(-22,IFT1,MOT,0,
6418      &                     PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6419                CALL DT_EVTPUT(-21,IFP2,MOP,0,
6420      &                     PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6421                CALL DT_EVTPUT(-22,IFT2,MOT,0,
6422      &                     PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6423                PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6424      &                                        +(PP1(3)+PT1(3))**2)
6425                ECH   = PP1(4)+PT1(4)
6426                AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6427                PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6428      &                                        +(PP2(3)+PT2(3))**2)
6429                ECH   = PP2(4)+PT2(4)
6430                AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6431             ELSE
6432 *    antibaryon-baryon
6433                CALL DT_EVTPUT(-21,IFP1,MOP,0,
6434      &                     PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6435                CALL DT_EVTPUT(-22,IFT2,MOT,0,
6436      &                     PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6437                CALL DT_EVTPUT(-21,IFP2,MOP,0,
6438      &                     PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6439                CALL DT_EVTPUT(-22,IFT1,MOT,0,
6440      &                     PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6441                PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6442      &                                        +(PP1(3)+PT2(3))**2)
6443                ECH   = PP1(4)+PT2(4)
6444                AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6445                PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6446      &                                        +(PP2(3)+PT1(3))**2)
6447                ECH   = PP2(4)+PT1(4)
6448                AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6449             ENDIF
6450             IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6451                AM1 = SQRT(AM1)
6452                AM2 = SQRT(AM2)
6453                IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
6454 C                 WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6455  5007             FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
6456                ENDIF
6457             ELSE
6458                WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6459             ENDIF
6460             NCSY = NCSY+1
6461          ENDIF
6462    80 CONTINUE
6463       IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
6464
6465 * energy-momentum & flavor conservation check
6466       IF (ABS(IDIFF).NE.1) THEN
6467          IF (IDIFF.NE.0) THEN
6468             IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0,
6469      &                                              1,3,10,IREJ)
6470          ELSE
6471             IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
6472      &                                              1,3,10,IREJ)
6473          ENDIF
6474          IF (IREJ.NE.0) THEN
6475             CALL DT_EVTOUT(4)
6476             STOP
6477          ENDIF
6478       ENDIF
6479
6480       RETURN
6481
6482  9999 CONTINUE
6483       IREJ  = 1
6484       RETURN
6485       END
6486
6487 *$ CREATE DT_CHKCSY.FOR
6488 *COPY DT_CHKCSY
6489 *
6490 *===chkcsy=============================================================*
6491 *
6492       SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
6493
6494 ************************************************************************
6495 * CHeCk Chain SYstem for consistency of partons at chain ends.         *
6496 *            ID1,ID2        PDG-numbers of partons at chain ends       *
6497 *            LCHK = .true.  consistent chain                           *
6498 *                 = .false. inconsistent chain                         *
6499 * This version dated 18.01.95 is written by S. Roesler                 *
6500 ************************************************************************
6501
6502       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6503       SAVE
6504       PARAMETER ( LINP = 10 ,
6505      &            LOUT = 6 ,
6506      &            LDAT = 9 )
6507
6508       LOGICAL LCHK
6509
6510       LCHK = .TRUE.
6511
6512 * q-aq chain
6513       IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN
6514          IF (ID1*ID2.GT.0) LCHK = .FALSE.
6515 * q-qq, aq-aqaq chain
6516       ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR.
6517      &        ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN
6518          IF (ID1*ID2.LT.0) LCHK = .FALSE.
6519 * qq-aqaq chain
6520       ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
6521          IF (ID1*ID2.GT.0) LCHK = .FALSE.
6522       ENDIF
6523
6524       RETURN
6525       END
6526
6527 *$ CREATE DT_EVENTA.FOR
6528 *COPY DT_EVENTA
6529 *
6530 *===eventa=============================================================*
6531 *
6532       SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
6533
6534 ************************************************************************
6535 * Treatment of nucleon-nucleon interactions in a two-chain             *
6536 * approximation.                                                       *
6537 *  (input) ID       BAMJET-index of projectile hadron (in case of      *
6538 *                   h-K scattering)                                    *
6539 *          IP/IT    mass number of projectile/target nucleus           *
6540 *          NCSY     number of two chain systems                        *
6541 *          IREJ     rejection flag                                     *
6542 * This version dated 15.01.95 is written by S. Roesler                 *
6543 ************************************************************************
6544
6545       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6546       SAVE
6547       PARAMETER ( LINP = 10 ,
6548      &            LOUT = 6 ,
6549      &            LDAT = 9 )
6550       PARAMETER (TINY10=1.0D-10)
6551
6552 * event history
6553       PARAMETER (NMXHKK=200000)
6554       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6555      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6556      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6557 * extended event history
6558       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6559      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6560      &                IHIST(2,NMXHKK)
6561 * rejection counter
6562       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6563      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6564      &                IREXCI(3),IRDIFF(2),IRINC
6565 * flags for diffractive interactions (DTUNUC 1.x)
6566       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6567 * particle properties (BAMJET index convention)
6568       CHARACTER*8  ANAME
6569       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6570      &                IICH(210),IIBAR(210),K1(210),K2(210)
6571 * flags for input different options
6572       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6573       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6574      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6575 * various options for treatment of partons (DTUNUC 1.x)
6576 * (chain recombination, Cronin,..)
6577       LOGICAL LCO2CR,LINTPT
6578       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6579      &                LCO2CR,LINTPT
6580
6581       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
6582
6583       IREJ      = 0
6584       NPOINT(3) = NHKK+1
6585
6586 * skip following treatment for low-mass diffraction
6587       IF (ABS(IFLAGD).EQ.1) THEN
6588          NPOINT(3) = NPOINT(2)
6589          GOTO 5
6590       ENDIF
6591
6592 * multiple scattering of chain ends
6593       IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
6594       IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
6595
6596       NC = NPOINT(2)
6597 * get a two-chain system from DTEVT1
6598       DO 3 I=1,NCSY
6599          IFP1 = IDHKK(NC)
6600          IFT1 = IDHKK(NC+1)
6601          IFP2 = IDHKK(NC+2)
6602          IFT2 = IDHKK(NC+3)
6603          DO 4 K=1,4
6604             PP1(K) = PHKK(K,NC)
6605             PT1(K) = PHKK(K,NC+1)
6606             PP2(K) = PHKK(K,NC+2)
6607             PT2(K) = PHKK(K,NC+3)
6608     4    CONTINUE
6609          MOP1 = NC
6610          MOT1 = NC+1
6611          MOP2 = NC+2
6612          MOT2 = NC+3
6613          CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
6614      &               IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
6615          IF (IREJ1.GT.0) THEN
6616             IRHHA = IRHHA+1
6617             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
6618             GOTO 9999
6619          ENDIF
6620          NC = NC+4
6621     3 CONTINUE
6622
6623 * meson/antibaryon projectile:
6624 * sample single-chain valence-valence systems (Reggeon contrib.)
6625       IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN
6626          IF (IIBAR(ID).LE.0) CALL DT_VV2SCH
6627       ENDIF
6628
6629       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6630 * check DTEVT1 for remaining resonance mass corrections
6631          CALL DT_EVTRES(IREJ1)
6632          IF (IREJ1.GT.0) THEN
6633             IRRES(1) = IRRES(1)+1
6634             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA'
6635             GOTO 9999
6636          ENDIF
6637       ENDIF
6638
6639 * assign p_t to two-"chain" systems consisting of two resonances only
6640 * since only entries for chains will be affected, this is obsolete
6641 * in case of JETSET-fragmetation
6642       CALL DT_RESPT
6643
6644 * combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
6645       IF (LCO2CR) CALL DT_COM2CR
6646
6647     5 CONTINUE
6648
6649 * fragmentation of the complete event
6650 **uncomment for internal phojet-fragmentation
6651 C     CALL DT_EVTFRA(IREJ1)
6652       CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
6653       IF (IREJ1.GT.0) THEN
6654          IRFRAG = IRFRAG+1
6655          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
6656          GOTO 9999
6657       ENDIF
6658
6659 * decay of possible resonances (should be obsolete)
6660       CALL DT_DECAY1
6661
6662       RETURN
6663
6664  9999 CONTINUE
6665       IREVT = IREVT+1
6666       IREJ  = 1
6667       RETURN
6668       END
6669
6670 *$ CREATE DT_GETCSY.FOR
6671 *COPY DT_GETCSY
6672 *
6673 *===getcsy=============================================================*
6674 *
6675       SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
6676      &                  IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
6677
6678 ************************************************************************
6679 * This version dated 15.01.95 is written by S. Roesler                 *
6680 ************************************************************************
6681
6682       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6683       SAVE
6684       PARAMETER ( LINP = 10 ,
6685      &            LOUT = 6 ,
6686      &            LDAT = 9 )
6687       PARAMETER (TINY10=1.0D-10)
6688
6689 * event history
6690       PARAMETER (NMXHKK=200000)
6691       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6692      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6693      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6694 * extended event history
6695       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6696      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6697      &                IHIST(2,NMXHKK)
6698 * rejection counter
6699       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6700      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6701      &                IREXCI(3),IRDIFF(2),IRINC
6702 * flags for input different options
6703       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6704       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6705      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6706 * flags for diffractive interactions (DTUNUC 1.x)
6707       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6708
6709       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
6710      &          IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
6711
6712       IREJ  = 0
6713
6714 * get quark content of partons
6715       DO 1 I=1,2
6716          IFP1(I) = 0
6717          IFP2(I) = 0
6718          IFT1(I) = 0
6719          IFT2(I) = 0
6720     1 CONTINUE
6721       IFP1(1) = IDT_IPDG2B(IFPR1,1,2)
6722       IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2)
6723       IFP2(1) = IDT_IPDG2B(IFPR2,1,2)
6724       IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2)
6725       IFT1(1) = IDT_IPDG2B(IFTA1,1,2)
6726       IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2)
6727       IFT2(1) = IDT_IPDG2B(IFTA2,1,2)
6728       IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2)
6729
6730 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
6731       IDCH1 = 2
6732       IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1
6733       IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3
6734       IDCH2 = 2
6735       IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1
6736       IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3
6737
6738 * store initial configuration for energy-momentum cons. check
6739       IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
6740
6741 * sample intrinsic p_t at chain-ends
6742       CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2,
6743      &            PT1,IFTA1,IFT1,PT2,IFTA2,IFT2,
6744      &            AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1)
6745       IF (IREJ1.NE.0) THEN
6746          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY'
6747          IRPT = IRPT+1
6748          GOTO 9999
6749       ENDIF
6750
6751 C      IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6752 C         IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
6753 C* check second chain for resonance
6754 C            CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6755 C     &                  AMCH2,AMCH2N,IDCH2,IREJ1)
6756 C            IF (IREJ1.NE.0) GOTO 9999
6757 C            IF (IDR2.NE.0) THEN
6758 C               CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6759 C     &                     AMCH2,AMCH2N,AMCH1,IREJ1)
6760 C               IF (IREJ1.NE.0) GOTO 9999
6761 C            ENDIF
6762 C* check first chain for resonance
6763 C            CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6764 C     &                  AMCH1,AMCH1N,IDCH1,IREJ1)
6765 C            IF (IREJ1.NE.0) GOTO 9999
6766 C            IF (IDR1.NE.0) IDR1 = 100*IDR1
6767 C         ELSE
6768 C* check first chain for resonance
6769 C            CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6770 C     &                  AMCH1,AMCH1N,IDCH1,IREJ1)
6771 C            IF (IREJ1.NE.0) GOTO 9999
6772 C            IF (IDR1.NE.0) THEN
6773 C               CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6774 C     &                     AMCH1,AMCH1N,AMCH2,IREJ1)
6775 C               IF (IREJ1.NE.0) GOTO 9999
6776 C            ENDIF
6777 C* check second chain for resonance
6778 C            CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6779 C     &                  AMCH2,AMCH2N,IDCH2,IREJ1)
6780 C            IF (IREJ1.NE.0) GOTO 9999
6781 C            IF (IDR2.NE.0) IDR2 = 100*IDR2
6782 C         ENDIF
6783 C      ENDIF
6784
6785       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6786 * check chains for resonances
6787          CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6788      &               AMCH1,AMCH1N,IDCH1,IREJ1)
6789          IF (IREJ1.NE.0) GOTO 9999
6790          CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6791      &               AMCH2,AMCH2N,IDCH2,IREJ1)
6792          IF (IREJ1.NE.0) GOTO 9999
6793 * change kinematics corresponding to resonance-masses
6794          IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN
6795             CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6796      &                                 AMCH1,AMCH1N,AMCH2,IREJ1)
6797             IF (IREJ1.GT.0) GOTO 9999
6798             IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6799             CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6800      &                  AMCH2,AMCH2N,IDCH2,IREJ1)
6801             IF (IREJ1.NE.0) GOTO 9999
6802             IF (IDR2.NE.0) IDR2 = 100*IDR2
6803          ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN
6804             CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6805      &                                 AMCH2,AMCH2N,AMCH1,IREJ1)
6806             IF (IREJ1.GT.0) GOTO 9999
6807             IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6808             CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6809      &                  AMCH1,AMCH1N,IDCH1,IREJ1)
6810             IF (IREJ1.NE.0) GOTO 9999
6811             IF (IDR1.NE.0) IDR1 = 100*IDR1
6812          ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN
6813             AMDIF1 = ABS(AMCH1-AMCH1N)
6814             AMDIF2 = ABS(AMCH2-AMCH2N)
6815             IF (AMDIF2.LT.AMDIF1) THEN
6816                CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6817      &                                    AMCH2,AMCH2N,AMCH1,IREJ1)
6818                IF (IREJ1.GT.0) GOTO 9999
6819                IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6820                CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),
6821      &                     IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1)
6822                IF (IREJ1.NE.0) GOTO 9999
6823                IF (IDR1.NE.0) IDR1 = 100*IDR1
6824             ELSE
6825                CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6826      &                                    AMCH1,AMCH1N,AMCH2,IREJ1)
6827                IF (IREJ1.GT.0) GOTO 9999
6828                IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6829                CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),
6830      &                     IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1)
6831                IF (IREJ1.NE.0) GOTO 9999
6832                IF (IDR2.NE.0) IDR2 = 100*IDR2
6833             ENDIF
6834          ENDIF
6835       ENDIF
6836
6837 * store final configuration for energy-momentum cons. check
6838       IF (LEMCCK) THEN
6839          CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM)
6840          CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
6841          IF (IREJ1.NE.0) GOTO 9999
6842       ENDIF
6843
6844 * put partons and chains into DTEVT1
6845       DO 10 I=1,4
6846          PCH1(I) = PP1(I)+PT1(I)
6847          PCH2(I) = PP2(I)+PT2(I)
6848    10 CONTINUE
6849       CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2),
6850      &                                      PP1(3),PP1(4),0,0,0)
6851       CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2),
6852      &                                      PT1(3),PT1(4),0,0,0)
6853       KCH = 100+IDCH(MOP1)*10+1
6854       CALL DT_EVTPUT(KCH,88888,-2,-1,
6855      &           PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1))
6856       CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2),
6857      &                                      PP2(3),PP2(4),0,0,0)
6858       CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2),
6859      &                                      PT2(3),PT2(4),0,0,0)
6860       KCH = KCH+1
6861       CALL DT_EVTPUT(KCH,88888,-2,-1,
6862      &           PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
6863
6864       RETURN
6865
6866  9999 CONTINUE
6867       IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN
6868 * "cancel" sea-sea chains
6869          CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1)
6870          IF (IREJ1.NE.0) GOTO 9998
6871 **sr 16.5. flag for EVENTB
6872          IREJ = -1
6873          RETURN
6874       ENDIF
6875  9998 CONTINUE
6876       IREJ = 1
6877       RETURN
6878       END
6879
6880 *$ CREATE DT_CHKINE.FOR
6881 *COPY DT_CHKINE
6882 *
6883 *===chkine=============================================================*
6884 *
6885       SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
6886      &                  AMCH1,AMCH1N,AMCH2,IREJ)
6887
6888 ************************************************************************
6889 * This subroutine replaces CORMOM.                                     *
6890 * This version dated 05.01.95 is written by S. Roesler                 *
6891 ************************************************************************
6892
6893       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6894       SAVE
6895       PARAMETER ( LINP = 10 ,
6896      &            LOUT = 6 ,
6897      &            LDAT = 9 )
6898       PARAMETER (TINY10=1.0D-10)
6899
6900 * flags for input different options
6901       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6902       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6903      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6904 * rejection counter
6905       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6906      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6907      &                IREXCI(3),IRDIFF(2),IRINC
6908
6909       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
6910      &          PP1I(4),PP2I(4),PT1I(4),PT2I(4)
6911
6912       IREJ  = 0
6913       JMSHL = IMSHL
6914
6915       SCALE  = AMCH1N/MAX(AMCH1,TINY10)
6916       DO 10 I=1,4
6917          PP1(I) = PP1I(I)
6918          PP2(I) = PP2I(I)
6919          PT1(I) = PT1I(I)
6920          PT2(I) = PT2I(I)
6921          PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I)
6922          PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I)
6923          PP1(I) = SCALE*PP1(I)
6924          PT1(I) = SCALE*PT1(I)
6925    10 CONTINUE
6926       IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR.
6927      &    (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997
6928
6929       ECH = PP2(4)+PT2(4)
6930       PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+
6931      &                               (PP2(3)+PT2(3))**2 )
6932       AMCH22 = (ECH-PCH)*(ECH+PCH)
6933       IF (AMCH22.LT.0.0D0) THEN
6934          IF (IOULEV(1).GT.0)
6935      &      WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
6936          GOTO 9997
6937       ENDIF
6938
6939       AMCH1 = AMCH1N
6940       AMCH2 = SQRT(AMCH22)
6941
6942 * put partons again on mass shell
6943    13 CONTINUE
6944       XM1 = 0.0D0
6945       XM2 = 0.0D0
6946       IF (JMSHL.EQ.1) THEN
6947          XM1 = PYMASS(IFP1)
6948          XM2 = PYMASS(IFT1)
6949       ENDIF
6950       CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
6951       IF (IREJ1.NE.0) THEN
6952          IF (JMSHL.EQ.0) GOTO 9998
6953          JMSHL = 0
6954          GOTO 13
6955       ENDIF
6956       JMSHL = IMSHL
6957       DO 11 I=1,4
6958          PP1(I) = P1(I)
6959          PT1(I) = P2(I)
6960    11 CONTINUE
6961    14 CONTINUE
6962       XM1 = 0.0D0
6963       XM2 = 0.0D0
6964       IF (JMSHL.EQ.1) THEN
6965          XM1 = PYMASS(IFP2)
6966          XM2 = PYMASS(IFT2)
6967       ENDIF
6968       CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
6969       IF (IREJ1.NE.0) THEN
6970          IF (JMSHL.EQ.0) GOTO 9998
6971          JMSHL = 0
6972          GOTO 14
6973       ENDIF
6974       DO 12 I=1,4
6975          PP2(I) = P1(I)
6976          PT2(I) = P2(I)
6977    12 CONTINUE
6978       DO 15 I=1,4
6979          PP1I(I) = PP1(I)
6980          PP2I(I) = PP2(I)
6981          PT1I(I) = PT1(I)
6982          PT2I(I) = PT2(I)
6983    15 CONTINUE
6984       RETURN
6985
6986  9997 IRCHKI(1) = IRCHKI(1)+1
6987 **sr
6988 C     GOTO 9999
6989       IREJ = -1
6990       RETURN
6991 **
6992  9998 IRCHKI(2) = IRCHKI(2)+1
6993
6994  9999 CONTINUE
6995       IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
6996       IREJ = 1
6997       RETURN
6998       END
6999
7000 *$ CREATE DT_CH2RES.FOR
7001 *COPY DT_CH2RES
7002 *
7003 *===ch2res=============================================================*
7004 *
7005       SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
7006      &                  AM,AMN,IMODE,IREJ)
7007
7008 ************************************************************************
7009 * Check chains for resonance production.                               *
7010 * This subroutine replaces COMCMA/COBCMA/COMCM2                        *
7011 *    input:                                                            *
7012 *          IF1,2,3,4    input flavors (q,aq in any order)              *
7013 *          AM           chain mass                                     *
7014 *          MODE = 1     check q-aq chain for meson-resonance           *
7015 *               = 2     check q-qq, aq-aqaq chain for baryon-resonance *
7016 *               = 3     check qq-aqaq chain for lower mass cut         *
7017 *    output:                                                           *
7018 *          IDR = 0      no resonances found                            *
7019 *              = -1     pseudoscalar meson/octet baryon                *
7020 *              = 1      vector-meson/decuplet baryon                   *
7021 *          IDXR         BAMJET-index of corresponding resonance        *
7022 *          AMN          mass of corresponding resonance                *
7023 *                                                                      *
7024 *          IREJ         rejection flag                                 *
7025 * This version dated 06.01.95 is written by S. Roesler                 *
7026 ************************************************************************
7027
7028       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7029       SAVE
7030       PARAMETER ( LINP = 10 ,
7031      &            LOUT = 6 ,
7032      &            LDAT = 9 )
7033
7034 * particle properties (BAMJET index convention)
7035       CHARACTER*8  ANAME
7036       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7037      &                IICH(210),IIBAR(210),K1(210),K2(210)
7038 * quark-content to particle index conversion (DTUNUC 1.x)
7039       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
7040      &                IA08(6,21),IA10(6,21)
7041 * rejection counter
7042       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7043      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7044      &                IREXCI(3),IRDIFF(2),IRINC
7045 * flags for input different options
7046       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7047       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7048      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7049
7050       DIMENSION IF(4),JF(4)
7051
7052 **sr 4.7. test
7053 C     DATA AMLOM,AMLOB /0.08D0,0.2D0/
7054       DATA AMLOM,AMLOB /0.1D0,0.7D0/
7055 **
7056 C     DATA AMLOM,AMLOB /0.001D0,0.001D0/
7057
7058       MODE = ABS(IMODE)
7059
7060       IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN
7061          WRITE(LOUT,1000) MODE
7062  1000    FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/,
7063      &          1X,'        program stopped')
7064          STOP
7065       ENDIF
7066
7067       AMX  = AM
7068       IREJ = 0
7069       IDR  = 0
7070       IDXR = 0
7071       AMN  = AMX
7072       IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
7073       IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
7074
7075       IF(1) = IF1
7076       IF(2) = IF2
7077       IF(3) = IF3
7078       IF(4) = IF4
7079       NF = 0
7080       DO 100 I=1,4
7081          IF (IF(I).NE.0) THEN
7082             NF = NF+1
7083             JF(NF) = IF(I)
7084          ENDIF
7085   100 CONTINUE
7086       IF (NF.LE.MODE) THEN
7087          WRITE(LOUT,1001) MODE,IF
7088  1001    FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ',
7089      &   I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4)
7090          GOTO 9999
7091       ENDIF
7092
7093       GOTO (1,2,3) MODE
7094
7095 * check for meson resonance
7096     1 CONTINUE
7097       IFQ  = JF(1)
7098       IFAQ = ABS(JF(2))
7099       IF (JF(2).GT.0) THEN
7100          IFQ  = JF(2)
7101          IFAQ = ABS(JF(1))
7102       ENDIF
7103       IFPS = IMPS(IFAQ,IFQ)
7104       IFV  = IMVE(IFAQ,IFQ)
7105       AMPS = AAM(IFPS)
7106       AMV  = AAM(IFV)
7107       AMHI = AMV+0.3D0
7108       IF (AMX.LT.AMV) THEN
7109          IF (AMX.LT.AMPS) THEN
7110             IF (IMODE.GT.0) THEN
7111                IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999
7112             ELSE
7113                IF (AMX.LT.0.8D0*AMPS) GOTO 9999
7114             ENDIF
7115             LOMRES = LOMRES+1
7116          ENDIF
7117 *    replace chain by pseudoscalar meson
7118          IDR  = -1
7119          IDXR = IFPS
7120          AMN  = AMPS
7121       ELSEIF (AMX.LT.AMHI) THEN
7122 *    replace chain by vector-meson
7123          IDR  = 1
7124          IDXR = IFV
7125          AMN  = AMV
7126       ENDIF
7127       RETURN
7128
7129 * check for baryon resonance
7130     2 CONTINUE
7131       CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
7132       AM8  = AAM(JB8)
7133       AM10 = AAM(JB10)
7134       AMHI = AM10+0.3D0
7135       IF (AMX.LT.AM10) THEN
7136          IF (AMX.LT.AM8) THEN
7137             IF (IMODE.GT.0) THEN
7138                IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999
7139             ELSE
7140                IF (AMX.LT.0.8D0*AM8) GOTO 9999
7141             ENDIF
7142             LOBRES = LOBRES+1
7143          ENDIF
7144 *    replace chain by oktet baryon
7145          IDR  = -1
7146          IDXR = JB8
7147          AMN  = AM8
7148       ELSEIF (AMX.LT.AMHI) THEN
7149          IDR  = 1
7150          IDXR = JB10
7151          AMN  = AM10
7152       ENDIF
7153       RETURN
7154
7155 * check qq-aqaq for lower mass cut
7156     3 CONTINUE
7157 *   empirical definition of AMHI to allow for (b-antib)-pair prod.
7158       AMHI = 2.5D0
7159       IF (AMX.LT.AMHI) GOTO 9999
7160       RETURN
7161
7162  9999 CONTINUE
7163       IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
7164      &    WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
7165       IREJ = 1
7166       IRRES(2) = IRRES(2)+1
7167       RETURN
7168       END
7169
7170 *$ CREATE DT_RJSEAC.FOR
7171 *COPY DT_RJSEAC
7172 *
7173 *===rjseac=============================================================*
7174 *
7175       SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
7176
7177 ************************************************************************
7178 * ReJection of SEA-sea Chains.                                         *
7179 *         MOP1/2       entries of projectile sea-partons in DTEVT1     *
7180 *         MOT1/2       entries of projectile sea-partons in DTEVT1     *
7181 * This version dated 16.01.95 is written by S. Roesler                 *
7182 ************************************************************************
7183
7184       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7185       SAVE
7186       PARAMETER ( LINP = 10 ,
7187      &            LOUT = 6 ,
7188      &            LDAT = 9 )
7189       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
7190
7191 * event history
7192       PARAMETER (NMXHKK=200000)
7193       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7194      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7195      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7196 * extended event history
7197       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7198      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7199      &                IHIST(2,NMXHKK)
7200 * statistics
7201       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7202      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7203      &                ICEVTG(8,0:30)
7204
7205       DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
7206
7207       IREJ = 0
7208
7209 * projectile sea q-aq-pair
7210 *    indices of sea-pair
7211       IDXSEA(1,1) = MOP1
7212       IDXSEA(1,2) = MOP2
7213 *    index of mother-nucleon
7214       IDXNUC(1)   = JMOHKK(1,MOP1)
7215 *    status of valence quarks to be corrected
7216       ISTVAL(1)   = -21
7217
7218 * target sea q-aq-pair
7219 *    indices of sea-pair
7220       IDXSEA(2,1) = MOT1
7221       IDXSEA(2,2) = MOT2
7222 *    index of mother-nucleon
7223       IDXNUC(2)   = JMOHKK(1,MOT1)
7224 *    status of valence quarks to be corrected
7225       ISTVAL(2)   = -22
7226
7227       DO 1 N=1,2
7228          IDONE = 0
7229          DO 2 I=NPOINT(2),NHKK
7230             IF ((ISTHKK(I).EQ.ISTVAL(N)).AND.
7231      &          (JMOHKK(1,I).EQ.IDXNUC(N)))   THEN
7232 * valence parton found
7233 *    inrease 4-momentum by sea 4-momentum
7234                DO 3 K=1,4
7235                   PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
7236      &                                  PHKK(K,IDXSEA(N,2))
7237     3          CONTINUE
7238                PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
7239      &                              PHKK(2,I)**2-PHKK(3,I)**2))
7240 *    "cancel" sea-pair
7241                DO 4 J=1,2
7242                   ISTHKK(IDXSEA(N,J))   = 100
7243                   IDHKK(IDXSEA(N,J))    = 0
7244                   JMOHKK(1,IDXSEA(N,J)) = 0
7245                   JMOHKK(2,IDXSEA(N,J)) = 0
7246                   JDAHKK(1,IDXSEA(N,J)) = 0
7247                   JDAHKK(2,IDXSEA(N,J)) = 0
7248                   DO 5 K=1,4
7249                      PHKK(K,IDXSEA(N,J)) = ZERO
7250                      VHKK(K,IDXSEA(N,J)) = ZERO
7251                      WHKK(K,IDXSEA(N,J)) = ZERO
7252     5             CONTINUE
7253                   PHKK(5,IDXSEA(N,J)) = ZERO
7254     4          CONTINUE
7255                IDONE = 1
7256             ENDIF
7257     2    CONTINUE
7258          IF (IDONE.NE.1) THEN
7259             WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2
7260  1000       FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event',
7261      &                '-record!',/,1X,'        sea-quark pairs   ',
7262      &                2I5,4X,2I5,'   could not be canceled!')
7263             GOTO 9999
7264          ENDIF
7265     1 CONTINUE
7266       ICRJSS = ICRJSS+1
7267       RETURN
7268
7269  9999 CONTINUE
7270       IREJ = 1
7271       RETURN
7272       END
7273
7274 *$ CREATE DT_VV2SCH.FOR
7275 *COPY DT_VV2SCH
7276 *
7277 *===vv2sch=============================================================*
7278 *
7279       SUBROUTINE DT_VV2SCH
7280
7281 ************************************************************************
7282 * Change Valence-Valence chain systems to Single CHain systems for     *
7283 * hadron-nucleus collisions with meson or antibaryon projectile.       *
7284 * (Reggeon contribution)                                               *
7285 * The single chain system is approximately treated as one chain and a  *
7286 * meson at rest.                                                       *
7287 * This version dated 18.01.95 is written by S. Roesler                 *
7288 ************************************************************************
7289
7290       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7291       SAVE
7292       PARAMETER ( LINP = 10 ,
7293      &            LOUT = 6 ,
7294      &            LDAT = 9 )
7295       PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
7296
7297       LOGICAL LSTART
7298
7299 * event history
7300       PARAMETER (NMXHKK=200000)
7301       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7302      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7303      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7304 * extended event history
7305       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7306      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7307      &                IHIST(2,NMXHKK)
7308 * flags for input different options
7309       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7310       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7311      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7312 * statistics
7313       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7314      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7315      &                ICEVTG(8,0:30)
7316
7317       DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
7318      &          PCH2(4)
7319
7320       DATA LSTART /.TRUE./
7321
7322       IFSC  = 0
7323       IF (LSTART) THEN
7324          WRITE(LOUT,1000)
7325  1000    FORMAT(/,1X,'VV2SCH:  Reggeon contribution to valance-',
7326      &          'valence chains treated')
7327          LSTART = .FALSE.
7328       ENDIF
7329
7330       NSTOP = NHKK
7331
7332 * get index of first chain
7333       DO 1 I=NPOINT(3),NHKK
7334          IF (IDHKK(I).EQ.88888) THEN
7335             NC = I
7336             GOTO 2
7337          ENDIF
7338     1 CONTINUE
7339
7340     2 CONTINUE
7341       IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)
7342      &                        .AND.(NC.LT.NSTOP)) THEN
7343 * get valence-valence chains
7344          IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN
7345 *   get "mother"-hadron indices
7346             MO1   = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC)))
7347             MO2   = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC)))
7348             KPROJ = IDT_ICIHAD(IDHKK(MO1))
7349             KTARG = IDT_ICIHAD(IDHKK(MO2))
7350 *   Lab momentum of projectile hadron
7351             CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3)
7352             PTOT  = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+
7353      &                                  PHKK(3,MO1)**2)
7354
7355             SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
7356             IF (DT_RNDM(PTOT).LE.SICHAP) THEN
7357                ICVV2S = ICVV2S+1
7358 *   single chain requested
7359 *      get flavors of chain-end partons
7360                MO(1) = JMOHKK(1,NC)
7361                MO(2) = JMOHKK(2,NC)
7362                MO(3) = JMOHKK(1,NC+3)
7363                MO(4) = JMOHKK(2,NC+3)
7364                DO 3 I=1,4
7365                   IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
7366                   IF(I,2) = 0
7367                   IF (ABS(IDHKK(MO(I))).GE.1000)
7368      &               IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
7369     3          CONTINUE
7370 *      which one is the q-aq chain?
7371 *        N1,N1+1 - DTEVT1-entries for q-aq system
7372 *        N2,N2+1 - DTEVT1-entries for the other chain
7373                IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN
7374                   K1 = 1
7375                   K2 = 3
7376                   N1 = NC-2
7377                   N2 = NC+1
7378                ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
7379                   K1 = 3
7380                   K2 = 1
7381                   N1 = NC+1
7382                   N2 = NC-2
7383                ELSE
7384                   GOTO 10
7385                ENDIF
7386                DO 4 K=1,4
7387                   PP1(K) = PHKK(K,N1)
7388                   PT1(K) = PHKK(K,N1+1)
7389                   PP2(K) = PHKK(K,N2)
7390                   PT2(K) = PHKK(K,N2+1)
7391     4          CONTINUE
7392                AMCH1 = PHKK(5,N1+2)
7393                AMCH2 = PHKK(5,N2+2)
7394 *      get meson-identity corresponding to flavors of q-aq chain
7395                ITMP   = IRESRJ
7396                IRESRJ = 0
7397                CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1,
7398      &                     ZERO,AMCH1N,1,IDUM)
7399                IRESRJ = ITMP
7400 *      change kinematics of chains
7401                CALL DT_CHKINE(PP1,IDHKK(N1),  PP2,IDHKK(N2),
7402      &                     PT1,IDHKK(N1+1),PT2,IDHKK(N2+1),
7403      &                     AMCH1,AMCH1N,AMCH2,IREJ1)
7404                IF (IREJ1.NE.0) GOTO 10
7405 *      check second chain for resonance
7406                IDCHAI = 2
7407                IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3
7408                CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2),
7409      &                     IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1)
7410                IF (IREJ1.NE.0) GOTO 10
7411                IF (IDR2.NE.0) IDR2 = 100*IDR2
7412 *      add partons and chains to DTEVT1
7413                DO 5 K=1,4
7414                   PCH1(K) = PP1(K)+PT1(K)
7415                   PCH2(K) = PP2(K)+PT2(K)
7416     5          CONTINUE
7417                CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2),
7418      &                                             PP1(3),PP1(4),0,0,0)
7419                CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1),
7420      &                                      PT1(2),PT1(3),PT1(4),0,0,0)
7421                KCH = ISTHKK(N1+2)+100
7422                CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3),
7423      &                     PCH1(4),IDR1,IDXR1,IDCH(N1+2))
7424                IDHKK(N1+2) = 22222
7425                CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2),
7426      &                                             PP2(3),PP2(4),0,0,0)
7427                CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1),
7428      &                                      PT2(2),PT2(3),PT2(4),0,0,0)
7429                KCH = ISTHKK(N2+2)+100
7430                CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3),
7431      &                     PCH2(4),IDR2,IDXR2,IDCH(N2+2))
7432                IDHKK(N2+2) = 22222
7433             ENDIF
7434          ENDIF
7435       ELSE
7436          GOTO 11
7437       ENDIF
7438    10 CONTINUE
7439       NC = NC+6
7440       GOTO 2
7441
7442    11 CONTINUE
7443
7444       RETURN
7445       END
7446
7447 *$ CREATE DT_PHNSCH.FOR
7448 *COPY DT_PHNSCH
7449 *
7450 *=== phnsch ===========================================================*
7451 *
7452       DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB )
7453
7454 *----------------------------------------------------------------------*
7455 *                                                                      *
7456 *     Probability for Hadron Nucleon Single CHain interactions:        *
7457 *                                                                      *
7458 *     Created on 30 december 1993  by    Alfredo Ferrari & Paola Sala  *
7459 *                                                   Infn - Milan       *
7460 *                                                                      *
7461 *     Last change on 04-jan-94     by    Alfredo Ferrari               *
7462 *                                                                      *
7463 *             modified by J.R.for use in DTUNUC  6.1.94                *
7464 *                                                                      *
7465 *     Input variables:                                                 *
7466 *                      Kp = hadron projectile index (Part numbering    *
7467 *                           scheme)                                    *
7468 *                   Ktarg = target nucleon index (1=proton, 8=neutron) *
7469 *                    Plab = projectile laboratory momentum (GeV/c)     *
7470 *     Output variable:                                                 *
7471 *                  Phnsch = probability per single chain (particle     *
7472 *                           exchange) interactions                     *
7473 *                                                                      *
7474 *----------------------------------------------------------------------*
7475
7476       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7477       SAVE
7478
7479       PARAMETER ( LUNOUT = 6  )
7480       PARAMETER ( LUNERR = 6  )
7481       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
7482       PARAMETER ( ZERZER = 0.D+00 )
7483       PARAMETER ( ONEONE = 1.D+00 )
7484       PARAMETER ( TWOTWO = 2.D+00 )
7485       PARAMETER ( FIVFIV = 5.D+00 )
7486       PARAMETER ( HLFHLF = 0.5D+00 )
7487
7488       PARAMETER ( NALLWP = 39   )
7489       PARAMETER ( IDMAXP = 210  )
7490
7491       DIMENSION ICHRGE(39),AM(39)
7492
7493 * particle properties (BAMJET index convention)
7494       CHARACTER*8  ANAME
7495       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7496      &                IICH(210),IIBAR(210),K1(210),K2(210)
7497
7498       DIMENSION KPTOIP(210)
7499 * auxiliary common for reggeon exchange (DTUNUC 1.x)
7500       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
7501      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
7502      &                IQTCHR(-6:6),MQUARK(3,39)
7503
7504       DIMENSION SGTCOE (5,33), IHLP (NALLWP)
7505       DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15)
7506 CPH      SAVE SGTCOE, IHLP
7507 CPH      SAVE IQFSC1, IQFSC2, IQBSC1, IQBSC2
7508       EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1))
7509       EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11))
7510       EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19))
7511
7512 * Conversion from part to paprop numbering
7513       DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
7514      & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
7515      & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
7516
7517 *  1=baryon, 2=pion, 3=kaon, 4=antibaryon:
7518       DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
7519      &    2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
7520 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
7521       DATA  SGTCO1  /
7522 * 1st reaction: gamma p total
7523      &0.147 D+00, ZERZER  , ZERZER   , 0.0022D+00, -0.0170D+00,
7524 * 2nd reaction: gamma d total
7525      &0.300 D+00, ZERZER  , ZERZER   , 0.0095D+00, -0.057 D+00,
7526 * 3rd reaction: pi+ p total
7527      &16.4  D+00, 19.3D+00, -0.42D+00, 0.19  D+00, ZERZER     ,
7528 * 4th reaction: pi- p total
7529      &33.0  D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03  D+00,
7530 * 5th reaction: pi+/- d total
7531      &56.8  D+00, 42.2D+00, -1.45D+00, 0.65  D+00, -5.39  D+00,
7532 * 6th reaction: K+ p total
7533      &18.1  D+00, ZERZER  , ZERZER   , 0.26  D+00, -1.0   D+00,
7534 * 7th reaction: K+ n total
7535      &18.7  D+00, ZERZER  , ZERZER   , 0.21  D+00, -0.89  D+00,
7536 * 8th reaction: K+ d total
7537      &34.2  D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99  D+00,
7538 * 9th reaction: K- p total
7539      &32.1  D+00, ZERZER  , ZERZER   , 0.66  D+00, -5.6   D+00,
7540 * 10th reaction: K- n total
7541      &25.2  D+00, ZERZER  , ZERZER   , 0.38  D+00, -2.9   D+00/
7542 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
7543       DATA  SGTCO2  /
7544 * 11th reaction: K- d total
7545      &57.6  D+00, ZERZER  , ZERZER   , 1.17  D+00, -9.5   D+00,
7546 * 12th reaction: p p total
7547      &48.0  D+00, ZERZER  , ZERZER   , 0.522 D+00, -4.51  D+00,
7548 * 13th reaction: p n total
7549      &47.30 D+00, ZERZER  , ZERZER   , 0.513 D+00, -4.27  D+00,
7550 * 14th reaction: p d total
7551      &91.3  D+00, ZERZER  , ZERZER   , 1.05  D+00, -8.8   D+00,
7552 * 15th reaction: pbar p total
7553      &38.4  D+00, 77.6D+00, -0.64D+00, 0.26  D+00, -1.2   D+00,
7554 * 16th reaction: pbar n total
7555      &ZERZER    ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7   D+00,
7556 * 17th reaction: pbar d total
7557      &112.  D+00, 125.D+00, -1.08D+00, 1.14  D+00, -12.4  D+00,
7558 * 18th reaction: Lamda p total
7559      &30.4  D+00, ZERZER  , ZERZER   , ZERZER    , 1.6    D+00/
7560 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
7561       DATA SGTCO3  /
7562 * 19th reaction: pi+ p elastic
7563      &ZERZER    , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER     ,
7564 * 20th reaction: pi- p elastic
7565      &1.76  D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER     ,
7566 * 21st reaction: K+ p elastic
7567      &5.0   D+00, 8.1 D+00, -1.8 D+00, 0.16  D+00, -1.3   D+00,
7568 * 22nd reaction: K- p elastic
7569      &7.3   D+00, ZERZER  , ZERZER   , 0.29  D+00, -2.40  D+00,
7570 * 23rd reaction: p p elastic
7571      &11.9  D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85  D+00,
7572 * 24th reaction: p d elastic
7573      &16.1  D+00, ZERZER  , ZERZER   , 0.32  D+00, -3.4   D+00,
7574 * 25th reaction: pbar p elastic
7575      &10.2  D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28  D+00,
7576 * 26th reaction: pbar p elastic bis
7577      &10.6  D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41  D+00,
7578 * 27th reaction: pbar n elastic
7579      &36.5  D+00, ZERZER  , ZERZER   , ZERZER    , -11.9  D+00,
7580 * 28th reaction: Lamda p elastic
7581      &12.3  D+00, ZERZER  , ZERZER   , ZERZER    , -2.4   D+00,
7582 * 29th reaction: K- p ela bis
7583      &7.24  D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35  D+00,
7584 * 30th reaction: pi- p cx
7585      &ZERZER    ,0.912D+00, -1.22D+00, ZERZER    , ZERZER     ,
7586 * 31st reaction: K- p cx
7587      &ZERZER    , 3.39D+00, -1.75D+00, ZERZER    , ZERZER     ,
7588 * 32nd reaction: K+ n cx
7589      &ZERZER    , 7.18D+00, -2.01D+00, ZERZER    , ZERZER     ,
7590 * 33rd reaction: pbar p cx
7591      &ZERZER    , 18.8D+00, -2.01D+00, ZERZER    , ZERZER     /
7592 *
7593 *  +-------------------------------------------------------------------*
7594          ICHRGE(KTARG)=IICH(KTARG)
7595          AM    (KTARG)=AAM (KTARG)
7596 *  |  Check for pi0 (d-dbar)
7597       IF ( KP .NE. 26 ) THEN
7598          IP  = KPTOIP (KP)
7599          IF(IP.EQ.0)IP=1
7600          ICHRGE(IP)=IICH(KP)
7601          AM    (IP)=AAM (KP)
7602 *  |
7603 *  +-------------------------------------------------------------------*
7604 *  |
7605       ELSE
7606          IP = 23
7607          ICHRGE(IP)=0
7608       END IF
7609 *  |
7610 *  +-------------------------------------------------------------------*
7611 *  +-------------------------------------------------------------------*
7612 *  |  No such interactions for baryon-baryon
7613       IF ( IIBAR (KP) .GT. 0 ) THEN
7614          DT_PHNSCH = ZERZER
7615          RETURN
7616 *  |
7617 *  +-------------------------------------------------------------------*
7618 *  |  No "annihilation" diagram possible for K+ p/n
7619       ELSE IF ( IP .EQ. 15 ) THEN
7620          DT_PHNSCH = ZERZER
7621          RETURN
7622 *  |
7623 *  +-------------------------------------------------------------------*
7624 *  |  No "annihilation" diagram possible for K0 p/n
7625       ELSE IF ( IP .EQ. 24 ) THEN
7626          DT_PHNSCH = ZERZER
7627          RETURN
7628 *  |
7629 *  +-------------------------------------------------------------------*
7630 *  |  No "annihilation" diagram possible for Omebar p/n
7631       ELSE IF ( IP .GE. 38 ) THEN
7632          DT_PHNSCH = ZERZER
7633          RETURN
7634       END IF
7635 *  |
7636 *  +-------------------------------------------------------------------*
7637 *  +-------------------------------------------------------------------*
7638 *  |  If the momentum is larger than 50 GeV/c, compute the single
7639 *  |  chain probability at 50 GeV/c and extrapolate to the present
7640 *  |  momentum according to 1/sqrt(s)
7641 *  |  sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
7642 *  |  P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
7643 *  |  sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
7644 *  |  sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
7645 *  |                        x sqrt(s/s(50))
7646 *  |  P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
7647       IF ( PLAB .GT. 50.D+00 ) THEN
7648          PLA    = 50.D+00
7649          AMPSQ  = AM (IP)**2
7650          AMTSQ  = AM (KTARG)**2
7651          EPROJ  = SQRT ( PLAB**2 + AMPSQ )
7652          UMOSQ  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7653          EPROJ  = SQRT ( PLA**2 + AMPSQ )
7654          UMO50  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7655          UMORAT = SQRT ( UMOSQ / UMO50 )
7656 *  |
7657 *  +-------------------------------------------------------------------*
7658 *  |  P < 3 GeV/c
7659       ELSE IF ( PLAB .LT. 3.D+00 ) THEN
7660          PLA    = 3.D+00
7661          AMPSQ  = AM (IP)**2
7662          AMTSQ  = AM (KTARG)**2
7663          EPROJ  = SQRT ( PLAB**2 + AMPSQ )
7664          UMOSQ  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7665          EPROJ  = SQRT ( PLA**2 + AMPSQ )
7666          UMO50  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7667          UMORAT = SQRT ( UMOSQ / UMO50 )
7668 *  |
7669 *  +-------------------------------------------------------------------*
7670 *  |  P < 50 GeV/c
7671       ELSE
7672          PLA    = PLAB
7673          UMORAT = ONEONE
7674       END IF
7675 *  |
7676 *  +-------------------------------------------------------------------*
7677       ALGPLA = LOG (PLA)
7678 *  +-------------------------------------------------------------------*
7679 *  |  Pions:
7680       IF ( IHLP (IP) .EQ. 2 ) THEN
7681          ACOF = SGTCOE (1,3)
7682          BCOF = SGTCOE (2,3)
7683          ENNE = SGTCOE (3,3)
7684          CCOF = SGTCOE (4,3)
7685          DCOF = SGTCOE (5,3)
7686 *  |  Compute the pi+ p total cross section:
7687          SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7688      &          + DCOF * ALGPLA
7689          ACOF = SGTCOE (1,19)
7690          BCOF = SGTCOE (2,19)
7691          ENNE = SGTCOE (3,19)
7692          CCOF = SGTCOE (4,19)
7693          DCOF = SGTCOE (5,19)
7694 *  |  Compute the pi+ p elastic cross section:
7695          SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7696      &          + DCOF * ALGPLA
7697 *  |  Compute the pi+ p inelastic cross section:
7698          SPPPIN = SPPPTT - SPPPEL
7699          ACOF = SGTCOE (1,4)
7700          BCOF = SGTCOE (2,4)
7701          ENNE = SGTCOE (3,4)
7702          CCOF = SGTCOE (4,4)
7703          DCOF = SGTCOE (5,4)
7704 *  |  Compute the pi- p total cross section:
7705          SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7706      &          + DCOF * ALGPLA
7707          ACOF = SGTCOE (1,20)
7708          BCOF = SGTCOE (2,20)
7709          ENNE = SGTCOE (3,20)
7710          CCOF = SGTCOE (4,20)
7711          DCOF = SGTCOE (5,20)
7712 *  |  Compute the pi- p elastic cross section:
7713          SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7714      &          + DCOF * ALGPLA
7715 *  |  Compute the pi- p inelastic cross section:
7716          SPMPIN = SPMPTT - SPMPEL
7717          SIGDIA = SPMPIN - SPPPIN
7718 *  |  +----------------------------------------------------------------*
7719 *  |  |  Charged pions: besides isospin consideration it is supposed
7720 *  |  |                 that (pi+ n)el is almost equal to (pi- p)el
7721 *  |  |                 and  (pi+ p)el "    "     "    "  (pi- n)el
7722 *  |  |                 and all are almost equal among each others
7723 *  |  |                 (reasonable above 5 GeV/c)
7724          IF ( ICHRGE (IP) .NE. 0 ) THEN
7725             KHELP = KTARG / 8
7726             JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP
7727             ACOF = SGTCOE (1,JREAC)
7728             BCOF = SGTCOE (2,JREAC)
7729             ENNE = SGTCOE (3,JREAC)
7730             CCOF = SGTCOE (4,JREAC)
7731             DCOF = SGTCOE (5,JREAC)
7732 *  |  |  Compute the total cross section:
7733             SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7734      &             + DCOF * ALGPLA
7735             JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP
7736             ACOF = SGTCOE (1,JREAC)
7737             BCOF = SGTCOE (2,JREAC)
7738             ENNE = SGTCOE (3,JREAC)
7739             CCOF = SGTCOE (4,JREAC)
7740             DCOF = SGTCOE (5,JREAC)
7741 *  |  |  Compute the elastic cross section:
7742             SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7743      &             + DCOF * ALGPLA
7744 *  |  |  Compute the inelastic cross section:
7745             SHNCIN = SHNCTT - SHNCEL
7746 *  |  |  Number of diagrams:
7747             NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP
7748 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7749             IQFSC1 = 1 + IP - 13
7750             IQFSC2 = 0
7751             IQBSC1 = 1 + KHELP
7752             IQBSC2 = 1 + IP - 13
7753 *  |  |
7754 *  |  +----------------------------------------------------------------*
7755 *  |  |  pi0: besides isospin consideration it is supposed that the
7756 *  |  |       elastic cross section is not very different from
7757 *  |  |       pi+ p and/or pi- p (reasonable above 5 GeV/c)
7758          ELSE
7759             KHELP  = KTARG / 8
7760             K2HLP  = ( KP - 23 ) / 3
7761 *  |  |  Number of diagrams:
7762 *  |  |  For u ubar (k2hlp=0):
7763 *           NDIAGR = 2 - KHELP
7764 *  |  |  For d dbar (k2hlp=1):
7765 *           NDIAGR = 2 + KHELP - K2HLP
7766             NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP
7767             SHNCIN = HLFHLF * ( SPPPIN + SPMPIN )
7768 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7769             IQFSC1 = 1 + K2HLP
7770             IQFSC2 = 0
7771             IQBSC1 = 1 + KHELP
7772             IQBSC2 = 2 - K2HLP
7773          END IF
7774 *  |  |
7775 *  |  +----------------------------------------------------------------*
7776 *  |                                                   end pi's
7777 *  +-------------------------------------------------------------------*
7778 *  |  Kaons:
7779       ELSE IF ( IHLP (IP) .EQ. 3 ) THEN
7780          ACOF = SGTCOE (1,6)
7781          BCOF = SGTCOE (2,6)
7782          ENNE = SGTCOE (3,6)
7783          CCOF = SGTCOE (4,6)
7784          DCOF = SGTCOE (5,6)
7785 *  |  Compute the K+ p total cross section:
7786          SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7787      &          + DCOF * ALGPLA
7788          ACOF = SGTCOE (1,21)
7789          BCOF = SGTCOE (2,21)
7790          ENNE = SGTCOE (3,21)
7791          CCOF = SGTCOE (4,21)
7792          DCOF = SGTCOE (5,21)
7793 *  |  Compute the K+ p elastic cross section:
7794          SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7795      &          + DCOF * ALGPLA
7796 *  |  Compute the K+ p inelastic cross section:
7797          SKPPIN = SKPPTT - SKPPEL
7798          ACOF = SGTCOE (1,9)
7799          BCOF = SGTCOE (2,9)
7800          ENNE = SGTCOE (3,9)
7801          CCOF = SGTCOE (4,9)
7802          DCOF = SGTCOE (5,9)
7803 *  |  Compute the K- p total cross section:
7804          SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7805      &          + DCOF * ALGPLA
7806          ACOF = SGTCOE (1,22)
7807          BCOF = SGTCOE (2,22)
7808          ENNE = SGTCOE (3,22)
7809          CCOF = SGTCOE (4,22)
7810          DCOF = SGTCOE (5,22)
7811 *  |  Compute the K- p elastic cross section:
7812          SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7813      &          + DCOF * ALGPLA
7814 *  |  Compute the K- p inelastic cross section:
7815          SKMPIN = SKMPTT - SKMPEL
7816          SIGDIA = HLFHLF * ( SKMPIN - SKPPIN )
7817 *  |  +----------------------------------------------------------------*
7818 *  |  |  Charged Kaons: actually only K-
7819          IF ( ICHRGE (IP) .NE. 0 ) THEN
7820             KHELP = KTARG / 8
7821 *  |  |  +-------------------------------------------------------------*
7822 *  |  |  |  Proton target:
7823             IF ( KHELP .EQ. 0 ) THEN
7824                SHNCIN = SKMPIN
7825 *  |  |  |  Number of diagrams:
7826                NDIAGR = 2
7827 *  |  |  |
7828 *  |  |  +-------------------------------------------------------------*
7829 *  |  |  |  Neutron target: besides isospin consideration it is supposed
7830 *  |  |  |              that (K- n)el is almost equal to (K- p)el
7831 *  |  |  |              (reasonable above 5 GeV/c)
7832             ELSE
7833                ACOF = SGTCOE (1,10)
7834                BCOF = SGTCOE (2,10)
7835                ENNE = SGTCOE (3,10)
7836                CCOF = SGTCOE (4,10)
7837                DCOF = SGTCOE (5,10)
7838 *  |  |  |  Compute the total cross section:
7839                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7840      &                + DCOF * ALGPLA
7841 *  |  |  |  Compute the elastic cross section:
7842                SHNCEL = SKMPEL
7843 *  |  |  |  Compute the inelastic cross section:
7844                SHNCIN = SHNCTT - SHNCEL
7845 *  |  |  |  Number of diagrams:
7846                NDIAGR = 1
7847             END IF
7848 *  |  |  |
7849 *  |  |  +-------------------------------------------------------------*
7850 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7851             IQFSC1 = 3
7852             IQFSC2 = 0
7853             IQBSC1 = 1 + KHELP
7854             IQBSC2 = 2
7855 *  |  |
7856 *  |  +----------------------------------------------------------------*
7857 *  |  |  K0's: (actually only K0bar)
7858          ELSE
7859             KHELP  = KTARG / 8
7860 *  |  |  +-------------------------------------------------------------*
7861 *  |  |  |  Proton target: (K0bar p)in supposed to be given by
7862 *  |  |  |                 (K- p)in - Sig_diagr
7863             IF ( KHELP .EQ. 0 ) THEN
7864                SHNCIN = SKMPIN - SIGDIA
7865 *  |  |  |  Number of diagrams:
7866                NDIAGR = 1
7867 *  |  |  |
7868 *  |  |  +-------------------------------------------------------------*
7869 *  |  |  |  Neutron target: (K0bar n)in supposed to be given by
7870 *  |  |  |                 (K- n)in + Sig_diagr
7871 *  |  |  |              besides isospin consideration it is supposed
7872 *  |  |  |              that (K- n)el is almost equal to (K- p)el
7873 *  |  |  |              (reasonable above 5 GeV/c)
7874             ELSE
7875                ACOF = SGTCOE (1,10)
7876                BCOF = SGTCOE (2,10)
7877                ENNE = SGTCOE (3,10)
7878                CCOF = SGTCOE (4,10)
7879                DCOF = SGTCOE (5,10)
7880 *  |  |  |  Compute the total cross section:
7881                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7882      &                + DCOF * ALGPLA
7883 *  |  |  |  Compute the elastic cross section:
7884                SHNCEL = SKMPEL
7885 *  |  |  |  Compute the inelastic cross section:
7886                SHNCIN = SHNCTT - SHNCEL + SIGDIA
7887 *  |  |  |  Number of diagrams:
7888                NDIAGR = 2
7889             END IF
7890 *  |  |  |
7891 *  |  |  +-------------------------------------------------------------*
7892 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7893             IQFSC1 = 3
7894             IQFSC2 = 0
7895             IQBSC1 = 1
7896             IQBSC2 = 1 + KHELP
7897          END IF
7898 *  |  |
7899 *  |  +----------------------------------------------------------------*
7900 *  |                                                   end Kaon's
7901 *  +-------------------------------------------------------------------*
7902 *  |  Antinucleons:
7903       ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN
7904 *  |  For momenta between 3 and 5 GeV/c the use of tabulated data
7905 *  |  should be implemented!
7906          ACOF = SGTCOE (1,15)
7907          BCOF = SGTCOE (2,15)
7908          ENNE = SGTCOE (3,15)
7909          CCOF = SGTCOE (4,15)
7910          DCOF = SGTCOE (5,15)
7911 *  |  Compute the pbar p total cross section:
7912          SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7913      &          + DCOF * ALGPLA
7914          IF ( PLA .LT. FIVFIV ) THEN
7915             JREAC = 26
7916          ELSE
7917             JREAC = 25
7918          END IF
7919          ACOF = SGTCOE (1,JREAC)
7920          BCOF = SGTCOE (2,JREAC)
7921          ENNE = SGTCOE (3,JREAC)
7922          CCOF = SGTCOE (4,JREAC)
7923          DCOF = SGTCOE (5,JREAC)
7924 *  |  Compute the pbar p elastic cross section:
7925          SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7926      &          + DCOF * ALGPLA
7927 *  |  Compute the pbar p inelastic cross section:
7928          SAPPIN = SAPPTT - SAPPEL
7929          ACOF = SGTCOE (1,12)
7930          BCOF = SGTCOE (2,12)
7931          ENNE = SGTCOE (3,12)
7932          CCOF = SGTCOE (4,12)
7933          DCOF = SGTCOE (5,12)
7934 *  |  Compute the p p total cross section:
7935          SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7936      &          + DCOF * ALGPLA
7937          ACOF = SGTCOE (1,23)
7938          BCOF = SGTCOE (2,23)
7939          ENNE = SGTCOE (3,23)
7940          CCOF = SGTCOE (4,23)
7941          DCOF = SGTCOE (5,23)
7942 *  |  Compute the p p elastic cross section:
7943          SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7944      &          + DCOF * ALGPLA
7945 *  |  Compute the K- p inelastic cross section:
7946          SPPINE = SPPTOT - SPPELA
7947          SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV
7948          KHELP  = KTARG / 8
7949 *  |  +----------------------------------------------------------------*
7950 *  |  |  Pbar:
7951          IF ( ICHRGE (IP) .NE. 0 ) THEN
7952             NDIAGR = 5 - KHELP
7953 *  |  |  +-------------------------------------------------------------*
7954 *  |  |  |  Proton target:
7955             IF ( KHELP .EQ. 0 ) THEN
7956 *  |  |  |  Number of diagrams:
7957                SHNCIN = SAPPIN
7958                PUUBAR = 0.8D+00
7959 *  |  |  |
7960 *  |  |  +-------------------------------------------------------------*
7961 *  |  |  |  Neutron target: it is supposed that (ap n)el is almost equal
7962 *  |  |  |                  to (ap p)el (reasonable above 5 GeV/c)
7963             ELSE
7964                ACOF = SGTCOE (1,16)
7965                BCOF = SGTCOE (2,16)
7966                ENNE = SGTCOE (3,16)
7967                CCOF = SGTCOE (4,16)
7968                DCOF = SGTCOE (5,16)
7969 *  |  |  |  Compute the total cross section:
7970                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7971      &                + DCOF * ALGPLA
7972 *  |  |  |  Compute the elastic cross section:
7973                SHNCEL = SAPPEL
7974 *  |  |  |  Compute the inelastic cross section:
7975                SHNCIN = SHNCTT - SHNCEL
7976                PUUBAR = HLFHLF
7977             END IF
7978 *  |  |  |
7979 *  |  |  +-------------------------------------------------------------*
7980 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7981 *  |  |  there are different possibilities, make a random choiche:
7982             IQFSC1 = -1
7983             RNCHEN = DT_RNDM(PUUBAR)
7984             IF ( RNCHEN .LT. PUUBAR ) THEN
7985                IQFSC2 = -2
7986             ELSE
7987                IQFSC2 = -1
7988             END IF
7989             IQBSC1 = -IQFSC1 + KHELP
7990             IQBSC2 = -IQFSC2
7991 *  |  |
7992 *  |  +----------------------------------------------------------------*
7993 *  |  |  nbar:
7994          ELSE
7995             NDIAGR = 4 + KHELP
7996 *  |  |  +-------------------------------------------------------------*
7997 *  |  |  |  Proton target: (nbar p)in supposed to be given by
7998 *  |  |  |                 (pbar p)in - Sig_diagr
7999             IF ( KHELP .EQ. 0 ) THEN
8000                SHNCIN = SAPPIN - SIGDIA
8001                PDDBAR = HLFHLF
8002 *  |  |  |
8003 *  |  |  +-------------------------------------------------------------*
8004 *  |  |  |  Neutron target: (nbar n)el is supposed to be equal to
8005 *  |  |  |                  (pbar p)el (reasonable above 5 GeV/c)
8006             ELSE
8007 *  |  |  |  Compute the total cross section:
8008                SHNCTT = SAPPTT
8009 *  |  |  |  Compute the elastic cross section:
8010                SHNCEL = SAPPEL
8011 *  |  |  |  Compute the inelastic cross section:
8012                SHNCIN = SHNCTT - SHNCEL
8013                PDDBAR = 0.8D+00
8014             END IF
8015 *  |  |  |
8016 *  |  |  +-------------------------------------------------------------*
8017 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8018 *  |  |  there are different possibilities, make a random choiche:
8019             IQFSC1 = -2
8020             RNCHEN = DT_RNDM(RNCHEN)
8021             IF ( RNCHEN .LT. PDDBAR ) THEN
8022                IQFSC2 = -1
8023             ELSE
8024                IQFSC2 = -2
8025             END IF
8026             IQBSC1 = -IQFSC1 + KHELP - 1
8027             IQBSC2 = -IQFSC2
8028          END IF
8029 *  |  |
8030 *  |  +----------------------------------------------------------------*
8031 *  |
8032 *  +-------------------------------------------------------------------*
8033 *  |  Others: not yet implemented
8034       ELSE
8035          SIGDIA = ZERZER
8036          SHNCIN = ONEONE
8037          NDIAGR = 0
8038          DT_PHNSCH = ZERZER
8039          RETURN
8040       END IF
8041 *  |                                                   end others
8042 *  +-------------------------------------------------------------------*
8043       DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN
8044       IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1)
8045      &       + IQECHR (IQBSC2)
8046       IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1)
8047      &       + IQBCHR (IQBSC2)
8048       IQECHC = IQECHC / 3
8049       IQBCHC = IQBCHC / 3
8050       IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1)
8051      &       + IQSCHR (IQBSC2)
8052       IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP))
8053      &       + IQSCHR (MQUARK(3,IP))
8054 *  +-------------------------------------------------------------------*
8055 *  |  Consistency check:
8056       IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN
8057          WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla',
8058      &                         DT_PHNSCH,KP,KTARG,PLA,' ****'
8059          WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla',
8060      &                         DT_PHNSCH,KP,KTARG,PLA,' ****'
8061          DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER )
8062          DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE )
8063       END IF
8064 *  |
8065 *  +-------------------------------------------------------------------*
8066 *  +-------------------------------------------------------------------*
8067 *  |  Consistency check:
8068       IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG)
8069      &     .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN
8070          WRITE (LUNOUT,*)
8071      &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8072      &      IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8073          WRITE (LUNERR,*)
8074      &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8075      &      IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8076       END IF
8077 *  |
8078 *  +-------------------------------------------------------------------*
8079 *  P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8080       IF ( UMORAT .GT. ONEPLS )
8081      &   DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH
8082      &                                 - ONEONE ) * UMORAT + ONEONE )
8083       RETURN
8084 *
8085       ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 )
8086       DT_SCHQUA = ONEONE
8087       JQFSC1 = IQFSC1
8088       JQFSC2 = IQFSC2
8089       JQBSC1 = IQBSC1
8090       JQBSC2 = IQBSC2
8091 *=== End of function Phnsch ===========================================*
8092       RETURN
8093       END
8094
8095 *$ CREATE DT_RESPT.FOR
8096 *COPY DT_RESPT
8097 *
8098 *===respt==============================================================*
8099 *
8100       SUBROUTINE DT_RESPT
8101
8102 ************************************************************************
8103 * Check DTEVT1 for two-resonance systems and sample intrinsic p_t.     *
8104 * This version dated 18.01.95 is written by S. Roesler                 *
8105 ************************************************************************
8106
8107       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8108       SAVE
8109       PARAMETER ( LINP = 10 ,
8110      &            LOUT = 6 ,
8111      &            LDAT = 9 )
8112       PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8113
8114 * event history
8115       PARAMETER (NMXHKK=200000)
8116       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8117      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8118      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8119 * extended event history
8120       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8121      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8122      &                IHIST(2,NMXHKK)
8123
8124 * get index of first chain
8125       DO 1 I=NPOINT(3),NHKK
8126          IF (IDHKK(I).EQ.88888) THEN
8127             NC = I
8128             GOTO 2
8129          ENDIF
8130     1 CONTINUE
8131
8132     2 CONTINUE
8133       IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN
8134 C        WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3)
8135 * skip VV-,SS- systems
8136          IF ((IDCH(NC  ).NE.1).AND.(IDCH(NC  ).NE.8).AND.
8137      &       (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN
8138 * check if both "chains" are resonances
8139             IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN
8140                CALL DT_SAPTRE(NC,NC+3)
8141             ENDIF
8142          ENDIF
8143       ELSE
8144          GOTO 3
8145       ENDIF
8146       NC = NC+6
8147       GOTO 2
8148
8149     3 CONTINUE
8150
8151       RETURN
8152       END
8153
8154 *$ CREATE DT_EVTRES.FOR
8155 *COPY DT_EVTRES
8156 *
8157 *===evtres=============================================================*
8158 *
8159       SUBROUTINE DT_EVTRES(IREJ)
8160
8161 ************************************************************************
8162 * This version dated 14.12.94 is written by S. Roesler                 *
8163 ************************************************************************
8164
8165       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8166       SAVE
8167       PARAMETER ( LINP = 10 ,
8168      &            LOUT = 6 ,
8169      &            LDAT = 9 )
8170       PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10)
8171
8172 * event history
8173       PARAMETER (NMXHKK=200000)
8174       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8175      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8176      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8177 * extended event history
8178       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8179      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8180      &                IHIST(2,NMXHKK)
8181 * flags for input different options
8182       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8183       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8184      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8185 * particle properties (BAMJET index convention)
8186       CHARACTER*8  ANAME
8187       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
8188      &                IICH(210),IIBAR(210),K1(210),K2(210)
8189
8190       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2)
8191
8192       IREJ = 0
8193
8194       DO 1 I=NPOINT(3),NHKK
8195          IF (ABS(IDRES(I)).GE.100) THEN
8196             AMMX = 0.0D0
8197             DO 2 J=NPOINT(3),NHKK
8198                IF (IDHKK(J).EQ.88888) THEN
8199                   IF (PHKK(5,J).GT.AMMX) THEN
8200                      AMMX = PHKK(5,J)
8201                      IMMX = J
8202                   ENDIF
8203                ENDIF
8204     2       CONTINUE
8205             IF (IDRES(IMMX).NE.0) THEN
8206                IF (IOULEV(3).GT.0) THEN
8207                   WRITE(LOUT,'(1X,A)')
8208      &               'EVTRES: no chain for correc. found'
8209 C                 GOTO 6
8210                   GOTO 9999
8211                ELSE
8212                   GOTO 9999
8213                ENDIF
8214             ENDIF
8215             IMO11  = JMOHKK(1,I)
8216             IMO12  = JMOHKK(2,I)
8217             IF (PHKK(3,IMO11).LT.0.0D0) THEN
8218                IMO11 = JMOHKK(2,I)
8219                IMO12 = JMOHKK(1,I)
8220             ENDIF
8221             IMO21  = JMOHKK(1,IMMX)
8222             IMO22  = JMOHKK(2,IMMX)
8223             IF (PHKK(3,IMO21).LT.0.0D0) THEN
8224                IMO21 = JMOHKK(2,IMMX)
8225                IMO22 = JMOHKK(1,IMMX)
8226             ENDIF
8227             AMCH1  = PHKK(5,I)
8228             AMCH1N = AAM(IDXRES(I))
8229
8230             IFPR1 = IDHKK(IMO11)
8231             IFPR2 = IDHKK(IMO21)
8232             IFTA1 = IDHKK(IMO12)
8233             IFTA2 = IDHKK(IMO22)
8234             DO 4 J=1,4
8235                PP1(J) = PHKK(J,IMO11)
8236                PP2(J) = PHKK(J,IMO21)
8237                PT1(J) = PHKK(J,IMO12)
8238                PT2(J) = PHKK(J,IMO22)
8239     4       CONTINUE
8240 * store initial configuration for energy-momentum cons. check
8241             IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1)
8242 * correct kinematics of second chain
8243             CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
8244      &                  AMCH1,AMCH1N,AMCH2,IREJ1)
8245             IF (IREJ1.NE.0) GOTO 9999
8246 * check now this chain for resonance mass
8247             IFP(1) = IDT_IPDG2B(IFPR2,1,2)
8248             IFP(2) = 0
8249             IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2)
8250             IFT(1) = IDT_IPDG2B(IFTA2,1,2)
8251             IFT(2) = 0
8252             IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2)
8253             IDCH2 = 2
8254             IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1
8255             IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3
8256             CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2,
8257      &                  AMCH2,AMCH2N,IDCH2,IREJ1)
8258             IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN
8259                IF (IOULEV(1).GT.0)
8260      &            WRITE(LOUT,*) ' correction for resonance not poss.'
8261 **sr test
8262 C              GOTO 1
8263 C              GOTO 9999
8264 **
8265             ENDIF
8266 * store final configuration for energy-momentum cons. check
8267             IF (LEMCCK) THEN
8268                CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1)
8269                CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
8270                IF (IREJ1.NE.0) GOTO 9999
8271             ENDIF
8272             DO 5 J=1,4
8273                PHKK(J,IMO11) = PP1(J)
8274                PHKK(J,IMO21) = PP2(J)
8275                PHKK(J,IMO12) = PT1(J)
8276                PHKK(J,IMO22) = PT2(J)
8277     5       CONTINUE
8278 * correct entries of chains
8279             DO 3 K=1,4
8280                PHKK(K,I)    = PHKK(K,IMO11)+PHKK(K,IMO12)
8281                PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22)
8282     3       CONTINUE
8283             AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2
8284             AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2-
8285      &            PHKK(3,IMMX)**2
8286 * ?? the following should now be obsolete
8287 **sr test
8288 C           IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN
8289             IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8290 **
8291                WRITE(LOUT,'(1X,A,4G10.3)')
8292      &          'EVTRES: inonsistent mass-corr.',AM1,AM2
8293 C              GOTO 9999
8294                GOTO 1
8295             ENDIF
8296             PHKK(5,I)    = SQRT(AM1)
8297             PHKK(5,IMMX) = SQRT(AM2)
8298             IDRES(I)     = IDRES(I)/100
8299             IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR.
8300      &          (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN
8301                WRITE(LOUT,'(1X,A,4G10.3)')
8302      &          'EVTRES: inconsistent chain-masses',
8303      &          PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2
8304                GOTO 9999
8305             ENDIF
8306          ENDIF
8307     1 CONTINUE
8308     6 CONTINUE
8309       RETURN
8310
8311  9999 CONTINUE
8312       IREJ = 1
8313       RETURN
8314       END
8315
8316 *$ CREATE DT_GETSPT.FOR
8317 *COPY DT_GETSPT
8318 *
8319 *===getspt=============================================================*
8320 *
8321       SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2,
8322      &                  PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2,
8323      &                  AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ)
8324
8325 ************************************************************************
8326 * This version dated 12.12.94 is written by S. Roesler                 *
8327 ************************************************************************
8328
8329       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8330       SAVE
8331       PARAMETER ( LINP = 10 ,
8332      &            LOUT = 6 ,
8333      &            LDAT = 9 )
8334       PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)
8335
8336 * various options for treatment of partons (DTUNUC 1.x)
8337 * (chain recombination, Cronin,..)
8338       LOGICAL LCO2CR,LINTPT
8339       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8340      &                LCO2CR,LINTPT
8341 * flags for input different options
8342       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8343       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8344      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8345 * flags for diffractive interactions (DTUNUC 1.x)
8346       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
8347
8348       DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4),
8349      &          PT2(4),PT2I(4),P1(4),P2(4),
8350      &          IFP1(2),IFP2(2),IFT1(2),IFT2(2),
8351      &          PTOTI(4),PTOTF(4),DIFF(4)
8352
8353       IC   = 0
8354       IREJ = 0
8355 C     B33P = 4.0D0
8356 C     B33T = 4.0D0
8357 C     IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
8358 C     IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
8359       REDU = 1.0D0
8360 C     B33P = 3.5D0
8361 C     B33T = 3.5D0
8362       B33P = 4.0D0
8363       B33T = 4.0D0
8364       IF (IDIFF.NE.0) THEN
8365          B33P = 16.0D0
8366          B33T = 16.0D0
8367       ENDIF
8368
8369       DO 1 I=1,4
8370          PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I)
8371          PP1(I)   = PP1I(I)
8372          PP2(I)   = PP2I(I)
8373          PT1(I)   = PT1I(I)
8374          PT2(I)   = PT2I(I)
8375     1 CONTINUE
8376 * get initial chain masses
8377       PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8378      &                               +(PP1(3)+PT1(3))**2)
8379       ECH   = PP1(4)+PT1(4)
8380       AM1   = (ECH+PTOCH)*(ECH-PTOCH)
8381       PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8382      &                               +(PP2(3)+PT2(3))**2)
8383       ECH   = PP2(4)+PT2(4)
8384       AM2   = (ECH+PTOCH)*(ECH-PTOCH)
8385       IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8386          IF (IOULEV(1).GT.0)
8387      &   WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1',
8388      &                              AM1,AM2
8389          GOTO 9999
8390       ENDIF
8391       AM1  = SQRT(AM1)
8392       AM2  = SQRT(AM2)
8393       AM1N = ZERO
8394       AM2N = ZERO
8395
8396       MODE = 0
8397 C      IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
8398 C        MODE = 0
8399 C      ELSE
8400 C         MODE = 1
8401 C         IF (AM1.LT.0.6) THEN
8402 C            B33P = 10.0D0
8403 C         ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
8404 CC           B33P = 4.0D0
8405 C         ENDIF
8406 C         IF (AM2.LT.0.6) THEN
8407 C            B33T = 10.0D0
8408 C         ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
8409 CC           B33T = 4.0D0
8410 C         ENDIF
8411 C      ENDIF
8412
8413 * check chain masses for very low mass chains
8414 C     CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8415 C    &            AM1,DUM,-IDCH1,IREJ1)
8416 C     CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8417 C    &            AM2,DUM,-IDCH2,IREJ2)
8418 C     IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
8419 C        B33P = 20.0D0
8420 C        B33T = 20.0D0
8421 C     ENDIF
8422
8423       JMSHL = IMSHL
8424
8425     2 CONTINUE
8426       IC = IC+1
8427       IF (MOD(IC,15).EQ.0) B33P  = 2.0D0*B33P
8428       IF (MOD(IC,15).EQ.0) B33T  = 2.0D0*B33T
8429       IF (MOD(IC,18).EQ.0) REDU  = 0.0D0
8430 C     IF (MOD(IC,19).EQ.0) JMSHL = 0
8431       IF (MOD(IC,20).EQ.0) GOTO 7
8432 C        WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
8433 C        RETURN
8434 C        GOTO 9999
8435 C     ENDIF
8436
8437 * get transverse momentum
8438       IF (LINTPT) THEN
8439          ES   = -2.0D0/(B33P**2)
8440      &          *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8441          HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0)
8442          HPSP = HPSP*REDU
8443          ES   = -2.0D0/(B33T**2)
8444      &          *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8445          HPST = SQRT(ES*ES+2.0D0*ES*0.94D0)
8446          HPST = HPST*REDU
8447       ELSE
8448          HPSP = ZERO
8449          HPST = ZERO
8450       ENDIF
8451       CALL DT_DSFECF(SFE1,CFE1)
8452       CALL DT_DSFECF(SFE2,CFE2)
8453       IF (MODE.EQ.0) THEN
8454          PP1(1) = PP1I(1)+HPSP*CFE1
8455          PP1(2) = PP1I(2)+HPSP*SFE1
8456          PP2(1) = PP2I(1)-HPSP*CFE1
8457          PP2(2) = PP2I(2)-HPSP*SFE1
8458          PT1(1) = PT1I(1)+HPST*CFE2
8459          PT1(2) = PT1I(2)+HPST*SFE2
8460          PT2(1) = PT2I(1)-HPST*CFE2
8461          PT2(2) = PT2I(2)-HPST*SFE2
8462       ELSE
8463          PP1(1) = PP1I(1)+HPSP*CFE1
8464          PP1(2) = PP1I(2)+HPSP*SFE1
8465          PT1(1) = PT1I(1)-HPSP*CFE1
8466          PT1(2) = PT1I(2)-HPSP*SFE1
8467          PP2(1) = PP2I(1)+HPST*CFE2
8468          PP2(2) = PP2I(2)+HPST*SFE2
8469          PT2(1) = PT2I(1)-HPST*CFE2
8470          PT2(2) = PT2I(2)-HPST*SFE2
8471       ENDIF
8472
8473 * put partons on mass shell
8474       XMP1 = 0.0D0
8475       XMT1 = 0.0D0
8476       IF (JMSHL.EQ.1) THEN
8477          XMP1 = PYMASS(IFPR1)
8478          XMT1 = PYMASS(IFTA1)
8479       ENDIF
8480       CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1)
8481       IF (IREJ1.NE.0) GOTO 2
8482       DO 3 I=1,4
8483          PTOTF(I) = P1(I)+P2(I)
8484          PP1(I)   = P1(I)
8485          PT1(I)   = P2(I)
8486     3 CONTINUE
8487       XMP2 = 0.0D0
8488       XMT2 = 0.0D0
8489       IF (JMSHL.EQ.1) THEN
8490          XMP2 = PYMASS(IFPR2)
8491          XMT2 = PYMASS(IFTA2)
8492       ENDIF
8493       CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1)
8494       IF (IREJ1.NE.0) GOTO 2
8495       DO 4 I=1,4
8496          PTOTF(I) = PTOTF(I)+P1(I)+P2(I)
8497          PP2(I)   = P1(I)
8498          PT2(I)   = P2(I)
8499     4 CONTINUE
8500
8501 * check consistency
8502       DO 5 I=1,4
8503          DIFF(I) = PTOTI(I)-PTOTF(I)
8504     5 CONTINUE
8505       IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR.
8506      &    (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN
8507          WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF
8508          GOTO 9999
8509       ENDIF
8510       PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2)
8511       AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) ))
8512       PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2)
8513       AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) ))
8514       PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2)
8515       AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) ))
8516       PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2)
8517       AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) ))
8518       IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR.
8519      &    (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3))
8520      &                                                           THEN
8521          WRITE(LOUT,'(1X,A,2(4G10.3,/))')
8522      &     'GETSPT: inconsistent masses',
8523      &     AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2
8524 * sr 22.11.00: commented. It should only have inconsistent masses for
8525 * ultrahigh energies due to rounding problems
8526 C        GOTO 9999
8527       ENDIF
8528
8529 * get chain masses
8530       PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8531      &                               +(PP1(3)+PT1(3))**2)
8532       ECH   = PP1(4)+PT1(4)
8533       AM1N  = (ECH+PTOCH)*(ECH-PTOCH)
8534       PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8535      &                               +(PP2(3)+PT2(3))**2)
8536       ECH   = PP2(4)+PT2(4)
8537       AM2N  = (ECH+PTOCH)*(ECH-PTOCH)
8538       IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN
8539          IF (IOULEV(1).GT.0)
8540      &   WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2',
8541      &                              AM1N,AM2N
8542          GOTO 2
8543       ENDIF
8544       AM1N = SQRT(AM1N)
8545       AM2N = SQRT(AM2N)
8546
8547 * check chain masses for very low mass chains
8548       CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8549      &            AM1N,DUM,-IDCH1,IREJ1)
8550       IF (IREJ1.NE.0) GOTO 2
8551       CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8552      &            AM2N,DUM,-IDCH2,IREJ2)
8553       IF (IREJ2.NE.0) GOTO 2
8554
8555     7 CONTINUE
8556       IF (AM1N.GT.ZERO) THEN
8557          AM1 = AM1N
8558          AM2 = AM2N
8559       ENDIF
8560       DO 6 I=1,4
8561          PP1I(I)   = PP1(I)
8562          PP2I(I)   = PP2(I)
8563          PT1I(I)   = PT1(I)
8564          PT2I(I)   = PT2(I)
8565     6 CONTINUE
8566
8567       RETURN
8568
8569  9999 CONTINUE
8570       IREJ = 1
8571       RETURN
8572       END
8573
8574 *$ CREATE DT_SAPTRE.FOR
8575 *COPY DT_SAPTRE
8576 *
8577 *===saptre=============================================================*
8578 *
8579       SUBROUTINE DT_SAPTRE(IDX1,IDX2)
8580
8581 ************************************************************************
8582 * p-t sampling for two-resonance systems. ("BAMJET-like" method)       *
8583 *        IDX1,IDX2       indices of resonances ("chains") in DTEVT1    *
8584 * Adopted from the original SAPTRE written by J. Ranft.                *
8585 * This version dated 18.01.95 is written by S. Roesler                 *
8586 ************************************************************************
8587
8588       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8589       SAVE
8590       PARAMETER ( LINP = 10 ,
8591      &            LOUT = 6 ,
8592      &            LDAT = 9 )
8593       PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8594
8595 * event history
8596       PARAMETER (NMXHKK=200000)
8597       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8598      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8599      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8600 * extended event history
8601       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8602      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8603      &                IHIST(2,NMXHKK)
8604 * flags for input different options
8605       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8606       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8607      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8608
8609       DIMENSION PA1(4),PA2(4),P1(4),P2(4)
8610
8611       DATA B3 /4.0D0/
8612
8613       ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1)
8614       ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2)
8615       ESMAX  = MIN(ESMAX1,ESMAX2)
8616       IF (ESMAX.LE.0.05D0) RETURN
8617
8618       HMA    = PHKK(5,IDX1)
8619       DO 1 K=1,4
8620          PA1(K) = PHKK(K,IDX1)
8621          PA2(K) = PHKK(K,IDX2)
8622     1 CONTINUE
8623
8624       IF (LEMCCK) THEN
8625          CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM)
8626          CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM)
8627       ENDIF
8628
8629       EXEB   = 0.0D0
8630       IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX)
8631       BEXP   = HMA*(1.0D0-EXEB)/B3
8632       AXEXP  = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2
8633       WA     = AXEXP/(BEXP+AXEXP)
8634       XAB    = DT_RNDM(WA)
8635    10 CONTINUE
8636 * ES is the transverse kinetic energy
8637       IF (XAB.LT.WA)THEN
8638         X  = DT_RNDM(WA)
8639         Y  = DT_RNDM(WA)
8640         ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7)
8641       ELSE
8642         X  = DT_RNDM(Y)
8643         ES = ABS(-LOG(X+TINY7)/B3)
8644       ENDIF
8645       IF (ES.GT.ESMAX) GOTO 10
8646       ES  = ES+HMA
8647 * transverse momentum
8648       HPS = SQRT((ES-HMA)*(ES+HMA))
8649
8650       CALL DT_DSFECF(SFE,CFE)
8651       HPX = HPS*CFE
8652       HPY = HPS*SFE
8653       PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY
8654       PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY
8655       IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN
8656
8657 C     PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3))
8658 C     PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3))
8659       PA1(1) = PA1(1)+HPX
8660       PA1(2) = PA1(2)+HPY
8661       PA2(1) = PA2(1)-HPX
8662       PA2(2) = PA2(2)-HPY
8663
8664 * put resonances on mass-shell again
8665       XM1 = PHKK(5,IDX1)
8666       XM2 = PHKK(5,IDX2)
8667       CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1)
8668       IF (IREJ1.NE.0) RETURN
8669
8670       IF (LEMCCK) THEN
8671          CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM)
8672          CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM)
8673          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1)
8674          IF (IREJ1.NE.0) RETURN
8675       ENDIF
8676
8677       DO 2 K=1,4
8678          PHKK(K,IDX1) = P1(K)
8679          PHKK(K,IDX2) = P2(K)
8680     2 CONTINUE
8681
8682       RETURN
8683       END
8684
8685 *$ CREATE DT_CRONIN.FOR
8686 *COPY DT_CRONIN
8687 *
8688 *===cronin=============================================================*
8689 *
8690       SUBROUTINE DT_CRONIN(INCL)
8691
8692 ************************************************************************
8693 * Cronin-Effect. Multiple scattering of partons at chain ends.         *
8694 *             INCL = 1     multiple sc. in projectile                  *
8695 *                  = 2     multiple sc. in target                      *
8696 * This version dated 05.01.96 is written by S. Roesler.                *
8697 ************************************************************************
8698
8699       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8700       SAVE
8701       PARAMETER ( LINP = 10 ,
8702      &            LOUT = 6 ,
8703      &            LDAT = 9 )
8704       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8705
8706 * event history
8707       PARAMETER (NMXHKK=200000)
8708       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8709      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8710      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8711 * extended event history
8712       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8713      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8714      &                IHIST(2,NMXHKK)
8715 * rejection counter
8716       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8717      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8718      &                IREXCI(3),IRDIFF(2),IRINC
8719 * Glauber formalism: collision properties
8720       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
8721      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
8722
8723       DIMENSION R(3),PIN(4),POUT(4),DEV(4)
8724
8725       DO 1 K=1,4
8726          DEV(K) = ZERO
8727     1 CONTINUE
8728
8729       DO 2 I=NPOINT(2),NHKK
8730          IF (ISTHKK(I).LT.0) THEN
8731 * get z-position of the chain
8732             R(1) = VHKK(1,I)*1.0D12
8733             IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC
8734             R(2) = VHKK(2,I)*1.0D12
8735             IDXNU = JMOHKK(1,I)
8736             IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) )
8737      &                             IDXNU = JMOHKK(1,I-1)
8738             IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) )
8739      &                             IDXNU = JMOHKK(1,I+1)
8740             R(3) = VHKK(3,IDXNU)*1.0D12
8741 * position of target parton the chain is connected to
8742             DO 3 K=1,4
8743                PIN(K) = PHKK(K,I)
8744     3       CONTINUE
8745 * multiple scattering of parton with DTEVT1-index I
8746             CALL DT_CROMSC(PIN,R,POUT,INCL)
8747 **testprint
8748 C           IF (NEVHKK.EQ.5) THEN
8749 C              AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2
8750 C              AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2
8751 C              AMIN = SIGN(SQRT(ABS(AMIN)),AMIN)
8752 C              AMOU = SIGN(SQRT(ABS(AMOU)),AMOU)
8753 C              WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU
8754 C              WRITE(6,'(A,4E15.5)')'PIN:       ',PIN
8755 C              WRITE(6,'(A,4E15.5)')'POUT:      ',POUT
8756 C           ENDIF
8757 **
8758 * increase accumulator by energy-momentum difference
8759             DO 4 K=1,4
8760                DEV(K)    = DEV(K)+POUT(K)-PIN(K)
8761                PHKK(K,I) = POUT(K)
8762     4       CONTINUE
8763             PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8764      &                           PHKK(2,I)**2-PHKK(3,I)**2))
8765          ENDIF
8766     2 CONTINUE
8767
8768 * dump accumulator to momenta of valence partons
8769       NVAL = 0
8770       ETOT = 0.0D0
8771       DO 5 I=NPOINT(2),NHKK
8772          IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8773             NVAL = NVAL+1
8774             ETOT = ETOT+PHKK(4,I)
8775          ENDIF
8776     5 CONTINUE
8777 C     WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4)
8778  1000 FORMAT(1X,'CRONIN :  number of val. partons ',I4,/,
8779      &       9X,4E12.4)
8780       DO 6 I=NPOINT(2),NHKK
8781          IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8782             E = PHKK(4,I)
8783             DO 7 K=1,4
8784 C              PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL)
8785                PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT
8786     7       CONTINUE
8787             PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8788      &                           PHKK(2,I)**2-PHKK(3,I)**2))
8789          ENDIF
8790     6 CONTINUE
8791
8792       RETURN
8793       END
8794
8795 *$ CREATE DT_CROMSC.FOR
8796 *COPY DT_CROMSC
8797 *
8798 *===cromsc=============================================================*
8799 *
8800       SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL)
8801
8802 ************************************************************************
8803 * Cronin-Effect. Multiple scattering of one parton passing through     *
8804 * nuclear matter.                                                      *
8805 *            PIN(4)       input 4-momentum of parton                   *
8806 *            POUT(4)      4-momentum of parton after mult. scatt.      *
8807 *            R(3)         spatial position of parton in target nucleus *
8808 *            INCL = 1     multiple sc. in projectile                   *
8809 *                 = 2     multiple sc. in target                       *
8810 * This is a revised version of the original version written by J. Ranft*
8811 * This version dated 17.01.95 is written by S. Roesler.                *
8812 ************************************************************************
8813
8814       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8815       SAVE
8816       PARAMETER ( LINP = 10 ,
8817      &            LOUT = 6 ,
8818      &            LDAT = 9 )
8819       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8820
8821       LOGICAL LSTART
8822
8823 * rejection counter
8824       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8825      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8826      &                IREXCI(3),IRDIFF(2),IRINC
8827 * Glauber formalism: collision properties
8828       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
8829      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
8830 * various options for treatment of partons (DTUNUC 1.x)
8831 * (chain recombination, Cronin,..)
8832       LOGICAL LCO2CR,LINTPT
8833       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8834      &                LCO2CR,LINTPT
8835
8836       DIMENSION PIN(4),POUT(4),R(3)
8837
8838       DATA LSTART /.TRUE./
8839
8840       IRCRON(1) = IRCRON(1)+1
8841
8842       IF (LSTART) THEN
8843          WRITE(LOUT,1000) CRONCO
8844  1000    FORMAT(/,1X,'CROMSC:  multiple scattering of chain ends',
8845      &          ' treated',/,10X,'with parameter CRONCO = ',F5.2)
8846          LSTART = .FALSE.
8847       ENDIF
8848
8849       NCBACK = 0
8850       RNCL   = RPROJ
8851       IF (INCL.EQ.2) RNCL = RTARG
8852
8853 * Lorentz-transformation into Lab.
8854       MODE = -(INCL+1)
8855       CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE)
8856
8857       PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2)
8858       IF (PTOT.LE.8.0D0) GOTO 9997
8859
8860 * direction cosines of parton before mult. scattering
8861       COSX = PIN(1)/PTOT
8862       COSY = PIN(2)/PTOT
8863       COSZ = PZ/PTOT
8864
8865       RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2
8866       IF (RTESQ.GE.-TINY3) GOTO 9999
8867
8868 * calculate distance (DIST) from R to surface of nucleus (radius RNCL)
8869 * in the direction of particle motion
8870
8871       A    = COSX*R(1)+COSY*R(2)+COSZ*R(3)
8872       TMP  = A**2-RTESQ
8873       IF (TMP.LT.ZERO) GOTO 9998
8874       DIST = -A+SQRT(TMP)
8875
8876 * multiple scattering angle
8877       THETO = CRONCO*SQRT(DIST)/PTOT
8878       IF (THETO.GT.0.1D0) THETO=0.1D0
8879
8880     1 CONTINUE
8881 * Gaussian sampling of spatial angle
8882       CALL DT_RANNOR(R1,R2)
8883       THETA = ABS(R1*THETO)
8884       IF (THETA.GT.0.3D0) GOTO 9997
8885       CALL DT_DSFECF(SFE,CFE)
8886       COSTH = COS(THETA)
8887       SINTH = SIN(THETA)
8888
8889 * new direction cosines
8890       CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE,
8891      &                               COSXN,COSYN,COSZN)
8892
8893       POUT(1) = COSXN*PTOT
8894       POUT(2) = COSYN*PTOT
8895       PZ      = COSZN*PTOT
8896 * Lorentz-transformation into nucl.-nucl. cms
8897       MODE = INCL+1
8898       CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE)
8899
8900 C     IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
8901 C     IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN
8902       IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN
8903          THETO = THETO/2.0D0
8904          NCBACK = NCBACK+1
8905          IF (MOD(NCBACK,200).EQ.0) THEN
8906             WRITE(LOUT,1001) THETO,PIN,POUT
8907  1001       FORMAT(1X,'CROMSC: inconsistent scattering angle ',
8908      &             E12.4,/,1X,'        PIN :',4E12.4,/,
8909      &             1X,'       POUT:',4E12.4)
8910             GOTO 9997
8911          ENDIF
8912          GOTO 1
8913       ENDIF
8914
8915       RETURN
8916
8917  9997 IRCRON(2) = IRCRON(2)+1
8918       GOTO 9999
8919  9998 IRCRON(3) = IRCRON(3)+1
8920
8921  9999 CONTINUE
8922       DO 100 K=1,4
8923          POUT(K) = PIN(K)
8924   100 CONTINUE
8925       RETURN
8926       END
8927
8928 *$ CREATE DT_COM2CR.FOR
8929 *COPY DT_COM2CR
8930 *
8931 *===com2sr=============================================================*
8932 *
8933       SUBROUTINE DT_COM2CR
8934
8935 ************************************************************************
8936 * COMbine q-aq chains to Color Ropes (qq-aqaq).                        *
8937 *        CUTOF      parameter determining minimum number of not        *
8938 *                   combined q-aq chains                               *
8939 * This subroutine replaces KKEVCC etc.                                 *
8940 * This version dated 11.01.95 is written by S. Roesler.                *
8941 ************************************************************************
8942
8943       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8944       SAVE
8945       PARAMETER ( LINP = 10 ,
8946      &            LOUT = 6 ,
8947      &            LDAT = 9 )
8948
8949 * event history
8950       PARAMETER (NMXHKK=200000)
8951       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8952      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8953      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8954 * extended event history
8955       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8956      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8957      &                IHIST(2,NMXHKK)
8958 * statistics
8959       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
8960      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
8961      &                ICEVTG(8,0:30)
8962 * various options for treatment of partons (DTUNUC 1.x)
8963 * (chain recombination, Cronin,..)
8964       LOGICAL LCO2CR,LINTPT
8965       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8966      &                LCO2CR,LINTPT
8967
8968       DIMENSION IDXQA(248),IDXAQ(248)
8969
8970       ICCHAI(1,9) = ICCHAI(1,9)+1
8971       NQA = 0
8972       NAQ = 0
8973 * scan DTEVT1 for q-aq, aq-q chains
8974       DO 10 I=NPOINT(3),NHKK
8975 * skip "chains" which are resonances
8976          IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN
8977             MO1 = JMOHKK(1,I)
8978             MO2 = JMOHKK(2,I)
8979             IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN
8980 * q-aq, aq-q chain found, keep index
8981                IF (IDHKK(MO1).GT.0) THEN
8982                   NQA = NQA+1
8983                   IDXQA(NQA) = I
8984                ELSE
8985                   NAQ = NAQ+1
8986                   IDXAQ(NAQ) = I
8987                ENDIF
8988             ENDIF
8989          ENDIF
8990    10 CONTINUE
8991
8992 * minimum number of q-aq chains requested for the same projectile/
8993 * target
8994       NCHMIN = IDT_NPOISS(CUTOF)
8995
8996 * combine q-aq chains of the same projectile
8997       CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1)
8998 * combine q-aq chains of the same target
8999       CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2)
9000 * combine aq-q chains of the same projectile
9001       CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1)
9002 * combine aq-q chains of the same target
9003       CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2)
9004
9005       RETURN
9006       END
9007
9008 *$ CREATE DT_SCN4CR.FOR
9009 *COPY DT_SCN4CR
9010 *
9011 *===scn4cr=============================================================*
9012 *
9013       SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE)
9014
9015 ************************************************************************
9016 * SCan q-aq chains for Color Ropes.                                    *
9017 * This version dated 11.01.95 is written by S. Roesler.                *
9018 ************************************************************************
9019
9020       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9021       SAVE
9022       PARAMETER ( LINP = 10 ,
9023      &            LOUT = 6 ,
9024      &            LDAT = 9 )
9025
9026 * event history
9027       PARAMETER (NMXHKK=200000)
9028       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9029      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9030      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9031 * extended event history
9032       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9033      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9034      &                IHIST(2,NMXHKK)
9035
9036       DIMENSION IDXCH(248),IDXJN(248)
9037
9038       DO 1 I=1,NCH
9039          IF (IDXCH(I).GT.0) THEN
9040             NJOIN = 1
9041             IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I))))
9042             IDXJN(NJOIN) = I
9043             IF (I.LT.NCH) THEN
9044                DO 2 J=I+1,NCH
9045                   IF (IDXCH(J).GT.0) THEN
9046                      IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J))))
9047                      IF (IDXMO.EQ.IDXMO1) THEN
9048                         NJOIN = NJOIN+1
9049                         IDXJN(NJOIN) = J
9050                      ENDIF
9051                   ENDIF
9052     2          CONTINUE
9053             ENDIF
9054             IF (NJOIN.GE.NCHMIN+2) THEN
9055                NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0)
9056                DO 3 J=1,2*NJ,2
9057                   CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1)
9058                   IF (IREJ1.NE.0) GOTO 3
9059                   IDXCH(IDXJN(J))   = 0
9060                   IDXCH(IDXJN(J+1)) = 0
9061     3          CONTINUE
9062             ENDIF
9063          ENDIF
9064     1 CONTINUE
9065
9066       RETURN
9067       END
9068
9069 *$ CREATE DT_JOIN.FOR
9070 *COPY DT_JOIN
9071 *
9072 *===join===============================================================*
9073 *
9074       SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ)
9075
9076 ************************************************************************
9077 * This subroutine joins two q-aq chains to one qq-aqaq chain.          *
9078 *     IDX1, IDX2       DTEVT1 indices of chains to be joined           *
9079 * This version dated 11.01.95 is written by S. Roesler.                *
9080 ************************************************************************
9081
9082       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9083       SAVE
9084       PARAMETER ( LINP = 10 ,
9085      &            LOUT = 6 ,
9086      &            LDAT = 9 )
9087
9088 * event history
9089       PARAMETER (NMXHKK=200000)
9090       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9091      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9092      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9093 * extended event history
9094       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9095      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9096      &                IHIST(2,NMXHKK)
9097 * flags for input different options
9098       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9099       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9100      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9101 * statistics
9102       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9103      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9104      &                ICEVTG(8,0:30)
9105
9106       DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4)
9107
9108       IREJ   = 0
9109
9110       IDX(1) = IDX1
9111       IDX(2) = IDX2
9112       DO 1 I=1,2
9113          DO 2 J=1,2
9114             MO(I,J) = JMOHKK(J,IDX(I))
9115             ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2)
9116     2    CONTINUE
9117     1 CONTINUE
9118
9119 * check consistency
9120       IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR.
9121      &    (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR.
9122      &    ((ID(1,1)*ID(2,1)).LT.0).OR.
9123      &    ((ID(1,2)*ID(2,2)).LT.0)) THEN
9124          WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1),
9125      &                    MO(2,2)
9126  1000    FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':',
9127      &             2I5,' chain ',I4,':',2I5)
9128       ENDIF
9129
9130 * join chains
9131       DO 3 K=1,4
9132          PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))
9133          PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))
9134     3 CONTINUE
9135       IF1  = IDT_IB2PDG(ID(1,1),ID(2,1),2)
9136       IF2  = IDT_IB2PDG(ID(1,2),ID(2,2),2)
9137       IST1 = ISTHKK(MO(1,1))
9138       IST2 = ISTHKK(MO(1,2))
9139
9140 * put partons again on mass shell
9141       XM1 = 0.0D0
9142       XM2 = 0.0D0
9143       IF (IMSHL.EQ.1) THEN
9144          XM1 = PYMASS(IF1)
9145          XM2 = PYMASS(IF2)
9146       ENDIF
9147       CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1)
9148       IF (IREJ1.NE.0) GOTO 9999
9149       DO 4 I=1,4
9150          PP(I) = P1(I)
9151          PT(I) = P2(I)
9152     4 CONTINUE
9153
9154 * store new partons in DTEVT1
9155       CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4),
9156      &                                                       0,0,0)
9157       CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4),
9158      &                                                       0,0,0)
9159       DO 5 K=1,4
9160          PCH(K) = PP(K)+PT(K)
9161     5 CONTINUE
9162
9163 * check new chain for lower mass limit
9164       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
9165          AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2))
9166          CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM,
9167      &               AMCH,AMCHN,3,IREJ1)
9168          IF (IREJ1.NE.0) THEN
9169             NHKK = NHKK-2
9170             GOTO 9999
9171          ENDIF
9172       ENDIF
9173
9174       ICCHAI(2,9) = ICCHAI(2,9)+1
9175 * store new chain in DTEVT1
9176       KCH = 191
9177       CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9)
9178       IDHKK(IDX(1)) = 22222
9179       IDHKK(IDX(2)) = 22222
9180 * special treatment for space-time coordinates
9181       DO 6 K=1,4
9182          VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0
9183          WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0
9184     6 CONTINUE
9185       RETURN
9186
9187  9999 CONTINUE
9188       IREJ = 1
9189       RETURN
9190       END
9191
9192 *$ CREATE DT_XSGLAU.FOR
9193 *COPY DT_XSGLAU
9194 *
9195 *===xsglau=============================================================*
9196 *
9197       SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX)
9198
9199 ************************************************************************
9200 * Total, elastic, quasi-elastic, inelastic cross sections according to *
9201 * Glauber's approach.                                                  *
9202 *  NA / NB     mass numbers of proj./target nuclei                     *
9203 *  JJPROJ      bamjet-index of projectile (=1 in case of proj.nucleus) *
9204 *  XI,Q2I,ECMI kinematical variables x, Q^2, E_cm                      *
9205 *  IE,IQ       indices of energy and virtuality (the latter for gamma  *
9206 *              projectiles only)                                       *
9207 *  NIDX        index of projectile/target nucleus                      *
9208 * This version dated 17.3.98  is written by S. Roesler                 *
9209 ************************************************************************
9210
9211       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9212       SAVE
9213       PARAMETER ( LINP = 10 ,
9214      &            LOUT = 6 ,
9215      &            LDAT = 9 )
9216
9217       COMPLEX*16 CZERO,CONE,CTWO
9218       CHARACTER*12 CFILE
9219       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9220      &           ONETHI=ONE/THREE,TINY25=1.0D-25)
9221       PARAMETER (TWOPI  = 6.283185307179586454D+00,
9222      &           PI     = TWOPI/TWO,
9223      &           GEV2MB = 0.38938D0,
9224      &           GEV2FM = 0.1972D0,
9225      &           ALPHEM = ONE/137.0D0,
9226 * proton mass
9227      &           AMP    = 0.938D0,
9228      &           AMP2   = AMP**2,
9229 * approx. nucleon radius
9230      &           RNUCLE = 1.12D0)
9231
9232 * particle properties (BAMJET index convention)
9233       CHARACTER*8  ANAME
9234       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
9235      &                IICH(210),IIBAR(210),K1(210),K2(210)
9236       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9237       PARAMETER ( MAXNCL = 260,
9238      &            MAXVQU = MAXNCL,
9239      &            MAXSQU = 20*MAXVQU,
9240      &            MAXINT = MAXVQU+MAXSQU)
9241 * Glauber formalism: parameters
9242       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9243      &                BMAX(NCOMPX),BSTEP(NCOMPX),
9244      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9245      &                NSITEB,NSTATB
9246 * Glauber formalism: cross sections
9247       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
9248      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
9249      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
9250      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
9251      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
9252      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
9253      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
9254      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
9255      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
9256      &                BSLOPE,NEBINI,NQBINI
9257 * Glauber formalism: flags and parameters for statistics
9258       LOGICAL LPROD
9259       CHARACTER*8 CGLB
9260       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
9261 * nucleon-nucleon event-generator
9262       CHARACTER*8 CMODEL
9263       LOGICAL LPHOIN
9264       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
9265 * VDM parameter for photon-nucleus interactions
9266       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
9267 * parameters for hA-diffraction
9268       COMMON /DTDIHA/ DIBETA,DIALPH
9269
9270       COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL),
9271      &           OMPP11,OMPP12,OMPP21,OMPP22,
9272      &           DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP,
9273      &           PPTMP1,PPTMP2
9274       COMPLEX*16 C,CA,CI
9275       DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL),
9276      &          COOP2(3,MAXNCL),COOT2(3,MAXNCL),
9277      &          BPROD(KSITEB)
9278
9279       PARAMETER (NPOINT=16)
9280       DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
9281
9282       LOGICAL LFIRST,LOPEN
9283       DATA LFIRST,LOPEN /.TRUE.,.FALSE./
9284
9285       NTARG = ABS(NIDX)
9286 * for quasi-elastic neutrino scattering set projectile to proton
9287 * it should not have an effect since the whole Glauber-formalism is
9288 * not needed for these interactions..
9289       IF (MCGENE.EQ.4) THEN
9290          IJPROJ = 1
9291       ELSE
9292          IJPROJ = JJPROJ
9293       ENDIF
9294
9295       IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN
9296          I = INDEX(CGLB,' ')
9297          IF (I.EQ.0) THEN
9298             CFILE = CGLB//'.glb'
9299             OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN')
9300          ELSEIF (I.GT.1) THEN
9301             CFILE = CGLB(1:I-1)//'.glb'
9302             OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN')
9303          ELSE
9304             STOP 'XSGLAU 1'
9305          ENDIF
9306          LOPEN = .TRUE.
9307       ENDIF
9308
9309       CZERO  = DCMPLX(ZERO,ZERO)
9310       CONE   = DCMPLX(ONE,ZERO)
9311       CTWO   = DCMPLX(TWO,ZERO)
9312       NEBINI = IE
9313       NQBINI = IQ
9314
9315 * re-define kinematics
9316       S  = ECMI**2
9317       Q2 = Q2I
9318       X  = XI
9319 *  g(Q2=0)-A, h-A, A-A scattering
9320       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9321          Q2 = 0.0001D0
9322          X  = Q2/(S+Q2-AMP2)
9323 *  g(Q2>0)-A scattering
9324       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN
9325          X  = Q2/(S+Q2-AMP2)
9326       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9327          Q2 = (S-AMP2)*X/(ONE-X)
9328       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
9329          S  = Q2*(ONE-X)/X+AMP2
9330       ELSE
9331          WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X
9332          STOP
9333       ENDIF
9334       ECMNN(IE) = SQRT(S)
9335       Q2G(IQ)   = Q2
9336       XNU = (S+Q2-AMP2)/(TWO*AMP)
9337
9338 * parameters determining statistics in evaluating Glauber-xsection
9339       NSTATB = JSTATB
9340       NSITEB = JBINSB
9341       IF (NSITEB.GT.KSITEB) NSITEB = KSITEB
9342
9343 * set up interaction geometry (common /DTGLAM/)
9344 *  projectile/target radii
9345       RPRNCL = DT_RNCLUS(NA)
9346       RTANCL = DT_RNCLUS(NB)
9347       IF (IJPROJ.EQ.7) THEN
9348          RASH(1) = ZERO
9349          RBSH(NTARG) = RTANCL
9350          BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9351       ELSE
9352          IF (NIDX.LE.-1) THEN
9353             RASH(1)     = RPRNCL
9354             RBSH(NTARG) = RTANCL
9355             BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9356          ELSE
9357             RASH(NTARG) = RPRNCL
9358             RBSH(1)     = RTANCL
9359             BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1))
9360          ENDIF
9361       ENDIF
9362 *  maximum impact-parameter
9363       BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1)
9364
9365 * slope, rho ( Re(f(0))/Im(f(0)) )
9366       IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
9367          IF (MCGENE.EQ.2) THEN
9368             ZERO1 = ZERO
9369             CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3,
9370      &                                                   BSLOPE,0)
9371          ELSE
9372             BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
9373          ENDIF
9374          IF (ECMNN(IE).LE.3.0D0) THEN
9375             ROSH = -0.43D0
9376          ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN
9377             ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE))
9378          ELSEIF (ECMNN(IE).GT.50.0D0) THEN
9379             ROSH = 0.1D0
9380          ENDIF
9381       ELSEIF (IJPROJ.EQ.7) THEN
9382          ROSH = 0.1D0
9383       ELSE
9384          BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
9385          ROSH   = 0.01D0
9386       ENDIF
9387
9388 * projectile-nucleon xsection (in fm)
9389       IF (IJPROJ.EQ.7) THEN
9390          SIGSH = DT_SIGVP(X,Q2)/10.0D0
9391       ELSE
9392          ELAB  = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
9393          PLAB  = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
9394 C        SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
9395          DUMZER = ZERO
9396          CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
9397          SIGSH = SIGSH/10.0D0
9398       ENDIF
9399
9400 * parameters for projectile diffraction (hA scattering only)
9401       IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7)
9402      &                               .AND.(DIBETA.GE.ZERO)) THEN
9403          ZERO1 = ZERO
9404          CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0)
9405 C        DIBETA = SDIF1/STOT
9406          DIBETA = 0.2D0
9407          DIGAMM = SQRT(DIALPH**2+DIBETA**2)
9408          IF (DIBETA.LE.ZERO) THEN
9409             ALPGAM = ONE
9410          ELSE
9411             ALPGAM = DIALPH/DIGAMM
9412          ENDIF
9413          FACDI1 = ONE-ALPGAM
9414          FACDI2 = ONE+ALPGAM
9415          FACDI  = SQRT(FACDI1*FACDI2)
9416          WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM
9417       ELSE
9418          DIBETA = -1.0D0
9419          DIALPH = ZERO
9420          DIGAMM = ZERO
9421          FACDI1 = ZERO
9422          FACDI2 = 2.0D0
9423          FACDI  = ZERO
9424       ENDIF
9425
9426 * initializations
9427       DO 10 I=1,NSITEB
9428          BSITE( 0,IQ,NTARG,I) = ZERO
9429          BSITE(IE,IQ,NTARG,I) = ZERO
9430          BPROD(I) = ZERO
9431    10 CONTINUE
9432       STOT  = ZERO
9433       STOT2 = ZERO
9434       SELA  = ZERO
9435       SELA2 = ZERO
9436       SQEP  = ZERO
9437       SQEP2 = ZERO
9438       SQET  = ZERO
9439       SQET2 = ZERO
9440       SQE2  = ZERO
9441       SQE22 = ZERO
9442       SPRO  = ZERO
9443       SPRO2 = ZERO
9444       SDEL  = ZERO
9445       SDEL2 = ZERO
9446       SDQE  = ZERO
9447       SDQE2 = ZERO
9448       FACN   = ONE/DBLE(NSTATB)
9449
9450       IPNT = 0
9451       RPNT = ZERO
9452
9453 *  initialize Gauss-integration for photon-proj.
9454       JPOINT = 1
9455       IF (IJPROJ.EQ.7) THEN
9456          IF (INTRGE(1).EQ.1) THEN
9457             AMLO2 = (3.0D0*AAM(13))**2
9458          ELSEIF (INTRGE(1).EQ.2) THEN
9459             AMLO2 = AAM(33)**2
9460          ELSE
9461             AMLO2 = AAM(96)**2
9462          ENDIF
9463          IF (INTRGE(2).EQ.1) THEN
9464             AMHI2 = S/TWO
9465          ELSEIF (INTRGE(2).EQ.2) THEN
9466             AMHI2 = S/4.0D0
9467          ELSE
9468             AMHI2 = S
9469          ENDIF
9470          AMHI20 = (ECMNN(IE)-AMP)**2
9471          IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
9472          XAMLO = LOG( AMLO2+Q2 )
9473          XAMHI = LOG( AMHI2+Q2 )
9474 **PHOJET105a
9475 C        CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9476 **PHOJET112
9477          CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9478 **
9479          JPOINT = NPOINT
9480 * ratio direct/total photon-nucleon xsection
9481          CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1)
9482       ENDIF
9483
9484 * read pre-initialized profile-function from file
9485       IF (IOGLB.EQ.1) THEN
9486          READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM
9487          IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN
9488             WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB,
9489      &                             NA,NB,NSTATB,NSITEB
9490  1000       FORMAT(' XSGLAU: inconsistent input data in file ',A12,/,
9491      &             ' (IA,IB,ISTATB,ISITEB) ',4I10,/,
9492      &             ' (NA,NB,NSTATB,NSITEB) ',4I10)
9493             STOP
9494          ENDIF
9495          IF (LFIRST) WRITE(LOUT,1001) CFILE
9496  1001    FORMAT(/,' XSGLAU: impact parameter distribution read from ',
9497      &          'file ',A12,/)
9498          READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),
9499      &                         XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG),
9500      &                         XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9501          READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),
9502      &                         XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG),
9503      &                         XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9504          NLINES = INT(DBLE(NSITEB)/7.0D0)
9505          IF (NLINES.GT.0) THEN
9506             DO 21 I=1,NLINES
9507                ISTART = 7*I-6
9508                READ(LDAT,'(7E11.4)')
9509      &            (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9510    21       CONTINUE
9511          ENDIF
9512          ISTART = 7*NLINES+1
9513          IF (ISTART.LE.NSITEB) THEN
9514             READ(LDAT,'(7E11.4)')
9515      &         (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9516          ENDIF
9517          LFIRST = .FALSE.
9518          GOTO 100
9519 * variable projectile/target/energy runs:
9520 * read pre-initialized profile-functions from file
9521       ELSEIF (IOGLB.EQ.100) THEN
9522          CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0)
9523          GOTO 100
9524       ENDIF
9525
9526 * cross sections averaged over NSTATB nucleon configurations
9527       DO 11 IS=1,NSTATB
9528 C        IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS
9529          STOTN = ZERO
9530          SELAN = ZERO
9531          SQEPN = ZERO
9532          SQETN = ZERO
9533          SQE2N = ZERO
9534          SPRON = ZERO
9535          SDELN = ZERO
9536          SDQEN = ZERO
9537
9538          IF (NIDX.LE.-1) THEN
9539             CALL DT_CONUCL(COOP1,NA,RASH(1),0)
9540             CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1)
9541             IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9542                CALL DT_CONUCL(COOP2,NA,RASH(1),0)
9543                CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1)
9544             ENDIF
9545          ELSE
9546             CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0)
9547             CALL DT_CONUCL(COOT1,NB,RBSH(1),1)
9548             IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9549                CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0)
9550                CALL DT_CONUCL(COOT2,NB,RBSH(1),1)
9551             ENDIF
9552          ENDIF
9553
9554 *  integration over impact parameter B
9555          DO 12 IB=1,NSITEB-1
9556             STOTB = ZERO
9557             SELAB = ZERO
9558             SQEPB = ZERO
9559             SQETB = ZERO
9560             SQE2B = ZERO
9561             SPROB = ZERO
9562             SDIR  = ZERO
9563             SDELB = ZERO
9564             SDQEB = ZERO
9565             B     = DBLE(IB)*BSTEP(NTARG)
9566             FACB  = 10.0D0*TWOPI*B*BSTEP(NTARG)
9567
9568 *   integration over M_V^2 for photon-proj.
9569             DO 14 IM=1,JPOINT
9570                PP11(1) = CONE
9571                PP12(1) = CONE
9572                PP21(1) = CONE
9573                PP22(1) = CONE
9574                IF (IJPROJ.EQ.7) THEN
9575                   DO 13 K=2,NB
9576                      PP11(K) = CONE
9577                      PP12(K) = CONE
9578                      PP21(K) = CONE
9579                      PP22(K) = CONE
9580    13             CONTINUE
9581                ENDIF
9582                SHI  = ZERO
9583                FACM = ONE
9584                DCOH = 1.0D10
9585
9586                IF (IJPROJ.EQ.7) THEN
9587                   AMV2 = EXP(ABSZX(IM))-Q2
9588                   AMV  = SQRT(AMV2)
9589                   IF (AMV2.LT.16.0D0) THEN
9590                      R = TWO
9591                   ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN
9592                      R = 10.0D0/3.0D0
9593                   ELSE
9594                      R = 11.0D0/3.0D0
9595                   ENDIF
9596 *    define M_V dependent properties of nucleon scattering amplitude
9597 *     V_M-nucleon xsection
9598                   SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0
9599                   SIGMV  = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2)
9600 *     slope-parametrisation a la Kaidalov
9601                   BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
9602      &                           +0.25D0*LOG(S/(AMV2+Q2)))
9603 *    coherence length
9604                   IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM
9605 *    integration weight factor
9606                   FACM = ALPHEM/(3.0D0*PI*(ONE-X))*
9607      &                  R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM)
9608                ENDIF
9609                GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
9610                GAM = GSH
9611                IF (IJPROJ.EQ.7) THEN
9612                   RCA = GAM*SIGMV/TWOPI
9613                ELSE
9614                   RCA = GAM*SIGSH/TWOPI
9615                ENDIF
9616                FCA = -ROSH*RCA
9617                CA  = DCMPLX(RCA,FCA)
9618                CI  = CONE
9619
9620                DO 15 INA=1,NA
9621                   KK1  = 1
9622                   INT1 = 1
9623                   KK2  = 1
9624                   INT2 = 1
9625                   DO 16 INB=1,NB
9626 *    photon-projectile: check for supression by coherence length
9627                      IF (IJPROJ.EQ.7) THEN
9628                         IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN
9629                            KK1  = INB
9630                            INT1 = INT1+1
9631                         ENDIF
9632                         IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN
9633                            KK2  = INB
9634                            INT2 = INT2+1
9635                         ENDIF
9636                      ENDIF
9637
9638                      X11 = B+COOT1(1,INB)-COOP1(1,INA)
9639                      Y11 =   COOT1(2,INB)-COOP1(2,INA)
9640                      XY11 = GAM*(X11*X11+Y11*Y11)
9641                      IF (XY11.LE.15.0D0) THEN
9642                         C = CONE-CA*EXP(-XY11)
9643                         AR = DBLE(PP11(INT1))
9644                         AI = DIMAG(PP11(INT1))
9645                         IF (ABS(AR).LT.TINY25) AR = ZERO
9646                         IF (ABS(AI).LT.TINY25) AI = ZERO
9647                         PP11(INT1) = DCMPLX(AR,AI)
9648                         PP11(INT1) = PP11(INT1)*C
9649                         AR  = DBLE(C)
9650                         AI  = DIMAG(C)
9651                         SHI = SHI+LOG(AR*AR+AI*AI)
9652                      ENDIF
9653                      IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9654                         X12 = B+COOT2(1,INB)-COOP1(1,INA)
9655                         Y12 =   COOT2(2,INB)-COOP1(2,INA)
9656                         XY12 = GAM*(X12*X12+Y12*Y12)
9657                         IF (XY12.LE.15.0D0) THEN
9658                            C = CONE-CA*EXP(-XY12)
9659                            AR = DBLE(PP12(INT2))
9660                            AI = DIMAG(PP12(INT2))
9661                            IF (ABS(AR).LT.TINY25) AR = ZERO
9662                            IF (ABS(AI).LT.TINY25) AI = ZERO
9663                            PP12(INT2) = DCMPLX(AR,AI)
9664                            PP12(INT2) = PP12(INT2)*C
9665                         ENDIF
9666                         X21 = B+COOT1(1,INB)-COOP2(1,INA)
9667                         Y21 =   COOT1(2,INB)-COOP2(2,INA)
9668                         XY21 = GAM*(X21*X21+Y21*Y21)
9669                         IF (XY21.LE.15.0D0) THEN
9670                            C = CONE-CA*EXP(-XY21)
9671                            AR = DBLE(PP21(INT1))
9672                            AI = DIMAG(PP21(INT1))
9673                            IF (ABS(AR).LT.TINY25) AR = ZERO
9674                            IF (ABS(AI).LT.TINY25) AI = ZERO
9675                            PP21(INT1) = DCMPLX(AR,AI)
9676                            PP21(INT1) = PP21(INT1)*C
9677                         ENDIF
9678                         X22 = B+COOT2(1,INB)-COOP2(1,INA)
9679                         Y22 =   COOT2(2,INB)-COOP2(2,INA)
9680                         XY22 = GAM*(X22*X22+Y22*Y22)
9681                         IF (XY22.LE.15.0D0) THEN
9682                            C = CONE-CA*EXP(-XY22)
9683                            AR = DBLE(PP22(INT2))
9684                            AI = DIMAG(PP22(INT2))
9685                            IF (ABS(AR).LT.TINY25) AR = ZERO
9686                            IF (ABS(AI).LT.TINY25) AI = ZERO
9687                            PP22(INT2) = DCMPLX(AR,AI)
9688                            PP22(INT2) = PP22(INT2)*C
9689                         ENDIF
9690                      ENDIF
9691    16             CONTINUE
9692    15          CONTINUE
9693
9694                OMPP11 = CZERO
9695                OMPP21 = CZERO
9696                DIPP11 = CZERO
9697                DIPP21 = CZERO
9698                DO 17 K=1,INT1
9699                   IF (PP11(K).EQ.CZERO) THEN
9700                      PPTMP1 = CZERO
9701                      PPTMP2 = CZERO
9702                   ELSE
9703                      PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM)
9704                      PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM)
9705                   ENDIF
9706                   AVDIPP = 0.5D0*
9707      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9708                   OMPP11 = OMPP11+AVDIPP
9709 C                 OMPP11 = OMPP11+(CONE-PP11(K))
9710                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9711                   DIPP11 = DIPP11+AVDIPP
9712                   IF (PP21(K).EQ.CZERO) THEN
9713                      PPTMP1 = CZERO
9714                      PPTMP2 = CZERO
9715                   ELSE
9716                      PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM)
9717                      PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM)
9718                   ENDIF
9719                   AVDIPP = 0.5D0*
9720      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9721                   OMPP21 = OMPP21+AVDIPP
9722 C                 OMPP21 = OMPP21+(CONE-PP21(K))
9723                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9724                   DIPP21 = DIPP21+AVDIPP
9725    17          CONTINUE
9726                OMPP12 = CZERO
9727                OMPP22 = CZERO
9728                DIPP12 = CZERO
9729                DIPP22 = CZERO
9730                DO 18 K=1,INT2
9731                   IF (PP12(K).EQ.CZERO) THEN
9732                      PPTMP1 = CZERO
9733                      PPTMP2 = CZERO
9734                   ELSE
9735                      PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM)
9736                      PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM)
9737                   ENDIF
9738                   AVDIPP = 0.5D0*
9739      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9740                   OMPP12 = OMPP12+AVDIPP
9741 C                 OMPP12 = OMPP12+(CONE-PP12(K))
9742                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9743                   DIPP12 = DIPP12+AVDIPP
9744                   IF (PP22(K).EQ.CZERO) THEN
9745                      PPTMP1 = CZERO
9746                      PPTMP2 = CZERO
9747                   ELSE
9748                      PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM)
9749                      PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM)
9750                   ENDIF
9751                   AVDIPP = 0.5D0*
9752      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9753                   OMPP22 = OMPP22+AVDIPP
9754 C                 OMPP22 = OMPP22+(CONE-PP22(K))
9755                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9756                   DIPP22 = DIPP22+AVDIPP
9757    18          CONTINUE
9758
9759                SPROM = ONE-EXP(SHI)
9760                SPROB = SPROB+FACM*SPROM
9761                IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9762                   STOTM = DBLE(OMPP11+OMPP22)
9763                   SELAM = DBLE(OMPP11*DCONJG(OMPP22))
9764                   SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM
9765                   SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM
9766                   SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM
9767                   SDELM = DBLE(DIPP11*DCONJG(DIPP22))
9768                   SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM
9769                   STOTB = STOTB+FACM*STOTM
9770                   SELAB = SELAB+FACM*SELAM
9771                   SDELB = SDELB+FACM*SDELM
9772                   IF (NB.GT.1) THEN
9773                      SQEPB = SQEPB+FACM*SQEPM
9774                      SDQEB = SDQEB+FACM*SDQEM
9775                   ENDIF
9776                   IF (NA.GT.1) SQETB = SQETB+FACM*SQETM
9777                   IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M
9778                   IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD
9779                ENDIF
9780
9781    14       CONTINUE
9782
9783             STOTN = STOTN+FACB*STOTB
9784             SELAN = SELAN+FACB*SELAB
9785             SQEPN = SQEPN+FACB*SQEPB
9786             SQETN = SQETN+FACB*SQETB
9787             SQE2N = SQE2N+FACB*SQE2B
9788             SPRON = SPRON+FACB*SPROB
9789             SDELN = SDELN+FACB*SDELB
9790             SDQEN = SDQEN+FACB*SDQEB
9791
9792             IF (IJPROJ.EQ.7) THEN
9793                BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB)
9794             ELSE
9795                IF (DIBETA.GT.ZERO) THEN
9796                   BPROD(IB+1)= BPROD(IB+1)
9797      &                        +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B)
9798                ELSE
9799                   BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB
9800                ENDIF
9801             ENDIF
9802
9803    12    CONTINUE
9804
9805          STOT  = STOT +FACN*STOTN
9806          STOT2 = STOT2+FACN*STOTN**2
9807          SELA  = SELA +FACN*SELAN
9808          SELA2 = SELA2+FACN*SELAN**2
9809          SQEP  = SQEP +FACN*SQEPN
9810          SQEP2 = SQEP2+FACN*SQEPN**2
9811          SQET  = SQET +FACN*SQETN
9812          SQET2 = SQET2+FACN*SQETN**2
9813          SQE2  = SQE2 +FACN*SQE2N
9814          SQE22 = SQE22+FACN*SQE2N**2
9815          SPRO  = SPRO +FACN*SPRON
9816          SPRO2 = SPRO2+FACN*SPRON**2
9817          SDEL  = SDEL +FACN*SDELN
9818          SDEL2 = SDEL2+FACN*SDELN**2
9819          SDQE  = SDQE +FACN*SDQEN
9820          SDQE2 = SDQE2+FACN*SDQEN**2
9821
9822    11 CONTINUE
9823
9824 * final cross sections
9825 * 1) total
9826       XSTOT(IE,IQ,NTARG) = STOT
9827       IF (IJPROJ.EQ.7)
9828      &   XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR
9829 * 2) elastic
9830       XSELA(IE,IQ,NTARG) = SELA
9831 * 3) quasi-el.: A+B-->A+X (excluding 2)
9832       XSQEP(IE,IQ,NTARG) = SQEP
9833 * 4) quasi-el.: A+B-->X+B (excluding 2)
9834       XSQET(IE,IQ,NTARG) = SQET
9835 * 5) quasi-el.: A+B-->X (excluding 2-4)
9836       XSQE2(IE,IQ,NTARG) = SQE2
9837 * 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
9838       IF (SDEL.GT.ZERO) THEN
9839          XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2
9840       ELSE
9841          XSPRO(IE,IQ,NTARG) = SPRO
9842       ENDIF
9843 * 7) projectile diffraction (el. scatt. off target)
9844       XSDEL(IE,IQ,NTARG) = SDEL
9845 * 8) projectile diffraction (quasi-el. scatt. off target)
9846       XSDQE(IE,IQ,NTARG) = SDQE
9847 *  stat. errors
9848       XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1))
9849       XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1))
9850       XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1))
9851       XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1))
9852       XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1))
9853       XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1))
9854       XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1))
9855       XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1))
9856
9857       IF (IJPROJ.EQ.7) THEN
9858          BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG)
9859      &          -XSQEP(IE,IQ,NTARG)
9860       ELSE
9861          BNORM = XSPRO(IE,IQ,NTARG)
9862       ENDIF
9863       DO 19 I=2,NSITEB
9864          BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1)
9865          IF ((IE.EQ.1).AND.(IQ.EQ.1))
9866      &      BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1)
9867    19 CONTINUE
9868
9869 * write profile function data into file
9870       IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN
9871          WRITE(LDAT,'(5I10,1P,E15.5)')
9872      &      IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE)
9873          WRITE(LDAT,'(1P,6E12.5)')
9874      &      XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG),
9875      &      XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9876          WRITE(LDAT,'(1P,6E12.5)')
9877      &      XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG),
9878      &      XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9879          NLINES = INT(DBLE(NSITEB)/7.0D0)
9880          IF (NLINES.GT.0) THEN
9881             DO 20 I=1,NLINES
9882                ISTART = 7*I-6
9883                WRITE(LDAT,'(1P,7E11.4)')
9884      &            (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9885    20       CONTINUE
9886          ENDIF
9887          ISTART = 7*NLINES+1
9888          IF (ISTART.LE.NSITEB) THEN
9889             WRITE(LDAT,'(1P,7E11.4)')
9890      &         (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9891          ENDIF
9892       ENDIF
9893
9894   100 CONTINUE
9895
9896 C     IF (ABS(IOGLB).EQ.1) CLOSE(LDAT)
9897
9898       RETURN
9899       END
9900
9901 *$ CREATE DT_GETBXS.FOR
9902 *COPY DT_GETBXS
9903 *
9904 *===getbxs=============================================================*
9905 *
9906       SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX)
9907
9908 ************************************************************************
9909 * Biasing in impact parameter space.                                   *
9910 *     XSFRAC = 0 :  BLO    - minimum impact parameter  (input)         *
9911 *                   BHI    - maximum impact parameter  (input)         *
9912 *                   XSFRAC - fraction of cross section corresponding   *
9913 *                            to impact parameter range (BLO,BHI)       *
9914 *                                                      (output)        *
9915 *     XSFRAC > 0 :  XSFRAC - fraction of cross section (input)         *
9916 *                   BHI    - maximum impact parameter giving requested *
9917 *                            fraction of cross section in impact       *
9918 *                            parameter range (0,BMAX)  (output)        *
9919 * This version dated 17.03.00  is written by S. Roesler                *
9920 ************************************************************************
9921
9922       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9923       SAVE
9924       PARAMETER ( LINP = 10 ,
9925      &            LOUT = 6 ,
9926      &            LDAT = 9 )
9927
9928       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9929 * Glauber formalism: parameters
9930       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9931      &                BMAX(NCOMPX),BSTEP(NCOMPX),
9932      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9933      &                NSITEB,NSTATB
9934
9935       NTARG = ABS(NIDX)
9936       IF (XSFRAC.LE.0.0D0) THEN
9937          ILO    = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG)))
9938          IHI    = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG)))
9939          IF (ILO.GE.IHI) THEN
9940             XSFRAC = 0.0D0
9941             RETURN
9942          ENDIF
9943          IF (ILO.EQ.NSITEB-1) THEN
9944             FRCLO = BSITE(0,1,NTARG,NSITEB)
9945          ELSE
9946             FRCLO = BSITE(0,1,NTARG,ILO+1)
9947      &              +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG)
9948      &              *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1))
9949          ENDIF
9950          IF (IHI.EQ.NSITEB-1) THEN
9951             FRCHI = BSITE(0,1,NTARG,NSITEB)
9952          ELSE
9953             FRCHI = BSITE(0,1,NTARG,IHI+1)
9954      &              +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG)
9955      &              *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1))
9956          ENDIF
9957          XSFRAC = FRCHI-FRCLO
9958       ELSE
9959          BLO = 0.0D0
9960          BHI = BMAX(NTARG)
9961          DO 1 I=1,NSITEB-1
9962             IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN
9963                FAC = (XSFRAC              -BSITE(0,1,NTARG,I))/
9964      &               (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I))
9965                BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC
9966                GOTO 2
9967             ENDIF
9968     1    CONTINUE
9969     2    CONTINUE
9970       ENDIF
9971
9972       RETURN
9973       END
9974
9975 *$ CREATE DT_CONUCL.FOR
9976 *COPY DT_CONUCL
9977 *
9978 *===conucl=============================================================*
9979 *
9980       SUBROUTINE DT_CONUCL(X,N,R,MODE)
9981
9982 ************************************************************************
9983 * Calculation of coordinates of nucleons within nuclei.                *
9984 *        X(3,N)   spatial coordinates of nucleons (in fm)  (output)    *
9985 *        N / R    number of nucleons / radius of nucleus   (input)     *
9986 *        MODE = 0 coordinates not sorted                               *
9987 *             = 1 coordinates sorted with increasing X(3,i)            *
9988 *             = 2 coordinates sorted with decreasing X(3,i)            *
9989 * This version dated 26.10.95 is revised by S. Roesler                 *
9990 ************************************************************************
9991
9992       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9993       SAVE
9994       PARAMETER ( LINP = 10 ,
9995      &            LOUT = 6 ,
9996      &            LDAT = 9 )
9997
9998       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9999      &           ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10000
10001       PARAMETER (TWOPI = 6.283185307179586454D+00 )
10002
10003       PARAMETER (NSRT=10)
10004       DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10005       DIMENSION X(3,N),XTMP(3,260)
10006
10007       CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R)
10008
10009       IF ((MODE.NE.0).AND.(N.GT.4)) THEN
10010          K = 0
10011          DO 1 I=1,NSRT
10012             IF (MODE.EQ.2) THEN
10013                ISRT = NSRT+1-I
10014             ELSE
10015                ISRT = I
10016             ENDIF
10017             K1 = K
10018             DO 2 J=1,ICSRT(ISRT)
10019                K = K+1
10020                X(1,K) = XTMP(1,IDXSRT(ISRT,J))
10021                X(2,K) = XTMP(2,IDXSRT(ISRT,J))
10022                X(3,K) = XTMP(3,IDXSRT(ISRT,J))
10023     2       CONTINUE
10024             IF (ICSRT(ISRT).GT.1) THEN
10025                I0 = K1+1
10026                I1 = K
10027                CALL DT_SORT(X,N,I0,I1,MODE)
10028             ENDIF
10029     1    CONTINUE
10030       ELSEIF ((MODE.NE.0).AND.(N.GE.2).AND.(N.LE.4)) THEN
10031          DO 3 I=1,N
10032             X(1,I) = XTMP(1,I)
10033             X(2,I) = XTMP(2,I)
10034             X(3,I) = XTMP(3,I)
10035     3    CONTINUE
10036          CALL DT_SORT(X,N,1,N,MODE)
10037       ELSE
10038          DO 4 I=1,N
10039             X(1,I) = XTMP(1,I)
10040             X(2,I) = XTMP(2,I)
10041             X(3,I) = XTMP(3,I)
10042     4    CONTINUE
10043       ENDIF
10044
10045       RETURN
10046       END
10047
10048 *$ CREATE DT_COORDI.FOR
10049 *COPY DT_COORDI
10050 *
10051 *===coordi=============================================================*
10052 *
10053       SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R)
10054
10055 ************************************************************************
10056 * Calculation of coordinates of nucleons within nuclei.                *
10057 *        X(3,N)   spatial coordinates of nucleons (in fm)  (output)    *
10058 *        N / R    number of nucleons / radius of nucleus   (input)     *
10059 * Based on the original version by Shmakov et al.                      *
10060 * This version dated 26.10.95 is revised by S. Roesler                 *
10061 ************************************************************************
10062
10063       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10064       SAVE
10065       PARAMETER ( LINP = 10 ,
10066      &            LOUT = 6 ,
10067      &            LDAT = 9 )
10068
10069       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10070      &           ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10071
10072       PARAMETER (TWOPI = 6.283185307179586454D+00 )
10073
10074       LOGICAL LSTART
10075
10076       PARAMETER (NSRT=10)
10077       DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10078       DIMENSION X(3,260),WD(4),RD(3)
10079
10080       DATA PDIF/0.545D0/,R2MIN/0.16D0/
10081       DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/
10082       DATA RD /2.09D0, 0.935D0, 0.697D0/
10083
10084       X1SUM = ZERO
10085       X2SUM = ZERO
10086       X3SUM = ZERO
10087
10088       IF (N.EQ.1) THEN
10089          X(1,1) = ZERO
10090          X(2,1) = ZERO
10091          X(3,1) = ZERO
10092       ELSEIF (N.EQ.2) THEN
10093          EPS = DT_RNDM(RD(1))
10094          DO 30 I=1,3
10095             IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40
10096    30    CONTINUE
10097    40    CONTINUE
10098          DO 50 J=1,3
10099             CALL DT_RANNOR(X1,X2)
10100             X(J,1) = RD(I)*X1
10101             X(J,2) = -X(J,1)
10102    50    CONTINUE
10103       ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN
10104          SIGMA = R/SQRTWO
10105          LSTART = .TRUE.
10106          CALL DT_RANNOR(X3,X4)
10107          DO 100 I=1,N
10108             CALL DT_RANNOR(X1,X2)
10109             X(1,I) = SIGMA*X1
10110             X(2,I) = SIGMA*X2
10111             IF (LSTART) GOTO 80
10112             X(3,I) = SIGMA*X4
10113             CALL DT_RANNOR(X3,X4)
10114             GOTO 90
10115    80       CONTINUE
10116             X(3,I) = SIGMA*X3
10117    90       CONTINUE
10118             LSTART = .NOT.LSTART
10119             X1SUM = X1SUM+X(1,I)
10120             X2SUM = X2SUM+X(2,I)
10121             X3SUM = X3SUM+X(3,I)
10122   100    CONTINUE
10123          X1SUM = X1SUM/DBLE(N)
10124          X2SUM = X2SUM/DBLE(N)
10125          X3SUM = X3SUM/DBLE(N)
10126          DO 101 I=1,N
10127             X(1,I) = X(1,I)-X1SUM
10128             X(2,I) = X(2,I)-X2SUM
10129             X(3,I) = X(3,I)-X3SUM
10130   101    CONTINUE
10131       ELSE
10132
10133 * maximum nuclear radius for coordinate sampling
10134          RMAX = R+4.605D0*PDIF
10135
10136 * initialize pre-sorting
10137          DO 121 I=1,NSRT
10138             ICSRT(I) = 0
10139   121    CONTINUE
10140          DR = TWO*RMAX/DBLE(NSRT)
10141
10142 * sample coordinates for N nucleons
10143          DO 140 I=1,N
10144   120       CONTINUE
10145             RAD = RMAX*(DT_RNDM(DR))**ONETHI
10146             F   = DT_DENSIT(N,RAD,R)
10147             IF (DT_RNDM(RAD).GT.F) GOTO 120
10148 *   theta, phi uniformly distributed
10149             CT  = ONE-TWO*DT_RNDM(F)
10150             ST  = SQRT((ONE-CT)*(ONE+CT))
10151             CALL DT_DSFECF(SFE,CFE)
10152             X(1,I) = RAD*ST*CFE
10153             X(2,I) = RAD*ST*SFE
10154             X(3,I) = RAD*CT
10155 *   ensure that distance between two nucleons is greater than R2MIN
10156             IF (I.LT.2) GOTO 122
10157             I1 = I-1
10158             DO 130 I2=1,I1
10159                DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+
10160      &                 (X(3,I)-X(3,I2))**2
10161                IF (DIST2.LE.R2MIN) GOTO 120
10162   130       CONTINUE
10163   122       CONTINUE
10164 *   save index according to z-bin
10165             IDXZ        = INT( (X(3,I)+RMAX)/DR )+1
10166             ICSRT(IDXZ) = ICSRT(IDXZ)+1
10167             IDXSRT(IDXZ,ICSRT(IDXZ)) = I
10168             X1SUM = X1SUM+X(1,I)
10169             X2SUM = X2SUM+X(2,I)
10170             X3SUM = X3SUM+X(3,I)
10171   140    CONTINUE
10172          X1SUM = X1SUM/DBLE(N)
10173          X2SUM = X2SUM/DBLE(N)
10174          X3SUM = X3SUM/DBLE(N)
10175          DO 141 I=1,N
10176             X(1,I) = X(1,I)-X1SUM
10177             X(2,I) = X(2,I)-X2SUM
10178             X(3,I) = X(3,I)-X3SUM
10179   141    CONTINUE
10180
10181       ENDIF
10182
10183       RETURN
10184       END
10185
10186 *$ CREATE DT_DENSIT.FOR
10187 *COPY DT_DENSIT
10188 *
10189 *===densit=============================================================*
10190 *
10191       DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA)
10192
10193       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10194       SAVE
10195
10196       PARAMETER ( LINP = 10 ,
10197      &            LOUT = 6 ,
10198      &            LDAT = 9 )
10199       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10200       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
10201      &           PI    = TWOPI/TWO)
10202
10203       DIMENSION R0(18),FNORM(18)
10204       DATA R0 /  ZERO,   ZERO,   ZERO,   ZERO, 2.12D0,
10205      &         2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0,
10206      &         2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0,
10207      &         2.72D0, 2.66D0, 2.79D0/
10208       DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10209      &            .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10210      &            .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01,
10211      &            .1214D+01,.1265D+01,.1318D+01/
10212       DATA PDIF /0.545D0/
10213
10214       DT_DENSIT = ZERO
10215 * shell model
10216       IF (NA.LE.4) THEN
10217          STOP 'DT_DENSIT-0'
10218       ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN
10219          R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA))
10220          DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2)
10221      &            *EXP(-(R/R1)**2)/FNORM(NA)
10222 * Woods-Saxon
10223       ELSEIF (NA.GT.18) THEN
10224          DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF))
10225       ENDIF
10226
10227       RETURN
10228       END
10229
10230 *$ CREATE DT_RNCLUS.FOR
10231 *COPY DT_RNCLUS
10232 *
10233 *===rnclus=============================================================*
10234 *
10235       DOUBLE PRECISION FUNCTION DT_RNCLUS(N)
10236
10237 ************************************************************************
10238 * Nuclear radius for nucleus with mass number N.                       *
10239 * This version dated 26.9.00  is written by S. Roesler                 *
10240 ************************************************************************
10241
10242       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10243       SAVE
10244
10245       PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)
10246
10247 * nucleon radius
10248       PARAMETER (RNUCLE = 1.12D0)
10249
10250 * nuclear radii for selected nuclei
10251       DIMENSION RADNUC(18)
10252       DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0,
10253      &               2.58D0,2.71D0,2.66D0,2.71D0/
10254
10255       IF (N.LE.18) THEN
10256          IF (RADNUC(N).GT.0.0D0) THEN
10257             DT_RNCLUS = RADNUC(N)
10258          ELSE
10259             DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10260          ENDIF
10261       ELSE
10262          DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10263       ENDIF
10264
10265       RETURN
10266       END
10267
10268 *$ CREATE DT_DENTST.FOR
10269 *COPY DT_DENTST
10270 *
10271 *===dentst=============================================================*
10272 *
10273 C      PROGRAM DT_DENTST
10274       SUBROUTINE DT_DENTST
10275
10276       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10277       SAVE
10278
10279       OPEN(40,FILE='dentst.out',STATUS='UNKNOWN')
10280       OPEN(41,FILE='denmax.out',STATUS='UNKNOWN')
10281
10282       RMIN  = 0.0D0
10283       RMAX  = 8.0D0
10284       NBINS = 500.0D0
10285       DR    = (RMAX-RMIN)/DBLE(NBINS)
10286       DO 1 IA=5,18
10287          FMAX = 0.0D0
10288          DO 2 IR=1,NBINS+1
10289             R = RMIN+DBLE(IR-1)*DR
10290             F = DT_DENSIT(IA,R,R)
10291             IF (F.GT.FMAX) FMAX = F
10292             WRITE(40,'(1X,I3,2E15.5)') IA,R,F
10293     2    CONTINUE
10294          WRITE(41,'(1X,I3,E15.5)') IA,FMAX
10295     1 CONTINUE
10296
10297       CLOSE(40)
10298       CLOSE(41)
10299
10300       END
10301
10302 *$ CREATE DT_SHMAKI.FOR
10303 *COPY DT_SHMAKI
10304 *
10305 *===shmaki=============================================================*
10306 *
10307       SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE)
10308
10309 ************************************************************************
10310 * Initialisation of Glauber formalism. This subroutine has to be       *
10311 * called once (in case of target emulsions as often as many different  *
10312 * target nuclei are considered) before events are sampled.             *
10313 *         NA / NCA   mass number/charge of projectile nucleus          *
10314 *         NB / NCB   mass number/charge of target     nucleus          *
10315 *         IJP        identity of projectile (hadrons/leptons/photons)  *
10316 *         PPN        projectile momentum (for projectile nuclei:       *
10317 *                    momentum per nucleon) in target rest system       *
10318 *         MODE = 0   Glauber formalism invoked                         *
10319 *              = 1   fitted results are loaded from data-file          *
10320 *              = 99  NTARG is forced to be 1                           *
10321 *                    (used in connection with GLAUBERI-card only)      *
10322 * This version dated 22.03.96 is based on the original SHMAKI-routine  *
10323 * and revised by S. Roesler.                                           *
10324 ************************************************************************
10325
10326       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10327       SAVE
10328       PARAMETER ( LINP = 10 ,
10329      &            LOUT = 6 ,
10330      &            LDAT = 9 )
10331       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
10332      &           THREE=3.0D0)
10333
10334       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10335 * Glauber formalism: parameters
10336       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10337      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10338      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10339      &                NSITEB,NSTATB
10340 * Lorentz-parameters of the current interaction
10341       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10342      &                UMO,PPCM,EPROJ,PPROJ
10343 * properties of photon/lepton projectiles
10344       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10345 * kinematical cuts for lepton-nucleus interactions
10346       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
10347      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
10348 * Glauber formalism: cross sections
10349       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10350      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10351      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10352      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10353      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10354      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10355      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10356      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10357      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10358      &                BSLOPE,NEBINI,NQBINI
10359 * cuts for variable energy runs
10360       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
10361 * nucleon-nucleon event-generator
10362       CHARACTER*8 CMODEL
10363       LOGICAL LPHOIN
10364       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10365 * Glauber formalism: flags and parameters for statistics
10366       LOGICAL LPROD
10367       CHARACTER*8 CGLB
10368       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10369
10370       DATA NTARG,ICOUT,IVEOUT /0,0,0/
10371
10372 C     CALL DT_HISHAD
10373 C     STOP
10374
10375       NTARG = NTARG+1
10376       IF (MODE.EQ.99) NTARG = 1
10377       NIDX = -NTARG
10378       IF (MODE.EQ.-1) NIDX = NTARG
10379
10380       IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1
10381       IF (ICOUT.EQ.1) WRITE(LOUT,1000)
10382  1000    FORMAT(//,1X,'SHMAKI:    Glauber formalism (Shmakov et. al) -',
10383      &          ' initialization',/,12X,'--------------------------',
10384      &          '-------------------------',/)
10385
10386       IF (MODE.EQ.2) THEN
10387          CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10388          CALL DT_SHFAST(MODE,PPN,IBACK)
10389          STOP ' Glauber pre-initialization done'
10390       ENDIF
10391       IF (MODE.EQ.1) THEN
10392          CALL DT_PROFBI(NA,NB,PPN,NTARG)
10393       ELSE
10394          IBACK = 1
10395          IF (MODE.EQ.3)  CALL DT_SHFAST(MODE,PPN,IBACK)
10396          IF (IBACK.EQ.1) THEN
10397 * lepton-nucleus (variable energy runs)
10398             IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR.
10399      &          (IJP.EQ.10).OR.(IJP.EQ.11))   THEN
10400                IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10401      &            WRITE(LOUT,1002) NB,NCB
10402  1002          FORMAT(1X,'variable energy run:     projectile-id:  7',
10403      &                '    target A/Z: ',I3,' /',I3,/,/,8X,
10404      &                'E_cm (GeV)    Q^2 (GeV^2)',
10405      &                '    Sigma_tot (mb)     Sigma_in (mb)',/,7X,
10406      &                '--------------------------------',
10407      &                '------------------------------')
10408                AECMLO = LOG10(MIN(UMO,ECMLI))
10409                AECMHI = LOG10(MIN(UMO,ECMHI))
10410                IESTEP = NEB-1
10411                DAECM  = (AECMHI-AECMLO)/DBLE(IESTEP)
10412                IF (AECMLO.EQ.AECMHI) IESTEP = 0
10413                DO 1 I=1,IESTEP+1
10414                   ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10415                   IF (Q2HI.GT.0.1D0) THEN
10416                      IF (Q2LI.LT.0.01D0) THEN
10417                         CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10418                         IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10419      &                     WRITE(LOUT,1003)
10420      &                  ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10421                         Q2LI = 0.01D0
10422                         IBIN = 2
10423                      ELSE
10424                         IBIN = 1
10425                      ENDIF
10426                      IQSTEP = NQB-IBIN
10427                      AQ2LO  = LOG10(Q2LI)
10428                      AQ2HI  = LOG10(Q2HI)
10429                      DAQ2   = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE)
10430                      DO 2 J=IBIN,IQSTEP+IBIN
10431                         Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2)
10432                         CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX)
10433                         IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10434      &                     WRITE(LOUT,1003) ECMNN(I),
10435      &                     Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG)
10436     2                CONTINUE
10437                   ELSE
10438                      CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10439                      IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10440      &                  WRITE(LOUT,1003)
10441      &                  ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10442                   ENDIF
10443  1003             FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3)
10444     1          CONTINUE
10445                IVEOUT = 1
10446             ELSE
10447 * hadron/photon/nucleus-nucleus
10448                IF ((ABS(VAREHI).GT.ZERO).AND.
10449      &             (ABS(VAREHI).GT.ABS(VARELO))) THEN
10450                   IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN
10451                      WRITE(LOUT,1004) NA,NB,NCB
10452  1004                FORMAT(1X,'variable energy run:    projectile-id:',
10453      &                      I3,'    target A/Z: ',I3,' /',I3,/)
10454                      WRITE(LOUT,1005)
10455  1005                FORMAT('  E_cm (GeV)  E_Lab (GeV)  sig_tot^pp (mb)'
10456      &                      ,'  Sigma_tot (mb)  Sigma_prod (mb)',/,
10457      &                      ' -------------------------------------',
10458      &                      '--------------------------------------')
10459                   ENDIF
10460                   AECMLO = LOG10(VARCLO)
10461                   AECMHI = LOG10(VARCHI)
10462                   IESTEP = NEB-1
10463                   DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10464                   IF (AECMLO.EQ.AECMHI) IESTEP = 0
10465                   DO 3 I=1,IESTEP+1
10466                      ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10467                      AMP = 0.938D0
10468                      AMT = 0.938D0
10469                      AMP2 = AMP**2
10470                      AMT2 = AMT**2
10471                      ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT)
10472                      PLAB = SQRT((ELAB+AMP)*(ELAB-AMP))
10473                      CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX)
10474                      IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10475      &                 WRITE(LOUT,1006)
10476      &                 ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10477  1006             FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3)
10478     3             CONTINUE
10479                   IVEOUT = 1
10480                ELSE
10481                   CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10482                ENDIF
10483             ENDIF
10484          ENDIF
10485       ENDIF
10486
10487       IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND.
10488      &    (IOGLB.NE.100)) THEN
10489          WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH,
10490      &                    BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG)
10491  1001    FORMAT(38X,'projectile',
10492      &          '      target',/,1X,'Mass number / charge',
10493      &          17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X,
10494      &          'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X,
10495      &          'Parameters of elastic scattering amplitude:',/,5X,
10496      &          'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ',
10497      &          F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X,
10498      &          'statistics at each b-step',4X,I5,/,/,1X,
10499      &          'Prod. cross section  ',5X,F10.4,' mb',/)
10500       ENDIF
10501
10502       RETURN
10503       END
10504
10505 *$ CREATE DT_PROFBI.FOR
10506 *COPY DT_PROFBI
10507 *
10508 *===profbi=============================================================*
10509 *
10510       SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG)
10511
10512 ************************************************************************
10513 * Integral over profile function (to be used for impact-parameter      *
10514 * sampling during event generation).                                   *
10515 * Fitted results are used.                                             *
10516 *         NA / NB    mass numbers of proj./target nuclei               *
10517 *         PPN        projectile momentum (for projectile nuclei:       *
10518 *                    momentum per nucleon) in target rest system       *
10519 *         NTARG      index of target material (i.e. kind of nucleus)   *
10520 * This version dated 31.05.95 is revised by S. Roesler                 *
10521 ************************************************************************
10522
10523       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10524       SAVE
10525       PARAMETER ( LINP = 10 ,
10526      &            LOUT = 6 ,
10527      &            LDAT = 9 )
10528 CPH      SAVE
10529
10530       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
10531
10532       LOGICAL LSTART
10533       CHARACTER CNAME*80
10534
10535       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10536 * Glauber formalism: parameters
10537       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10538      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10539      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10540      &                NSITEB,NSTATB
10541 * Glauber formalism: cross sections
10542       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10543      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10544      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10545      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10546      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10547      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10548      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10549      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10550      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10551      &                BSLOPE,NEBINI,NQBINI
10552
10553       PARAMETER (NGLMAX=8000)
10554       DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX),
10555      &          GLASIG(NGLMAX),GLAFIT(5,NGLMAX)
10556
10557       DATA LSTART /.TRUE./
10558
10559       IF (LSTART) THEN
10560 * read fit-parameters from file
10561          OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN')
10562          I = 0
10563     1    CONTINUE
10564          READ(47,'(A80)') CNAME
10565          IF (CNAME.EQ.'STOP') GOTO 2
10566          I = I+1
10567          READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I),
10568      &                 GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I),
10569      &                 GLAFIT(4,I),GLAFIT(5,I)
10570          IF (I+1.GT.NGLMAX) THEN
10571             WRITE(LOUT,1000)
10572  1000       FORMAT(1X,'PROFBI:    warning! array size exceeded - ',
10573      &             'program stopped')
10574             STOP
10575          ENDIF
10576          GOTO 1
10577     2    CONTINUE
10578          NGLPAR = I
10579          LSTART = .FALSE.
10580       ENDIF
10581
10582       NNA = NA
10583       NNB = NB
10584       IF (NA.GT.NB) THEN
10585          NNA = NB
10586          NNB = NA
10587       ENDIF
10588       IDXGLA = 0
10589       DO 3 J=1,NGLPAR
10590          IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN
10591             IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1)
10592             DO 4 K=1,J-1
10593                IPOINT = J-K
10594                IF (J.EQ.NGLPAR) IPOINT = J+1-K
10595                IF ((NNA.GT.NGLIP(IPOINT)).OR.
10596      &             (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN
10597                   IF (IPOINT.EQ.1) IPOINT = 0
10598                   NATMP = NGLIP(IPOINT+1)
10599                   IF (PPN.LT.GLAPPN(IPOINT+1)) THEN
10600                      IDXGLA = IPOINT+1
10601                      GOTO 6
10602                   ELSE
10603                      J1BEG = IPOINT+1
10604                      J1END = J
10605 C                    IF (J.EQ.NGLPAR) THEN
10606 C                       J1BEG = IPOINT
10607 C                       J1END = J
10608 C                    ENDIF
10609                      DO 5 J1=J1BEG,J1END
10610                         IF (NGLIP(J1).EQ.NATMP) THEN
10611                            IF (PPN.LT.GLAPPN(J1)) THEN
10612                               IDXGLA = J1
10613                               GOTO 6
10614                            ENDIF
10615                         ELSE
10616                            IDXGLA = J1-1
10617                            GOTO 6
10618                         ENDIF
10619     5                CONTINUE
10620                      IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR)))
10621      &                  IDXGLA = NGLPAR
10622                   ENDIF
10623                ENDIF
10624     4       CONTINUE
10625          ENDIF
10626     3 CONTINUE
10627
10628     6 CONTINUE
10629       IF (IDXGLA.EQ.0) THEN
10630          WRITE(LOUT,1001) NNA,NNB,PPN
10631  1001    FORMAT(1X,'PROFBI:   configuration (NA,NB,PPN = ',
10632      &          2I4,F6.0,') not found ')
10633          STOP
10634       ENDIF
10635
10636 * no interpolation yet available
10637       XSPRO(1,1,NTARG) = GLASIG(IDXGLA)
10638
10639       BSITE(1,1,NTARG,1) = ZERO
10640       DO 10 I=2,NSITEB
10641          XX = DBLE(I)
10642          POLY  = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+
10643      &           GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+
10644      &           GLAFIT(5,IDXGLA)*XX**4
10645          IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY)
10646          BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY))
10647          IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO
10648    10 CONTINUE
10649
10650       RETURN
10651       END
10652
10653 *$ CREATE DT_GLAUBE.FOR
10654 *COPY DT_GLAUBE
10655 *
10656 *===glaube=============================================================*
10657 *
10658       SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX)
10659
10660 ************************************************************************
10661 * Calculation of configuartion of interacting nucleons for one event.  *
10662 *    NB / NB    mass numbers of proj./target nuclei           (input)  *
10663 *    B          impact parameter                              (output) *
10664 *    INTT       total number of wounded nucleons                 "     *
10665 *    INTA / INTB number of wounded nucleons in proj. / target    "     *
10666 *    JS / JT(i) number of collisions proj. / target nucleon i is       *
10667 *                                                   involved  (output) *
10668 *    NIDX       index of projectile/target material            (input) *
10669 *               = -2 call within FLUKA transport calculation           *
10670 * This is an update of the original routine SHMAKO by J.Ranft/HJM      *
10671 * This version dated 22.03.96 is revised by S. Roesler                 *
10672 *                                                                      *
10673 * Last change 27.12.2006 by S. Roesler.                                *
10674 ************************************************************************
10675
10676       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10677       SAVE
10678       PARAMETER ( LINP = 10 ,
10679      &            LOUT = 6 ,
10680      &            LDAT = 9 )
10681       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
10682      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
10683
10684       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10685       PARAMETER ( MAXNCL = 260,
10686      &            MAXVQU = MAXNCL,
10687      &            MAXSQU = 20*MAXVQU,
10688      &            MAXINT = MAXVQU+MAXSQU)
10689 * Glauber formalism: parameters
10690       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10691      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10692      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10693      &                NSITEB,NSTATB
10694 * Glauber formalism: cross sections
10695       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10696      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10697      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10698      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10699      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10700      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10701      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10702      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10703      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10704      &                BSLOPE,NEBINI,NQBINI
10705 * Lorentz-parameters of the current interaction
10706       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10707      &                UMO,PPCM,EPROJ,PPROJ
10708 * properties of photon/lepton projectiles
10709       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10710 * Glauber formalism: collision properties
10711       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
10712      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
10713 * Glauber formalism: flags and parameters for statistics
10714       LOGICAL LPROD
10715       CHARACTER*8 CGLB
10716       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10717
10718       DIMENSION JS(MAXNCL),JT(MAXNCL)
10719
10720       NTARG = ABS(NIDX)
10721
10722 * get actual energy from /DTLTRA/
10723       ECMNOW = UMO
10724       Q2     = VIRT
10725 *
10726 * new patch for pre-initialized variable projectile/target/energy runs,
10727 * bypassed for use within FLUKA (Nidx=-2)
10728       IF (IOGLB.EQ.100) THEN
10729          IF (NIDX.NE.-2) CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1)
10730 *
10731 * variable energy run, interpolate profile function
10732       ELSE
10733          I1   = 1
10734          I2   = 1
10735          RATE = ONE
10736          IF (NEBINI.GT.1) THEN
10737             IF (ECMNOW.GE.ECMNN(NEBINI)) THEN
10738                I1   = NEBINI
10739                I2   = NEBINI
10740                RATE = ONE
10741             ELSEIF (ECMNOW.GT.ECMNN(1)) THEN
10742                DO 1 I=2,NEBINI
10743                   IF (ECMNOW.LT.ECMNN(I)) THEN
10744                      I1   = I-1
10745                      I2   = I
10746                      RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
10747                      GOTO 2
10748                   ENDIF
10749     1          CONTINUE
10750     2          CONTINUE
10751             ENDIF
10752          ENDIF
10753          J1   = 1
10754          J2   = 1
10755          RATQ = ONE
10756          IF (NQBINI.GT.1) THEN
10757             IF (Q2.GE.Q2G(NQBINI)) THEN
10758                J1   = NQBINI
10759                J2   = NQBINI
10760                RATQ = ONE
10761             ELSEIF (Q2.GT.Q2G(1)) THEN
10762                DO 3 I=2,NQBINI
10763                   IF (Q2.LT.Q2G(I)) THEN
10764                      J1   = I-1
10765                      J2   = I
10766                      RATQ = LOG10(     Q2/MAX(Q2G(J1),TINY14))/
10767      &                      LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
10768 C                    RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1))
10769                      GOTO 4
10770                   ENDIF
10771     3          CONTINUE
10772     4          CONTINUE
10773             ENDIF
10774          ENDIF
10775
10776          DO 5 I=1,KSITEB
10777             BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+
10778      &         RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10779      &         RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10780      &         RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+
10781      &                    BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I))
10782     5    CONTINUE
10783       ENDIF
10784
10785       CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX)
10786       IF (NIDX.LE.-1) THEN
10787          RPROJ = RASH(1)
10788          RTARG = RBSH(NTARG)
10789       ELSE
10790          RPROJ = RASH(NTARG)
10791          RTARG = RBSH(1)
10792       ENDIF
10793
10794       RETURN
10795       END
10796
10797 *$ CREATE DT_DIAGR.FOR
10798 *COPY DT_DIAGR
10799 *
10800 *===diagr==============================================================*
10801 *
10802       SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC,
10803      &                                                         NIDX)
10804
10805 ************************************************************************
10806 * Based on the original version by Shmakov et al.                      *
10807 * This version dated 21.04.95 is revised by S. Roesler                 *
10808 ************************************************************************
10809
10810       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10811       SAVE
10812       PARAMETER ( LINP = 10 ,
10813      &            LOUT = 6 ,
10814      &            LDAT = 9 )
10815       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10816       PARAMETER (TWOPI  = 6.283185307179586454D+00,
10817      &           PI     = TWOPI/TWO,
10818      &           GEV2MB = 0.38938D0,
10819      &           GEV2FM = 0.1972D0,
10820      &           ALPHEM = ONE/137.0D0,
10821 * proton mass
10822      &           AMP    = 0.938D0,
10823      &           AMP2   = AMP**2,
10824 * rho0 mass
10825      &           AMRHO0 = 0.77D0)
10826
10827       COMPLEX*16 C,CA,CI
10828       PARAMETER ( MAXNCL = 260,
10829      &            MAXVQU = MAXNCL,
10830      &            MAXSQU = 20*MAXVQU,
10831      &            MAXINT = MAXVQU+MAXSQU)
10832 * particle properties (BAMJET index convention)
10833       CHARACTER*8  ANAME
10834       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
10835      &                IICH(210),IIBAR(210),K1(210),K2(210)
10836       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10837 * emulsion treatment
10838       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
10839      &                NCOMPO,IEMUL
10840 * Glauber formalism: parameters
10841       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10842      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10843      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10844      &                NSITEB,NSTATB
10845 * Glauber formalism: cross sections
10846       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10847      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10848      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10849      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10850      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10851      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10852      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10853      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10854      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10855      &                BSLOPE,NEBINI,NQBINI
10856 * VDM parameter for photon-nucleus interactions
10857       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
10858 * nucleon-nucleon event-generator
10859       CHARACTER*8 CMODEL
10860       LOGICAL LPHOIN
10861       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10862 **PHOJET105a
10863 C     COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10864 **PHOJET112
10865 C  obsolete cut-off information
10866       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
10867       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10868 **
10869 * coordinates of nucleons
10870       COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
10871 * interface between Glauber formalism and DPM
10872       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
10873      &                INTER1(MAXINT),INTER2(MAXINT)
10874 * statistics: Glauber-formalism
10875       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
10876 * n-n cross section fluctuations
10877       PARAMETER (NBINS = 1000)
10878       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
10879
10880       DIMENSION JS(MAXNCL),JT(MAXNCL),
10881      &          JS0(MAXNCL),JT0(MAXNCL,MAXNCL),
10882      &          JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL)
10883       DIMENSION NWA(0:210),NWB(0:210)
10884
10885       LOGICAL LFIRST
10886       DATA LFIRST /.TRUE./
10887
10888       DATA NTARGO,ICNT /0,0/
10889
10890       NTARG = ABS(NIDX)
10891
10892       IF (LFIRST) THEN
10893          LFIRST = .FALSE.
10894          IF (NCOMPO.EQ.0) THEN
10895             NCALL  = 0
10896             NWAMAX = NA
10897             NWBMAX = NB
10898             DO 17 I=0,210
10899                NWA(I) = 0
10900                NWB(I) = 0
10901    17       CONTINUE
10902          ENDIF
10903       ENDIF
10904       IF (NTARG.EQ.-1) THEN
10905          IF (NCOMPO.EQ.0) THEN
10906             WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons'
10907             WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ',
10908      &                                NCALL,NWAMAX,NWBMAX
10909             DO 18 I=1,MAX(NWAMAX,NWBMAX)
10910                WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)')
10911      &                          I,NWA(I),DBLE(NWA(I))/DBLE(NCALL),
10912      &                            NWB(I),DBLE(NWB(I))/DBLE(NCALL)
10913    18       CONTINUE
10914          ENDIF
10915          RETURN
10916       ENDIF
10917
10918       DCOH   = 1.0D10
10919       IPNT   = 0
10920
10921       SQ2  = Q2
10922       IF (SQ2.LE.ZERO) SQ2 = 0.0001D0
10923       S   = ECMNOW**2
10924       X   = SQ2/(S+SQ2-AMP2)
10925       XNU = (S+SQ2-AMP2)/(TWO*AMP)
10926 * photon projectiles: recalculate photon-nucleon amplitude
10927       IF (IJPROJ.EQ.7) THEN
10928    15    CONTINUE
10929 *  VDM assumption: mass of V-meson
10930          AMV2   = DT_SAM2(SQ2,ECMNOW)
10931          AMV    = SQRT(AMV2)
10932          IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15
10933 *  check for pointlike interaction
10934          CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1)
10935 **sr 27.10.
10936 C        SIGSH  = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
10937          SIGSH  = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
10938 **
10939          ROSH   = 0.1D0
10940          BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2)
10941      &                   +0.25D0*LOG(S/(AMV2+SQ2)))
10942 *  coherence length
10943          IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM
10944       ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
10945          IF (MCGENE.EQ.2) THEN
10946             ZERO1 = ZERO
10947             CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3,
10948      &                                                BSLOPE,0)
10949          ELSE
10950             BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
10951          ENDIF
10952          IF (ECMNOW.LE.3.0D0) THEN
10953             ROSH = -0.43D0
10954          ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN
10955             ROSH = -0.63D0+0.175D0*LOG(ECMNOW)
10956          ELSEIF (ECMNOW.GT.50.0D0) THEN
10957             ROSH = 0.1D0
10958          ENDIF
10959          ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
10960          PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
10961          IF (MCGENE.EQ.2) THEN
10962             ZERO1 = ZERO
10963             CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3,
10964      &                                                  BDUM,0)
10965             SIGSH = SIGSH/10.0D0
10966          ELSE
10967 C           SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
10968             DUMZER = ZERO
10969             CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
10970             SIGSH = SIGSH/10.0D0
10971          ENDIF
10972       ELSE
10973          BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
10974          ROSH   = 0.01D0
10975          ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
10976          PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
10977 C        SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
10978          DUMZER = ZERO
10979          CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
10980          SIGSH = SIGSH/10.0D0
10981       ENDIF
10982       GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
10983       GAM = GSH
10984       RCA = GAM*SIGSH/TWOPI
10985       FCA = -ROSH*RCA
10986       CA  = DCMPLX(RCA,FCA)
10987       CI  = DCMPLX(ONE,ZERO)
10988
10989    16 CONTINUE
10990 * impact parameter
10991       IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX)
10992
10993       NTRY = 0
10994     3 CONTINUE
10995       NTRY = NTRY+1
10996 * initializations
10997       JNT  = 0
10998       DO 1 I=1,NA
10999          JS(I) = 0
11000     1 CONTINUE
11001       DO 2 I=1,NB
11002          JT(I) = 0
11003     2 CONTINUE
11004       IF (IJPROJ.EQ.7) THEN
11005          DO 8 I=1,MAXNCL
11006             JS0(I) = 0
11007             JNT0(I)= 0
11008             DO 9 J=1,NB
11009                JT0(I,J) = 0
11010     9       CONTINUE
11011     8    CONTINUE
11012       ENDIF
11013
11014 * nucleon configuration
11015 C     IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN
11016       IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN
11017 C        CALL DT_CONUCL(PKOO,NA,RASH,2)
11018 C        CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1)
11019          IF (NIDX.LE.-1) THEN
11020             CALL DT_CONUCL(PKOO,NA,RASH(1),0)
11021             CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0)
11022          ELSE
11023             CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0)
11024             CALL DT_CONUCL(TKOO,NB,RBSH(1),0)
11025          ENDIF
11026          NTARGO = NTARG
11027       ENDIF
11028       ICNT = ICNT+1
11029
11030 * LEPTO: pick out one struck nucleon
11031       IF (MCGENE.EQ.3) THEN
11032          JNT     = 1
11033          JS(1)   = 1
11034          IDX     = INT(DT_RNDM(X)*NB)+1
11035          JT(IDX) = 1
11036          B       = ZERO
11037          GOTO 19
11038       ENDIF
11039
11040       DO 4 INA=1,NA
11041 * cross section fluctuations
11042          AFLUC = ONE
11043          IF (IFLUCT.EQ.1) THEN
11044             IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0)
11045             AFLUC = FLUIXX(IFLUK)
11046          ENDIF
11047          KK1  = 1
11048          KINT = 1
11049          DO 5 INB=1,NB
11050 * photon-projectile: check for supression by coherence length
11051             IF (IJPROJ.EQ.7) THEN
11052                IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN
11053                   KK1  = INB
11054                   KINT = KINT+1
11055                ENDIF
11056             ENDIF
11057             QQ1 = B+TKOO(1,INB)-PKOO(1,INA)
11058             QQ2 =   TKOO(2,INB)-PKOO(2,INA)
11059             XY  = GAM*(QQ1*QQ1+QQ2*QQ2)
11060             IF (XY.LE.15.0D0) THEN
11061                C  = CI-CA*AFLUC*EXP(-XY)
11062                AR = DBLE(C)
11063                AI = DIMAG(C)
11064                P  = AR*AR+AI*AI
11065                IF (DT_RNDM(XY).GE.P) THEN
11066                   JNT = JNT+1
11067                   IF (IJPROJ.EQ.7) THEN
11068                      JNT0(KINT) = JNT0(KINT)+1
11069                      IF (JNT0(KINT).GT.MAXNCL) THEN
11070                         WRITE(LOUT,1001) MAXNCL
11071  1001                   FORMAT(1X,
11072      &                        'DIAGR:  no. of requested interactions',
11073      &                        ' exceeds array dimensions ',I4)
11074                         STOP
11075                      ENDIF
11076                      JS0(KINT)      = JS0(KINT)+1
11077                      JT0(KINT,INB)  = JT0(KINT,INB)+1
11078                      JI1(KINT,JNT0(KINT)) = INA
11079                      JI2(KINT,JNT0(KINT)) = INB
11080                   ELSE
11081                      IF (JNT.GT.MAXINT) THEN
11082                         WRITE(LOUT,1000) JNT, MAXINT
11083  1000                   FORMAT(1X,
11084      &                        'DIAGR:  no. of requested interactions ('
11085      &                        ,I4,') exceeds array dimensions (',I4,')')
11086                         STOP
11087                      ENDIF
11088                      JS(INA) = JS(INA)+1
11089                      JT(INB) = JT(INB)+1
11090                      INTER1(JNT) = INA
11091                      INTER2(JNT) = INB
11092                   ENDIF
11093                ENDIF
11094             ENDIF
11095     5    CONTINUE
11096     4 CONTINUE
11097
11098       IF (JNT.EQ.0) THEN
11099          IF (NTRY.LT.500) THEN
11100             GOTO 3
11101          ELSE
11102 C           WRITE(6,*) ' new impact parameter required (old= ',B,')'
11103             GOTO 16
11104          ENDIF
11105       ENDIF
11106
11107       IDIREC = 0
11108       IF (IJPROJ.EQ.7) THEN
11109          K = INT(ONE+DT_RNDM(X)*DBLE(KINT))
11110    10    CONTINUE
11111          IF (JNT0(K).EQ.0) THEN
11112             K = K+1
11113             IF (K.GT.KINT) K = 1
11114             GOTO 10
11115          ENDIF
11116 * supress Glauber-cascade by direct photon processes
11117          CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2)
11118          IF (IPNT.GT.0) THEN
11119             JNT   = 1
11120             JS(1) = 1
11121             DO 11 INB=1,NB
11122                JT(INB) = JT0(K,INB)
11123                IF (JT(INB).GT.0) GOTO 12
11124    11       CONTINUE
11125    12       CONTINUE
11126             INTER1(1) = 1
11127             INTER2(1) = INB
11128             IDIREC    = IPNT
11129          ELSE
11130             JNT   = JNT0(K)
11131             JS(1) = JS0(K)
11132             DO 13 INB=1,NB
11133                JT(INB) = JT0(K,INB)
11134    13       CONTINUE
11135             DO 14 I=1,JNT
11136                INTER1(I) = JI1(K,I)
11137                INTER2(I) = JI2(K,I)
11138    14       CONTINUE
11139          ENDIF
11140       ENDIF
11141
11142    19 CONTINUE
11143       INTA = 0
11144       INTB = 0
11145       DO 6 I=1,NA
11146         IF (JS(I).NE.0) INTA=INTA+1
11147     6 CONTINUE
11148       DO 7 I=1,NB
11149         IF (JT(I).NE.0) INTB=INTB+1
11150     7 CONTINUE
11151       ICWPG = INTA
11152       ICWTG = INTB
11153       ICIG  = JNT
11154       IPGLB = IPGLB+INTA
11155       ITGLB = ITGLB+INTB
11156       NGLB = NGLB+1
11157
11158       IF (NCOMPO.EQ.0) THEN
11159          NCALL = NCALL+1
11160          NWA(INTA) = NWA(INTA)+1
11161          NWB(INTB) = NWB(INTB)+1
11162       ENDIF
11163
11164       RETURN
11165       END
11166
11167 *$ CREATE DT_MODB.FOR
11168 *COPY DT_MODB
11169 *
11170 *===modb===============================================================*
11171 *
11172       SUBROUTINE DT_MODB(B,NIDX)
11173
11174 ************************************************************************
11175 * Sampling of impact parameter of collision.                           *
11176 *    B          impact parameter    (output)                           *
11177 *    NIDX       index of projectile/target material             (input)*
11178 * Based on the original version by Shmakov et al.                      *
11179 * This version dated 21.04.95 is revised by S. Roesler                 *
11180 *                                                                      *
11181 * Last change 27.12.2006 by S. Roesler.                                *
11182 ************************************************************************
11183
11184       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11185       SAVE
11186       PARAMETER ( LINP = 10 ,
11187      &            LOUT = 6 ,
11188      &            LDAT = 9 )
11189       PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0)
11190
11191       LOGICAL LEFT,LFIRST
11192
11193 * central particle production, impact parameter biasing
11194       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
11195       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11196 * Glauber formalism: parameters
11197       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11198      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11199      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11200      &                NSITEB,NSTATB
11201 * Glauber formalism: cross sections
11202       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11203      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11204      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11205      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11206      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11207      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11208      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11209      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11210      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11211      &                BSLOPE,NEBINI,NQBINI
11212
11213       DATA LFIRST /.TRUE./
11214
11215       NTARG = ABS(NIDX)
11216       IF (NIDX.LE.-1) THEN
11217          RA = RASH(1)
11218          RB = RBSH(NTARG)
11219       ELSE
11220          RA = RASH(NTARG)
11221          RB = RBSH(1)
11222       ENDIF
11223
11224       IF (ICENTR.EQ.2) THEN
11225          IF (RA.EQ.RB) THEN
11226             BB = DT_RNDM(B)*(0.3D0*RA)**2
11227             B  = SQRT(BB)
11228          ELSEIF(RA.LT.RB)THEN
11229             BB = DT_RNDM(B)*1.4D0*(RB-RA)**2
11230             B  = SQRT(BB)
11231          ELSEIF(RA.GT.RB)THEN
11232             BB = DT_RNDM(B)*1.4D0*(RA-RB)**2
11233             B  = SQRT(BB)
11234          ENDIF
11235       ELSE
11236     9    CONTINUE
11237          Y  = DT_RNDM(BB)
11238          I0 = 1
11239          I2 = NSITEB
11240    10    CONTINUE
11241          I1 = (I0+I2)/2
11242          LEFT = ((BSITE(0,1,NTARG,I0)-Y)
11243      &          *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO
11244          IF (LEFT) GOTO 20
11245          I0 = I1
11246          GOTO 30
11247    20    CONTINUE
11248          I2 = I1
11249    30    CONTINUE
11250          IF (I2-I0-2) 40,50,60
11251    40    CONTINUE
11252          I1 = I2+1
11253          IF (I1.GT.NSITEB) I1 = I0-1
11254          GOTO 70
11255    50    CONTINUE
11256          I1 = I0+1
11257          GOTO 70
11258    60    CONTINUE
11259          GOTO 10
11260    70    CONTINUE
11261          X0 = DBLE(I0-1)*BSTEP(NTARG)
11262          X1 = DBLE(I1-1)*BSTEP(NTARG)
11263          X2 = DBLE(I2-1)*BSTEP(NTARG)
11264          Y0 = BSITE(0,1,NTARG,I0)
11265          Y1 = BSITE(0,1,NTARG,I1)
11266          Y2 = BSITE(0,1,NTARG,I2)
11267    80    CONTINUE
11268          B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+
11269      &       X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+
11270      &       X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15)
11271 **sr 5.4.98: shift B by half the bin width to be in agreement with BPROD
11272          B = B+0.5D0*BSTEP(NTARG)
11273          IF (B.LT.ZERO) B = X1
11274          IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG)
11275          IF (ICENTR.LT.0) THEN
11276             IF (LFIRST) THEN
11277                LFIRST = .FALSE.
11278                IF (ICENTR.LE.-100) THEN
11279                   BIMIN  = 0.0D0
11280                ELSE
11281                   XSFRAC = 0.0D0
11282                ENDIF
11283                CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG)
11284                WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG),
11285      &                          BIMIN,BIMAX,XSFRAC*100.0D0,
11286      &                          XSFRAC*XSPRO(1,1,NTARG)
11287  10000         FORMAT(/,1X,'DT_MODB:      Biasing in impact parameter',
11288      &                /,15X,'---------------------------'/,/,4X,
11289      &                'average radii of proj / targ :',F10.3,' fm /',
11290      &                F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :',
11291      &                F10.3,' fm',/,/,21X,'b_lo / b_hi :',
11292      &                F10.3,' fm /',F7.3,' fm',/,5X,'percentage of',
11293      &                ' cross section :',F10.3,' %',/,5X,
11294      &                'corresponding cross section :',F10.3,' mb',/)
11295             ENDIF
11296             IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN
11297                B = BIMIN
11298             ELSE
11299                IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9
11300             ENDIF
11301          ENDIF
11302       ENDIF
11303
11304       RETURN
11305       END
11306
11307 *$ CREATE DT_SHFAST.FOR
11308 *COPY DT_SHFAST
11309 *
11310 *===shfast=============================================================*
11311 *
11312       SUBROUTINE DT_SHFAST(MODE,PPN,IBACK)
11313
11314       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11315       SAVE
11316       PARAMETER ( LINP = 10 ,
11317      &            LOUT = 6 ,
11318      &            LDAT = 9 )
11319       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1,
11320      &           ONE=1.0D0,TWO=2.0D0)
11321
11322       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11323 * Glauber formalism: parameters
11324       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11325      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11326      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11327      &                NSITEB,NSTATB
11328 * properties of interacting particles
11329       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11330 * Glauber formalism: cross sections
11331       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11332      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11333      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11334      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11335      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11336      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11337      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11338      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11339      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11340      &                BSLOPE,NEBINI,NQBINI
11341
11342       IBACK = 0
11343
11344       IF (MODE.EQ.2) THEN
11345          OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11346          WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN
11347  1000    FORMAT(1X,8I5,E15.5)
11348          WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11349  1001    FORMAT(1X,4E15.5)
11350          WRITE(47,1002) SIGSH,ROSH,GSH
11351  1002    FORMAT(1X,3E15.5)
11352          DO 10 I=1,100
11353             WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I)
11354    10    CONTINUE
11355          WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11356  1003    FORMAT(1X,2I10,3E15.5)
11357          CLOSE(47)
11358       ELSE
11359          OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11360          READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP
11361          IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND.
11362      &       (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ)
11363      &       .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND.
11364      &       (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN
11365             READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11366             READ(47,1002) SIGSH,ROSH,GSH
11367             DO 11 I=1,100
11368                READ(47,'(1X,E15.5)') BSITE(1,1,1,I)
11369    11       CONTINUE
11370             READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11371          ELSE
11372             IBACK = 1
11373          ENDIF
11374          CLOSE(47)
11375       ENDIF
11376
11377       RETURN
11378       END
11379
11380 *$ CREATE DT_POILIK.FOR
11381 *COPY DT_POILIK
11382 *
11383 *===poilik=============================================================*
11384 *
11385       SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE)
11386
11387       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
11388       SAVE
11389
11390       PARAMETER ( LINP = 10 ,
11391      &            LOUT = 6 ,
11392      &            LDAT = 9 )
11393       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0)
11394       PARAMETER (NE = 8)
11395
11396 **PHOJET105a
11397 C     CHARACTER*8 MDLNA
11398 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
11399 C     PARAMETER (IEETAB=10)
11400 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
11401 **PHOJET110
11402 C  model switches and parameters
11403       CHARACTER*8 MDLNA
11404       INTEGER ISWMDL,IPAMDL
11405       DOUBLE PRECISION PARMDL
11406       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11407 C  energy-interpolation table
11408       INTEGER IEETA2
11409       PARAMETER ( IEETA2 = 20 )
11410       INTEGER ISIMAX
11411       DOUBLE PRECISION SIGTAB,SIGECM
11412       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
11413 **
11414 * VDM parameter for photon-nucleus interactions
11415       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11416 **sr 22.7.97
11417       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11418 * Glauber formalism: cross sections
11419       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11420      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11421      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11422      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11423      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11424      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11425      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11426      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11427      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11428      &                BSLOPE,NEBINI,NQBINI
11429 **
11430
11431       DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/
11432
11433       IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3
11434
11435 * load cross sections from interpolation table
11436       IP = 1
11437       IF(ECM.LE.SIGECM(IP,1)) THEN
11438         I1 = 1
11439         I2 = 1
11440       ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
11441         DO 50 I=2,ISIMAX
11442           IF(ECM.LE.SIGECM(IP,I)) GOTO 200
11443   50    CONTINUE
11444  200    CONTINUE
11445         I1 = I-1
11446         I2 = I
11447       ELSE
11448         WRITE(LOUT,'(/1X,A,2E12.3)')
11449      &    'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
11450         I1 = ISIMAX
11451         I2 = ISIMAX
11452       ENDIF
11453       FAC2 = ZERO
11454       IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
11455      &                     /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
11456       FAC1 = ONE-FAC2
11457
11458       SIGANO = DT_SANO(ECM)
11459
11460 * cross section dependence on photon virtuality
11461       FSUP1 = ZERO
11462       DO  150 I=1,3
11463          FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I)))
11464      &                             /(ONE+VIRT/PARMDL(30+I))**2
11465  150  CONTINUE
11466       FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34))
11467       FAC1  = FAC1*FSUP1
11468       FAC2  = FAC2*FSUP1
11469       FSUP2 = ONE
11470
11471       ECMOLD = ECM
11472       Q2OLD  = VIRT
11473
11474     3 CONTINUE
11475
11476 C     SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
11477       CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2)
11478       IF (ISHAD(1).EQ.1) THEN
11479          SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
11480       ELSE
11481          SIGDIR = ZERO
11482       ENDIF
11483       SIGANO = FSUP1*FSUP2*SIGANO
11484       SIGTOT = SIGTOT-SIGDIR-SIGANO
11485       SIGDIR = SIGDIR/(FSUP1*FSUP2)
11486       SIGANO = SIGANO/(FSUP1*FSUP2)
11487       SIGTOT = SIGTOT+SIGDIR+SIGANO
11488
11489       RR = DT_RNDM(SIGTOT)
11490       IF (RR.LT.SIGDIR/SIGTOT) THEN
11491          IPNT = 1
11492       ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND.
11493      &        (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN
11494          IPNT = 2
11495       ELSE
11496          IPNT = 0
11497       ENDIF
11498       RPNT = (SIGDIR+SIGANO)/SIGTOT
11499 C     WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2
11500 C     WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO
11501 C     WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM
11502 C     WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT
11503       IF (MODE.EQ.1) RETURN
11504
11505 **sr 22.7.97
11506       K1   = 1
11507       K2   = 1
11508       RATE = ZERO
11509       IF (ECM.GE.ECMNN(NEBINI)) THEN
11510          K1   = NEBINI
11511          K2   = NEBINI
11512          RATE = ONE
11513       ELSEIF (ECM.GT.ECMNN(1)) THEN
11514          DO 10 I=2,NEBINI
11515             IF (ECM.LT.ECMNN(I)) THEN
11516                K1   = I-1
11517                K2   = I
11518                RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1))
11519                GOTO 11
11520             ENDIF
11521    10    CONTINUE
11522    11    CONTINUE
11523       ENDIF
11524       J1   = 1
11525       J2   = 1
11526       RATQ = ZERO
11527       IF (NQBINI.GT.1) THEN
11528          IF (VIRT.GE.Q2G(NQBINI)) THEN
11529             J1   = NQBINI
11530             J2   = NQBINI
11531             RATQ = ONE
11532          ELSEIF (VIRT.GT.Q2G(1)) THEN
11533             DO 12 I=2,NQBINI
11534                IF (VIRT.LT.Q2G(I)) THEN
11535                   J1   = I-1
11536                   J2   = I
11537                   RATQ = LOG10(   VIRT/MAX(Q2G(J1),TINY14))/
11538      &                   LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
11539                   GOTO 13
11540                ENDIF
11541    12       CONTINUE
11542    13       CONTINUE
11543          ENDIF
11544       ENDIF
11545       SGA = XSPRO(K1,J1,NTARG)+
11546      &      RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+
11547      &      RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+
11548      &      RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+
11549      &                 XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG))
11550       SDI = DBLE(NB)*SIGDIR
11551       SAN = DBLE(NB)*SIGANO
11552       SPL = SDI+SAN
11553       RR = DT_RNDM(SPL)
11554       IF (RR.LT.SDI/SGA) THEN
11555          IPNT = 1
11556       ELSEIF ((RR.GE.SDI/SGA).AND.
11557      &        (RR.LT.SPL/SGA)) THEN
11558          IPNT = 2
11559       ELSE
11560          IPNT = 0
11561       ENDIF
11562       RPNT = SPL/SGA
11563 C     WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM
11564 **
11565
11566       RETURN
11567       END
11568
11569 *$ CREATE DT_GLBINI.FOR
11570 *COPY DT_GLBINI
11571 *
11572 *===glbini=============================================================*
11573 *
11574       SUBROUTINE DT_GLBINI(WHAT)
11575
11576 ************************************************************************
11577 * Pre-initialization of profile function                               *
11578 * This version dated 28.11.00 is written by S. Roesler.                *
11579 *                                                                      *
11580 * Last change 27.12.2006 by S. Roesler.                                *
11581 ************************************************************************
11582
11583       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11584       SAVE
11585
11586       PARAMETER ( LINP = 10 ,
11587      &            LOUT = 6 ,
11588      &            LDAT = 9 )
11589       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14)
11590
11591       LOGICAL LCMS
11592
11593 * particle properties (BAMJET index convention)
11594       CHARACTER*8  ANAME
11595       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11596      &                IICH(210),IIBAR(210),K1(210),K2(210)
11597 * properties of interacting particles
11598       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11599       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11600 * emulsion treatment
11601       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11602      &                NCOMPO,IEMUL
11603 * Glauber formalism: flags and parameters for statistics
11604       LOGICAL LPROD
11605       CHARACTER*8 CGLB
11606       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11607 * number of data sets other than protons and nuclei
11608 * at the moment = 2 (pions and kaons)
11609       PARAMETER (MAXOFF=2)
11610       DIMENSION IJPINI(5),IOFFST(25)
11611       DATA IJPINI / 13, 15,  0,  0,  0/
11612 * Glauber data-set to be used for hadron projectiles
11613 * (0=proton, 1=pion, 2=kaon)
11614       DATA (IOFFST(K),K=1,25) /
11615      &  0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11616      &  0, 0, 1, 2, 2/
11617 * Acceptance interval for target nucleus mass
11618       PARAMETER (KBACC = 6)
11619 * flags for input different options
11620       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
11621       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
11622      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
11623
11624       PARAMETER (MAXMSS = 100)
11625       DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS)
11626       DIMENSION WHAT(6)
11627
11628       DATA JPEACH,JPSTEP / 18, 5 /
11629
11630 * temporary patch until fix has been implemented in phojet:
11631 *  maximum energy for pion projectile
11632       DATA ECMXPI / 100000.0D0 /
11633 *
11634 *--------------------------------------------------------------------------
11635 * general initializations
11636 *
11637 *  steps in projectile mass number for initialization
11638       IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4))
11639       IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5))
11640 *
11641 *  energy range and binning
11642       ELO  = ABS(WHAT(1))
11643       EHI  = ABS(WHAT(2))
11644       IF (ELO.GT.EHI) ELO = EHI
11645       NEBIN = MAX(INT(WHAT(3)),1)
11646       IF (ELO.EQ.EHI) NEBIN = 0
11647       LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO)
11648       IF (LCMS) THEN
11649          ECMINI = EHI
11650       ELSE
11651          ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2
11652      &                 +2.0D0*AAM(IJTARG)*EHI)
11653       ENDIF
11654 *
11655 *  default arguments for Glauber-routine
11656       XI  = ZERO
11657       Q2I = ZERO
11658 *
11659 *  initialize nuclear parameters, etc.
11660       CALL DT_BERTTP
11661       CALL DT_INCINI
11662 *
11663 *  open Glauber-data output file
11664       IDX = INDEX(CGLB,' ')
11665       K   = 12
11666       IF (IDX.GT.1) K = IDX-1
11667       OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
11668 *
11669 *--------------------------------------------------------------------------
11670 * Glauber-initialization for proton and nuclei projectiles
11671 *
11672 *  initialize phojet for proton-proton interactions
11673       ELAB = ZERO
11674       PLAB = ZERO
11675       CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11676       CALL DT_PHOINI
11677 *
11678 *  record projectile masses
11679       NASAV = 0
11680       NPROJ = MIN(IP,JPEACH)
11681       DO 10 KPROJ=1,NPROJ
11682          NASAV = NASAV+1
11683          IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11684          IASAV(NASAV) = KPROJ
11685    10 CONTINUE
11686       IF (IP.GT.JPEACH) THEN
11687          NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP)
11688          IF (NPROJ.EQ.0) THEN
11689             NASAV = NASAV+1
11690             IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11691             IASAV(NASAV) = IP
11692          ELSE
11693             DO 11 IPROJ=1,NPROJ
11694                KPROJ = JPEACH+IPROJ*JPSTEP
11695                NASAV = NASAV+1
11696                IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11697                IASAV(NASAV) = KPROJ
11698    11       CONTINUE
11699             IF (KPROJ.LT.IP) THEN
11700                NASAV = NASAV+1
11701                IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11702                IASAV(NASAV) = IP
11703             ENDIF
11704          ENDIF
11705       ENDIF
11706 *
11707 *  record target masses
11708       NBSAV = 0
11709       NTARG = 1
11710       IF (NCOMPO.GT.0) NTARG = NCOMPO
11711       DO 12 ITARG=1,NTARG
11712          NBSAV = NBSAV+1
11713          IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! '
11714          IF (NCOMPO.GT.0) THEN
11715             IBSAV(NBSAV) = IEMUMA(ITARG)
11716          ELSE
11717             IBSAV(NBSAV) = IT
11718          ENDIF
11719    12 CONTINUE
11720 *
11721 *  print masses
11722       WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2))
11723  1000 FORMAT(I4,A,1P,2E13.5)
11724       NLINES = DBLE(NASAV)/18.0D0
11725       IF (NLINES.GT.0) THEN
11726          DO 13 I=1,NLINES
11727             IF (I.EQ.1) THEN
11728                WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18)
11729             ELSE
11730                WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I)
11731             ENDIF
11732    13    CONTINUE
11733       ENDIF
11734       I0 = 18*NLINES+1
11735       IF (I0.LE.NASAV) THEN
11736          IF (I0.EQ.1) THEN
11737             WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV)
11738          ELSE
11739             WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV)
11740          ENDIF
11741       ENDIF
11742       NLINES = DBLE(NBSAV)/18.0D0
11743       IF (NLINES.GT.0) THEN
11744          DO 14 I=1,NLINES
11745             IF (I.EQ.1) THEN
11746                WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18)
11747             ELSE
11748                WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I)
11749             ENDIF
11750    14    CONTINUE
11751       ENDIF
11752       I0 = 18*NLINES+1
11753       IF (I0.LE.NBSAV) THEN
11754          IF (I0.EQ.1) THEN
11755             WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV)
11756          ELSE
11757             WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV)
11758          ENDIF
11759       ENDIF
11760 *
11761 *  calculate Glauber-data for each energy and mass combination
11762 *
11763 *   loop over energy bins
11764       ELO = LOG10(ELO)
11765       EHI = LOG10(EHI)
11766       DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE)
11767       DO 1 IE=1,NEBIN+1
11768          E = ELO+DBLE(IE-1)*DEBIN
11769          E = 10**E
11770          IF (LCMS) THEN
11771             E   = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E)
11772             ECM = E
11773          ELSE
11774             PLAB = ZERO
11775             ECM  = ZERO
11776             E    = MAX(AAM(IJPROJ)+0.1D0,E)
11777             CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11778          ENDIF
11779 *
11780 *   loop over projectile and target masses
11781          DO 2 ITARG=1,NBSAV
11782             DO 3 IPROJ=1,NASAV
11783                CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ,
11784      &                                       XI,Q2I,ECM,1,1,-1)
11785     3       CONTINUE
11786     2    CONTINUE
11787 *
11788     1 CONTINUE
11789 *
11790 *--------------------------------------------------------------------------
11791 * Glauber-initialization for pion, kaon, ... projectiles
11792 *
11793       DO 6 IJ=1,MAXOFF
11794 *
11795 *  initialize phojet for this interaction
11796          ELAB = ZERO
11797          PLAB = ZERO
11798          IJPROJ = IJPINI(IJ)
11799          IP     = 1
11800          IPZ    = 1
11801 *
11802 *   temporary patch until fix has been implemented in phojet:
11803          IF (ECMINI.GT.ECMXPI) THEN
11804             CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1)
11805          ELSE
11806             CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11807          ENDIF
11808          CALL DT_PHOINI
11809 *
11810 *  calculate Glauber-data for each energy and mass combination
11811 *
11812 *   loop over energy bins
11813          DO 4 IE=1,NEBIN+1
11814             E = ELO+DBLE(IE-1)*DEBIN
11815             E = 10**E
11816             IF (LCMS) THEN
11817                E   = MAX(2.0D0*AAM(IJPROJ)+TINY14,E)
11818                ECM = E
11819             ELSE
11820                PLAB = ZERO
11821                ECM  = ZERO
11822                E    = MAX(AAM(IJPROJ)+TINY14,E)
11823                CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11824             ENDIF
11825 *
11826 *   loop over projectile and target masses
11827             DO 5 ITARG=1,NBSAV
11828                CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1)
11829     5       CONTINUE
11830 *
11831     4    CONTINUE
11832 *
11833     6 CONTINUE
11834
11835 *--------------------------------------------------------------------------
11836 * close output unit(s), etc.
11837 *
11838       CLOSE(LDAT)
11839
11840       RETURN
11841       END
11842
11843 *$ CREATE DT_GLBSET.FOR
11844 *COPY DT_GLBSET
11845 *
11846 *===glbset=============================================================*
11847 *
11848       SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE)
11849 ************************************************************************
11850 * Interpolation of pre-initialized profile functions                   *
11851 * This version dated 28.11.00 is written by S. Roesler.                *
11852 ************************************************************************
11853
11854       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11855       SAVE
11856
11857       PARAMETER ( LINP = 10 ,
11858      &            LOUT = 6 ,
11859      &            LDAT = 9 )
11860       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
11861
11862       LOGICAL LCMS,LREAD,LFRST1,LFRST2
11863
11864 * particle properties (BAMJET index convention)
11865       CHARACTER*8  ANAME
11866       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11867      &                IICH(210),IIBAR(210),K1(210),K2(210)
11868 * Glauber formalism: flags and parameters for statistics
11869       LOGICAL LPROD
11870       CHARACTER*8 CGLB
11871       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11872       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11873 * Glauber formalism: parameters
11874       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11875      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11876      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11877      &                NSITEB,NSTATB
11878 * Glauber formalism: cross sections
11879       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11880      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11881      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11882      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11883      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11884      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11885      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11886      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11887      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11888      &                BSLOPE,NEBINI,NQBINI
11889 * number of data sets other than protons and nuclei
11890 * at the moment = 2 (pions and kaons)
11891       PARAMETER (MAXOFF=2)
11892       DIMENSION IJPINI(5),IOFFST(25)
11893       DATA IJPINI / 13, 15,  0,  0,  0/
11894 * Glauber data-set to be used for hadron projectiles
11895 * (0=proton, 1=pion, 2=kaon)
11896       DATA (IOFFST(K),K=1,25) /
11897      &  0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11898      &  0, 0, 1, 2, 2/
11899 * Acceptance interval for target nucleus mass
11900       PARAMETER (KBACC = 6)
11901 * emulsion treatment
11902       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11903      &                NCOMPO,IEMUL
11904
11905       PARAMETER (MAXSET=5000,
11906      &           MAXBIN=100)
11907       DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB)
11908       DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6),
11909      &          BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB),
11910      &          IAIDX(10)
11911
11912       DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./
11913 *
11914 * read data from file
11915 *
11916       IF (MODE.EQ.0) THEN
11917
11918          IF (LREAD) RETURN
11919
11920          DO 1 I=1,MAXSET
11921             DO 2 J=1,6
11922                XSIG(I,J) = ZERO
11923                XERR(I,J) = ZERO
11924     2       CONTINUE
11925             DO 3 J=1,KSITEB
11926                BPROFL(I,J) = ZERO
11927     3       CONTINUE
11928     1    CONTINUE
11929          DO 4 I=1,MAXBIN
11930             IABIN(I) = 0
11931             IBBIN(I) = 0
11932     4    CONTINUE
11933          DO 5 I=1,KSITEB
11934             BPRO0(I) = ZERO
11935             BPRO1(I) = ZERO
11936             BPRO(I)  = ZERO
11937     5    CONTINUE
11938
11939          IDX = INDEX(CGLB,' ')
11940          K   = 12
11941          IF (IDX.GT.1) K = IDX-1
11942          OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
11943          WRITE(LOUT,1000) CGLB(1:K)//'.glb'
11944  1000    FORMAT(/,' GLBSET: impact parameter distributions read from ',
11945      &          'file ',A12,/)
11946 *
11947 *  read binning information
11948          READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI
11949 *  return lower energy threshold to Fluka-interface
11950          ELAB = ELO
11951          LCMS = ELO.LT.ZERO
11952          WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:'
11953          IF (LCMS) THEN
11954             WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN
11955          ELSE
11956             WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN
11957          ENDIF
11958  1001    FORMAT(2X,A5,'  E_lo = ',1P,E9.3,'  E_hi = ',1P,E9.3,4X,
11959      &          'No. of bins:',I5,/)
11960          ELO  = LOG10(ABS(ELO))
11961          EHI  = LOG10(ABS(EHI))
11962          DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN))
11963          WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)'
11964          READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18)
11965          IF (NABIN.LT.18) THEN
11966             WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN)
11967          ELSE
11968             WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18)
11969          ENDIF
11970          IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !'
11971          IF (NABIN.GT.18) THEN
11972             NLINES = DBLE(NABIN-18)/18.0D0
11973             IF (NLINES.GT.0) THEN
11974                DO 7 I=1,NLINES
11975                   I0 = 18*(I+1)-17
11976                   READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
11977                   WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
11978     7          CONTINUE
11979             ENDIF
11980             I0 = 18*(NLINES+1)+1
11981             IF (I0.LE.NABIN) THEN
11982                READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
11983                WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
11984             ENDIF
11985          ENDIF
11986          WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)'
11987          READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18)
11988          IF (NBBIN.LT.18) THEN
11989             WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN)
11990          ELSE
11991             WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18)
11992          ENDIF
11993          IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !'
11994          IF (NBBIN.GT.18) THEN
11995             NLINES = DBLE(NBBIN-18)/18.0D0
11996             IF (NLINES.GT.0) THEN
11997                DO 8 I=1,NLINES
11998                   I0 = 18*(I+1)-17
11999                   READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12000                   WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12001     8          CONTINUE
12002             ENDIF
12003             I0 = 18*(NLINES+1)+1
12004             IF (I0.LE.NBBIN) THEN
12005                READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12006                WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12007             ENDIF
12008          ENDIF
12009 *  number of data sets to follow in the Glauber data file
12010 *   this variable is used for checks of consistency of projectile
12011 *   and target mass configurations given in header of Glauber data
12012 *   file and the data-sets which follow in this file
12013          NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN
12014 *
12015 *  read profile function data
12016          NSET  = 0
12017          NAIDX = 0
12018          IPOLD = 0
12019    10    CONTINUE
12020          NSET = NSET+1
12021          IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! '
12022          READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM
12023  1002    FORMAT(5I10,E15.5)
12024          IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN
12025             NAIDX = NAIDX+1
12026             IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !'
12027             IAIDX(NAIDX) = IP
12028             IPOLD = IP
12029          ENDIF
12030          READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6)
12031          READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6)
12032          NLINES = INT(DBLE(ISITEB)/7.0D0)
12033          IF (NLINES.GT.0) THEN
12034             DO 11 I=1,NLINES
12035                READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I)
12036    11       CONTINUE
12037          ENDIF
12038          I0 = 7*NLINES+1
12039          IF (I0.LE.ISITEB)
12040      &      READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB)
12041          GOTO 10
12042   100    CONTINUE
12043          NSET = NSET-1
12044          IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !'
12045          WRITE(LOUT,'(/,1X,A)')
12046      &   ' projectiles other than protons and nuclei: (particle index)'
12047          IF (NAIDX.GT.0) THEN
12048             WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX)
12049          ELSE
12050             WRITE(LOUT,'(6X,A)') 'none'
12051          ENDIF
12052 *
12053          CLOSE(LDAT)
12054          WRITE(LOUT,*)
12055          LREAD = .TRUE.
12056
12057          IF (NCOMPO.EQ.0) THEN
12058             DO 12 J=1,NBBIN
12059                NCOMPO = NCOMPO+1
12060                IEMUMA(NCOMPO) = IBBIN(J)
12061                IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2
12062                EMUFRA(NCOMPO) = 1.0D0
12063    12       CONTINUE
12064             IEMUL = 1
12065          ENDIF
12066 *
12067 * calculate profile function for certain set of parameters
12068 *
12069       ELSE
12070
12071 c        write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE
12072 *
12073 * check for type of projectile and set index-offset to entry in
12074 * Glauber data array correspondingly
12075          IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !'
12076          IF (IOFFST(IDPROJ).EQ.-1) THEN
12077             STOP ' GLBSET: no data for this projectile !'
12078          ELSEIF (IOFFST(IDPROJ).GT.0) THEN
12079             IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN
12080          ELSE
12081             IDXOFF = 0
12082          ENDIF
12083 *
12084 * get energy bin and interpolation factor
12085          IF (LCMS) THEN
12086             E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB)
12087          ELSE
12088             E = ELAB
12089          ENDIF
12090          E = LOG10(E)
12091          IF (E.LT.ELO) THEN
12092             IF (LFRST1) THEN
12093                WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E
12094                LFRST1 = .FALSE.
12095             ENDIF
12096             E = ELO
12097          ENDIF
12098          IF (E.GT.EHI) THEN
12099             IF (LFRST2) THEN
12100                WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E
12101                LFRST2 = .FALSE.
12102             ENDIF
12103             E = EHI
12104          ENDIF
12105          IE0  = (E-ELO)/DEBIN+1
12106          IE1  = IE0+1
12107          FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN
12108 *
12109 * get target nucleus index
12110          KB = 0
12111          NBACC = KBACC
12112          DO 20 I=1,NBBIN
12113             NBDIFF = ABS(NB-IBBIN(I))
12114             IF (NB.EQ.IBBIN(I)) THEN
12115                KB = I
12116                GOTO 21
12117             ELSEIF (NBDIFF.LE.NBACC) THEN
12118                KB = I
12119                NBACC = NBDIFF
12120             ENDIF
12121    20    CONTINUE
12122          IF (KB.NE.0) GOTO 21
12123          WRITE(LOUT,*) ' GLBSET: data not found for target ',NB
12124          STOP
12125    21    CONTINUE
12126 *
12127 * get projectile nucleus bin and interpolation factor
12128          KA0 = 0
12129          KA1 = 0
12130          FACNA = 0
12131          IF (IDXOFF.GT.0) THEN
12132             KA0 = 1
12133             KA1 = 1
12134             KABIN = 1
12135          ELSE
12136             IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !'
12137             DO 22 I=1,NABIN
12138                IF (NA.EQ.IABIN(I)) THEN
12139                   KA0 = I
12140                   KA1 = I
12141                   GOTO 23
12142                ELSEIF (NA.LT.IABIN(I)) THEN
12143                   KA0 = I-1
12144                   KA1 = I
12145                   GOTO 23
12146                ENDIF
12147    22       CONTINUE
12148             WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA
12149             STOP
12150    23       CONTINUE
12151             IF (KA0.NE.KA1)
12152      &         FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0))
12153             KABIN = NABIN
12154          ENDIF
12155 *
12156 * interpolate profile functions for interactions ka0-kb and ka1-kb
12157 * for energy E separately
12158          IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12159          IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12160          IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12161          IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12162          DO 30 I=1,ISITEB
12163             BPRO0(I) = BPROFL(IDX0,I)
12164      &                 +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I))
12165             BPRO1(I) = BPROFL(IDY0,I)
12166      &                 +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I))
12167    30    CONTINUE
12168          RADB  = DT_RNCLUS(NB)
12169          BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1)
12170          BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1)
12171 *
12172 * interpolate cross sections for energy E and projectile mass
12173          DO 31 I=1,6
12174             XS0   = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I))
12175             XS1   = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I))
12176             XS(I) = XS0+FACNA*(XS1-XS0)
12177             XE0   = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I))
12178             XE1   = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I))
12179             XE(I) = XE0+FACNA*(XE1-XE0)
12180    31    CONTINUE
12181 *
12182 * interpolate between ka0 and ka1
12183          RADA = DT_RNCLUS(NA)
12184          BMX  = 2.0D0*(RADA+RADB)
12185          BSTP = BMX/DBLE(ISITEB-1)
12186          BPRO(1) = ZERO
12187          DO 32 I=1,ISITEB-1
12188             B = DBLE(I)*BSTP
12189 *
12190 *   calculate values of profile functions at B
12191             IDX0 = B/BSTP0+1
12192             IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12193             IDX1 = MIN(IDX0+1,ISITEB)
12194             FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0
12195             BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0))
12196             IDX0 = B/BSTP1+1
12197             IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12198             IDX1 = MIN(IDX0+1,ISITEB)
12199             FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1
12200             BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0))
12201 *
12202             BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0)
12203    32    CONTINUE
12204 *
12205 * fill common dtglam
12206          NSITEB   = ISITEB
12207          RASH(1)  = RADA
12208          RBSH(1)  = RADB
12209          BMAX(1)  = BMX
12210          BSTEP(1) = BSTP
12211          DO 33 I=1,KSITEB
12212             BSITE(0,1,1,I) = BPRO(I)
12213    33    CONTINUE
12214 *
12215 * fill common dtglxs
12216          XSTOT(1,1,1) = XS(1)
12217          XSELA(1,1,1) = XS(2)
12218          XSQEP(1,1,1) = XS(3)
12219          XSQET(1,1,1) = XS(4)
12220          XSQE2(1,1,1) = XS(5)
12221          XSPRO(1,1,1) = XS(6)
12222          XETOT(1,1,1) = XE(1)
12223          XEELA(1,1,1) = XE(2)
12224          XEQEP(1,1,1) = XE(3)
12225          XEQET(1,1,1) = XE(4)
12226          XEQE2(1,1,1) = XE(5)
12227          XEPRO(1,1,1) = XE(6)
12228
12229       ENDIF
12230
12231       RETURN
12232       END
12233
12234 *$ CREATE DT_XKSAMP.FOR
12235 *COPY DT_XKSAMP
12236 *
12237 *===xksamp=============================================================*
12238 *
12239       SUBROUTINE DT_XKSAMP(NN,ECM)
12240
12241 ************************************************************************
12242 * Sampling of parton x-values and chain system for one interaction.    *
12243 *                                   processed by S. Roesler, 9.8.95    *
12244 ************************************************************************
12245
12246       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12247       SAVE
12248       PARAMETER ( LINP = 10 ,
12249      &            LOUT = 6 ,
12250      &            LDAT = 9 )
12251       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
12252 CPH      SAVE
12253
12254       PARAMETER (
12255 * lower cuts for (valence-sea/sea-valence) chain masses
12256 *   antiquark-quark (u/d-sea quark)    (s-sea quark)
12257      &               AMIU = 0.5D0,      AMIS = 0.8D0,
12258 *   quark-diquark   (u/d-sea quark)    (s-sea quark)
12259      &               AMAU = 2.6D0,      AMAS = 2.6D0,
12260 * maximum lower valence-x threshold
12261      &           XVMAX  = 0.98D0,
12262 * fraction of sea-diquarks sampled out of sea-partons
12263 **test
12264 C    &           FRCDIQ = 0.9D0,
12265 **
12266 *
12267      &           SQMA   = 0.7D0,
12268 *
12269 * maximum number of trials to generate x's for the required number
12270 * of sea quark pairs for a given hadron
12271      &           NSEATY = 12
12272 C    &           NSEATY = 3
12273      &          )
12274
12275       LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO
12276
12277       PARAMETER ( MAXNCL = 260,
12278      &            MAXVQU = MAXNCL,
12279      &            MAXSQU = 20*MAXVQU,
12280      &            MAXINT = MAXVQU+MAXSQU)
12281 * event history
12282       PARAMETER (NMXHKK=200000)
12283       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
12284      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
12285      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
12286 * particle properties (BAMJET index convention)
12287       CHARACTER*8  ANAME
12288       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12289      &                IICH(210),IIBAR(210),K1(210),K2(210)
12290 * interface between Glauber formalism and DPM
12291       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
12292      &                INTER1(MAXINT),INTER2(MAXINT)
12293 * properties of interacting particles
12294       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12295 * threshold values for x-sampling (DTUNUC 1.x)
12296       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
12297      &                SSMIMQ,VVMTHR
12298 * x-values of partons (DTUNUC 1.x)
12299       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
12300      &                XTVQ(MAXVQU),XTVD(MAXVQU),
12301      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
12302      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
12303 * flavors of partons (DTUNUC 1.x)
12304       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
12305      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
12306      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
12307      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
12308      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
12309      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
12310      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
12311 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12312       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
12313      &                IXPV,IXPS,IXTV,IXTS,
12314      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
12315      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
12316      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
12317      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
12318      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
12319      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
12320      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
12321      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
12322 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12323       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
12324      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
12325 * auxiliary common for chain system storage (DTUNUC 1.x)
12326       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
12327 * flags for input different options
12328       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12329       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12330      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12331 * various options for treatment of partons (DTUNUC 1.x)
12332 * (chain recombination, Cronin,..)
12333       LOGICAL LCO2CR,LINTPT
12334       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
12335      &                LCO2CR,LINTPT
12336
12337       DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU),
12338      &          INTLO(MAXINT)
12339
12340 * (1) initializations
12341 *-----------------------------------------------------------------------
12342
12343 **test
12344       IF (ECM.LT.4.5D0) THEN
12345 C        FRCDIQ = 0.6D0
12346          FRCDIQ = 0.4D0
12347       ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN
12348 C        FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0
12349          FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0
12350       ELSE
12351 C        FRCDIQ = 0.9D0
12352          FRCDIQ = 0.7D0
12353       ENDIF
12354 **
12355       DO 30 I=1,MAXSQU
12356          ZUOSP(I) = .FALSE.
12357          ZUOST(I) = .FALSE.
12358          IF (I.LE.MAXVQU) THEN
12359             ZUOVP(I) = .FALSE.
12360             ZUOVT(I) = .FALSE.
12361          ENDIF
12362    30 CONTINUE
12363
12364 * lower thresholds for x-selection
12365 *  sea-quarks       (default: CSEA=0.2)
12366       IF (ECM.LT.10.0D0) THEN
12367 **!!test
12368          XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM
12369 C        XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0
12370          NSEA  = NSEATY
12371 C        XSTHR = ONE/ECM**2
12372       ELSE
12373 **sr 30.3.98
12374 C        XSTHR = CSEA/ECM
12375          XSTHR = CSEA/ECM**2
12376 C        XSTHR = ONE/ECM**2
12377 **
12378          IF ((IP.GE.150).AND.(IT.GE.150))
12379      &      XSTHR = 2.5D0/(ECM*SQRT(ECM))
12380          NSEA  = NSEATY
12381       ENDIF
12382 *                   (default: SSMIMA=0.14) used for sea-diquarks (?)
12383       XSSTHR = SSMIMA/ECM
12384       BSQMA  = SQMA/ECM
12385 *  valence-quarks   (default: CVQ=1.0)
12386       XVTHR  = CVQ/ECM
12387 *  valence-diquarks (default: CDQ=2.0)
12388       XDTHR  = CDQ/ECM
12389
12390 * maximum-x for sea-quarks
12391       XVCUT  = XVTHR+XDTHR
12392       IF (XVCUT.GT.XVMAX) THEN
12393          XVCUT = XVMAX
12394          XVTHR = XVCUT/3.0D0
12395          XDTHR = XVCUT-XVTHR
12396       ENDIF
12397       XXSEAM = ONE-XVCUT
12398 **sr 18.4. test: DPMJET
12399 C     XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1))
12400 C    &            - XDTHR*(1.D0+0.3D0*DT_RNDM(V2))
12401 C    &             -0.01*(1.D0+1.5D0*DT_RNDM(V3))
12402 **
12403 * maximum number of sea-pairs allowed kinematically
12404 C     NSMAX  = INT(OHALF*XXSEAM/XSTHR)
12405       RNSMAX = OHALF*XXSEAM/XSTHR
12406       IF (RNSMAX.GT.10000.0D0) THEN
12407          NSMAX = 10000
12408       ELSE
12409          NSMAX = INT(OHALF*XXSEAM/XSTHR)
12410       ENDIF
12411 * check kinematical limit for valence-x thresholds
12412 * (should be obsolete now)
12413       IF (XVCUT.GT.XVMAX) THEN
12414          WRITE(LOUT,1000) XVCUT,ECM
12415  1000    FORMAT(' XKSAMP:    kin. limit for valence-x',
12416      &          '  thresholds not allowed (',2E9.3,')')
12417 C        XVTHR = XVMAX-XDTHR
12418 C        IF (XVTHR.LT.ZERO) STOP
12419          STOP
12420       ENDIF
12421
12422 * set eta for valence-x sampling (BETREJ)
12423 *   (UNON per default, UNOM used for projectile mesons only)
12424       IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN
12425          UNOPRV = UNOM
12426       ELSE
12427          UNOPRV = UNON
12428       ENDIF
12429
12430 * (2) select parton x-values of interacting projectile nucleons
12431 *-----------------------------------------------------------------------
12432
12433       IXPV = 0
12434       IXPS = 0
12435
12436       DO 100 IPP=1,IP
12437 *   get interacting projectile nucleon as sampled by Glauber
12438          IF (JSSH(IPP).NE.0) THEN
12439             IXSTMP = IXPS
12440             IXVTMP = IXPV
12441    99       CONTINUE
12442             IXPS   = IXSTMP
12443             IXPV   = IXVTMP
12444 *     JIPP is the actual number of sea-pairs sampled for this nucleon
12445             JIPP   = MIN(JSSH(IPP)-1,NSMAX)
12446    41       CONTINUE
12447             XXSEA  = ZERO
12448             IF (JIPP.GT.0) THEN
12449                XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR
12450 *???
12451                IF (XSTHR.GE.XSMAX) THEN
12452                   JIPP = JIPP-1
12453                   GOTO 41
12454                ENDIF
12455
12456 *>>>get x-values of sea-quark pairs
12457                NSCOUN = 0
12458                PLW = 0.5D0
12459    40          CONTINUE
12460 *     accumulator for sea x-values
12461                XXSEA  = ZERO
12462                NSCOUN = NSCOUN+1
12463                IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12464                IF (NSCOUN.GT.NSEA) THEN
12465 *     decrease the number of interactions after NSEA trials
12466                   JIPP   = JIPP-1
12467                   NSCOUN = 0
12468                ENDIF
12469                DO 70 ISQ=1,JIPP
12470 *     sea-quarks
12471                   IF (IPSQ(IXPS+1).LE.2) THEN
12472 **sr 8.4.98 (1/sqrt(x))
12473 C                    XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12474 C                    XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12475                      XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12476 **
12477                   ELSE
12478                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
12479                         XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12480                      ELSE
12481 **sr 8.4.98 (1/sqrt(x))
12482 C                       XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12483 C                       XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12484                         XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12485 **
12486                      ENDIF
12487                   ENDIF
12488 *     sea-antiquarks
12489                   IF (IPSAQ(IXPS+1).GE.-2) THEN
12490 **sr 8.4.98 (1/sqrt(x))
12491 C                    XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12492 C                    XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12493                      XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12494 **
12495                   ELSE
12496                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
12497                         XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12498                      ELSE
12499 **sr 8.4.98 (1/sqrt(x))
12500 C                       XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12501 C                       XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12502                         XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12503 **
12504                      ENDIF
12505                   ENDIF
12506                   XXSEA = XXSEA+XPSQI+XPSAQI
12507 *     check for maximum allowed sea x-value
12508                   IF (XXSEA.GE.XXSEAM) THEN
12509                      IXPS = IXPS-ISQ+1
12510                      GOTO 40
12511                   ENDIF
12512 *     accept this sea-quark pair
12513                   IXPS         = IXPS+1
12514                   XPSQ(IXPS)   = XPSQI
12515                   XPSAQ(IXPS)  = XPSAQI
12516                   IFROSP(IXPS) = IPP
12517                   ZUOSP(IXPS)  = .TRUE.
12518    70          CONTINUE
12519             ENDIF
12520
12521 *>>>get x-values of valence partons
12522 *     valence quark
12523             IF (XVTHR.GT.0.05D0) THEN
12524                XVHI  = ONE-XXSEA-XDTHR
12525                XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI)
12526             ELSE
12527    90          CONTINUE
12528                XPVQI = DT_DBETAR(OHALF,UNOPRV)
12529                IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR))
12530      &                                                     GOTO 90
12531             ENDIF
12532 *     valence diquark
12533             XPVDI = ONE-XPVQI-XXSEA
12534 *       reject according to x**1.5
12535             XDTMP = XPVDI**1.5D0
12536             IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99
12537 *     accept these valence partons
12538             IXPV         = IXPV+1
12539             XPVQ(IXPV)   = XPVQI
12540             XPVD(IXPV)   = XPVDI
12541             IFROVP(IXPV) = IPP
12542             ITOVP(IPP)   = IXPV
12543             ZUOVP(IXPV)  = .TRUE.
12544
12545          ENDIF
12546   100 CONTINUE
12547
12548 * (3) select parton x-values of interacting target nucleons
12549 *-----------------------------------------------------------------------
12550
12551       IXTV = 0
12552       IXTS = 0
12553
12554       DO 170 ITT=1,IT
12555 *   get interacting target nucleon as sampled by Glauber
12556          IF (JTSH(ITT).NE.0) THEN
12557             IXSTMP = IXTS
12558             IXVTMP = IXTV
12559   169       CONTINUE
12560             IXTS   = IXSTMP
12561             IXTV   = IXVTMP
12562 *     JITT is the actual number of sea-pairs sampled for this nucleon
12563             JITT   = MIN(JTSH(ITT)-1,NSMAX)
12564   111       CONTINUE
12565             XXSEA  = ZERO
12566             IF (JITT.GT.0) THEN
12567                XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR
12568 *???
12569                IF (XSTHR.GE.XSMAX) THEN
12570                   JITT = JITT-1
12571                   GOTO 111
12572                ENDIF
12573
12574 *>>>get x-values of sea-quark pairs
12575                NSCOUN = 0
12576                PLW = 0.5D0
12577   110          CONTINUE
12578 *     accumulator for sea x-values
12579                XXSEA  = ZERO
12580                NSCOUN = NSCOUN+1
12581                IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12582                IF (NSCOUN.GT.NSEA)THEN
12583 *     decrease the number of interactions after NSEA trials
12584                   JITT   = JITT-1
12585                   NSCOUN = 0
12586                ENDIF
12587                DO 140 ISQ=1,JITT
12588 *     sea-quarks
12589                   IF (ITSQ(IXTS+1).LE.2) THEN
12590 **sr 8.4.98 (1/sqrt(x))
12591 C                    XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12592 C                    XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12593                      XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12594 **
12595                   ELSE
12596                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
12597                         XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12598                      ELSE
12599 **sr 8.4.98 (1/sqrt(x))
12600 C                       XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12601 C                       XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12602                         XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12603 **
12604                      ENDIF
12605                   ENDIF
12606 *     sea-antiquarks
12607                   IF (ITSAQ(IXTS+1).GE.-2) THEN
12608 **sr 8.4.98 (1/sqrt(x))
12609 C                    XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12610 C                    XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12611                      XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12612 **
12613                   ELSE
12614                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
12615                         XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12616                      ELSE
12617 **sr 8.4.98 (1/sqrt(x))
12618 C                       XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12619 C                       XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12620                         XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12621 **
12622                      ENDIF
12623                   ENDIF
12624                   XXSEA = XXSEA+XTSQI+XTSAQI
12625 *     check for maximum allowed sea x-value
12626                   IF (XXSEA.GE.XXSEAM) THEN
12627                      IXTS = IXTS-ISQ+1
12628                      GOTO 110
12629                   ENDIF
12630 *     accept this sea-quark pair
12631                   IXTS         = IXTS+1
12632                   XTSQ(IXTS)   = XTSQI
12633                   XTSAQ(IXTS)  = XTSAQI
12634                   IFROST(IXTS) = ITT
12635                   ZUOST(IXTS)  = .TRUE.
12636   140          CONTINUE
12637             ENDIF
12638
12639 *>>>get x-values of valence partons
12640 *     valence quark
12641             IF (XVTHR.GT.0.05D0) THEN
12642                XVHI  = ONE-XXSEA-XDTHR
12643                XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI)
12644             ELSE
12645   160          CONTINUE
12646                XTVQI = DT_DBETAR(OHALF,UNON)
12647                IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR))
12648      &                                                    GOTO 160
12649             ENDIF
12650 *     valence diquark
12651             XTVDI = ONE-XTVQI-XXSEA
12652 *       reject according to x**1.5
12653             XDTMP = XTVDI**1.5D0
12654             IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169
12655 *     accept these valence partons
12656             IXTV         = IXTV+1
12657             XTVQ(IXTV)   = XTVQI
12658             XTVD(IXTV)   = XTVDI
12659             IFROVT(IXTV) = ITT
12660             ITOVT(ITT)   = IXTV
12661             ZUOVT(IXTV)  = .TRUE.
12662
12663          ENDIF
12664   170 CONTINUE
12665
12666 * (4) get valence-valence chains
12667 *-----------------------------------------------------------------------
12668
12669       NVV = 0
12670       DO 240 I=1,NN
12671          INTLO(I) = .TRUE.
12672          IPVAL    = ITOVP(INTER1(I))
12673          ITVAL    = ITOVT(INTER2(I))
12674          IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN
12675             INTLO(I)      = .FALSE.
12676             ZUOVP(IPVAL)  = .FALSE.
12677             ZUOVT(ITVAL)  = .FALSE.
12678             NVV           = NVV+1
12679             ISKPCH(8,NVV) = 0
12680             INTVV1(NVV)   = IPVAL
12681             INTVV2(NVV)   = ITVAL
12682          ENDIF
12683   240 CONTINUE
12684
12685 * (5) get sea-valence chains
12686 *-----------------------------------------------------------------------
12687
12688       NSV = 0
12689       NDV = 0
12690       PLW = 0.5D0
12691       DO 270 I=1,NN
12692          IF (INTLO(I)) THEN
12693             IPVAL = ITOVP(INTER1(I))
12694             ITVAL = ITOVT(INTER2(I))
12695             DO 250 J=1,IXPS
12696                IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND.
12697      &                                ZUOVT(ITVAL)) THEN
12698                   ZUOSP(J)     = .FALSE.
12699                   ZUOVT(ITVAL) = .FALSE.
12700                   INTLO(I)     = .FALSE.
12701                   IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN
12702 *   sample sea-diquark pair
12703                      CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1)
12704                      IF (IREJ1.EQ.0) GOTO 260
12705                   ENDIF
12706                   NSV           = NSV+1
12707                   ISKPCH(4,NSV) = 0
12708                   INTSV1(NSV)   = J
12709                   INTSV2(NSV)   = ITVAL
12710
12711 *>>>correct chain kinematics according to minimum chain masses
12712 *     the actual chain masses
12713                   AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2
12714                   AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2
12715 *     get lower mass cuts
12716                   IF (IPSQ(J).EQ.3) THEN
12717 *       q being s-quark
12718                      AMCHK1 = AMAS
12719                      AMCHK2 = AMIS
12720                   ELSE
12721 *       q being u/d-quark
12722                      AMCHK1 = AMAU
12723                      AMCHK2 = AMIU
12724                   ENDIF
12725 *       q-qq chain
12726 *         chain mass above minimum - resampling of sea-q x-value
12727                   IF (AMSVQ1.GT.AMCHK1) THEN
12728                      XPSQTH      = AMCHK1/(XTVD(ITVAL)*ECM**2)
12729 **sr 8.4.98 (1/sqrt(x))
12730 C                    XPSQXX      = DT_SAMPEX(XPSQTH,XPSQ(J))
12731 C                    XPSQXX      = DT_SAMSQX(XPSQTH,XPSQ(J))
12732                      XPSQXX      = DT_SAMPLW(XPSQTH,XPSQ(J),PLW)
12733 **
12734                      XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX
12735                      XPSQ(J)     = XPSQXX
12736 *         chain mass below minimum - reset sea-q x-value and correct
12737 *                                    diquark-x of the same nucleon
12738                   ELSEIF (AMSVQ1.LT.AMCHK1) THEN
12739                      XPSQW       = AMCHK1/(XTVD(ITVAL)*ECM**2)
12740                      DXPSQ       = XPSQW-XPSQ(J)
12741                      IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12742                         XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12743                         XPSQ(J)     = XPSQW
12744                      ENDIF
12745                   ENDIF
12746 *       aq-q chain
12747 *         chain mass below minimum - reset sea-aq x-value and correct
12748 *                                    diquark-x of the same nucleon
12749                   IF (AMSVQ2.LT.AMCHK2) THEN
12750                      XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2)
12751                      DXPSQ = XPSQW-XPSAQ(J)
12752                      IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12753                         XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12754                         XPSAQ(J)    = XPSQW
12755                      ENDIF
12756                   ENDIF
12757 *>>>end of chain mass correction
12758
12759                   GOTO 260
12760                ENDIF
12761   250       CONTINUE
12762          ENDIF
12763   260    CONTINUE
12764   270 CONTINUE
12765
12766 * (6) get valence-sea chains
12767 *-----------------------------------------------------------------------
12768
12769       NVS = 0
12770       NVD = 0
12771       DO 300 I=1,NN
12772          IF (INTLO(I)) THEN
12773             IPVAL = ITOVP(INTER1(I))
12774             ITVAL = ITOVT(INTER2(I))
12775             DO 280 J=1,IXTS
12776                IF (ZUOVP(IPVAL).AND.ZUOST(J).AND.
12777      &                  (IFROST(J).EQ.INTER2(I))) THEN
12778                   ZUOST(J)     = .FALSE.
12779                   ZUOVP(IPVAL) = .FALSE.
12780                   INTLO(I)     = .FALSE.
12781                   IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
12782 *   sample sea-diquark pair
12783                      CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1)
12784                      IF (IREJ1.EQ.0) GOTO 290
12785                   ENDIF
12786                   NVS           = NVS + 1
12787                   ISKPCH(6,NVS) = 0
12788                   INTVS1(NVS)   = IPVAL
12789                   INTVS2(NVS)   = J
12790
12791 *>>>correct chain kinematics according to minimum chain masses
12792 *     the actual chain masses
12793                   AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2
12794                   AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2
12795 *     get lower mass cuts
12796                   IF (ITSQ(J).EQ.3) THEN
12797 *       q being s-quark
12798                      AMCHK1 = AMIS
12799                      AMCHK2 = AMAS
12800                   ELSE
12801 *       q being u/d-quark
12802                      AMCHK1 = AMIU
12803                      AMCHK2 = AMAU
12804                   ENDIF
12805 *       q-aq chain
12806 *         chain mass below minimum - reset sea-aq x-value and correct
12807 *                                    diquark-x of the same nucleon
12808                   IF (AMVSQ1.LT.AMCHK1) THEN
12809                      XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2)
12810                      DXTSQ = XTSQW-XTSAQ(J)
12811                      IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12812                         XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12813                         XTSAQ(J)    = XTSQW
12814                      ENDIF
12815                   ENDIF
12816 *       qq-q chain
12817 *         chain mass above minimum - resampling of sea-q x-value
12818                   IF (AMVSQ2.GT.AMCHK2) THEN
12819                      XTSQTH      = AMCHK2/(XPVD(IPVAL)*ECM**2)
12820 **sr 8.4.98 (1/sqrt(x))
12821 C                    XTSQXX      = DT_SAMPEX(XTSQTH,XTSQ(J))
12822 C                    XTSQXX      = DT_SAMSQX(XTSQTH,XTSQ(J))
12823                      XTSQXX      = DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
12824 **
12825                      XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX
12826                      XTSQ(J)     = XTSQXX
12827 *         chain mass below minimum - reset sea-q x-value and correct
12828 *                                    diquark-x of the same nucleon
12829                   ELSEIF (AMVSQ2.LT.AMCHK2) THEN
12830                      XTSQW       = AMCHK2/(XPVD(IPVAL)*ECM**2)
12831                      DXTSQ       = XTSQW-XTSQ(J)
12832                      IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12833                         XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12834                         XTSQ(J)     = XTSQW
12835                      ENDIF
12836                   ENDIF
12837 *>>>end of chain mass correction
12838
12839                   GOTO 290
12840                ENDIF
12841   280       CONTINUE
12842          ENDIF
12843   290    CONTINUE
12844   300 CONTINUE
12845
12846 * (7) get sea-sea chains
12847 *-----------------------------------------------------------------------
12848
12849       NSS = 0
12850       NDS = 0
12851       NSD = 0
12852       DO 420 I=1,NN
12853          IF (INTLO(I)) THEN
12854             IPVAL = ITOVP(INTER1(I))
12855             ITVAL = ITOVT(INTER2(I))
12856 *   loop over target partons not yet matched
12857             DO 400 J=1,IXTS
12858                IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN
12859 *   loop over projectile partons not yet matched
12860                   DO 390 JJ=1,IXPS
12861                      IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN
12862                         ZUOSP(JJ)     = .FALSE.
12863                         ZUOST(J)      = .FALSE.
12864                         INTLO(I)      = .FALSE.
12865                         NSS           = NSS+1
12866                         ISKPCH(1,NSS) = 0
12867                         INTSS1(NSS)   = JJ
12868                         INTSS2(NSS)   = J
12869
12870 *---->chain recombination option
12871                         VALFRA        = DBLE(NVV/(NVV+IXPS+IXTS))
12872                         IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA))
12873      &                                                             THEN
12874 *       sea-sea chains may recombine with valence-valence chains
12875 *       only if they have the same projectile or target nucleon
12876                            DO 4201 IVV=1,NVV
12877                               IF (ISKPCH(8,IVV).NE.99) THEN
12878                                  IXVPR = INTVV1(IVV)
12879                                  IXVTA = INTVV2(IVV)
12880                                  IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR.
12881      &                               (INTER2(I).EQ.IFROVT(IXVTA))) THEN
12882 *         recombination possible, drop old v-v and s-s chains
12883                                     ISKPCH(1,NSS) = 99
12884                                     ISKPCH(8,IVV) = 99
12885
12886 *         (a) assign new s-v chains
12887 *         ~~~~~~~~~~~~~~~~~~~~~~~~~
12888                                     IF (LSEADI.AND.
12889      &                                  (DT_RNDM(VALFRA).GT.FRCDIQ))
12890      &                                                             THEN
12891 *           sample sea-diquark pair
12892                                        CALL DT_SAMSDQ(ECM,IXVTA,JJ,2,
12893      &                                                      IREJ1)
12894                                        IF (IREJ1.EQ.0) GOTO 4202
12895                                     ENDIF
12896                                     NSV           = NSV+1
12897                                     ISKPCH(4,NSV) = 0
12898                                     INTSV1(NSV)   = JJ
12899                                     INTSV2(NSV)   = IXVTA
12900 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
12901 *           the actual chain masses
12902                                     AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA)
12903      &                                                     *ECM**2
12904                                     AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA)
12905      &                                                     *ECM**2
12906 *           get lower mass cuts
12907                                     IF (IPSQ(JJ).EQ.3) THEN
12908 *             q being s-quark
12909                                        AMCHK1 = AMAS
12910                                        AMCHK2 = AMIS
12911                                     ELSE
12912 *             q being u/d-quark
12913                                        AMCHK1 = AMAU
12914                                        AMCHK2 = AMIU
12915                                     ENDIF
12916 *           q-qq chain
12917 *             chain mass above minimum - resampling of sea-q x-value
12918                                     IF (AMSVQ1.GT.AMCHK1) THEN
12919                                        XPSQTH      =
12920      &                                    AMCHK1/(XTVD(IXVTA)*ECM**2)
12921 **sr 8.4.98 (1/sqrt(x))
12922                                        XPSQXX      =
12923      &                                    DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW)
12924 C    &                                    DT_SAMSQX(XPSQTH,XPSQ(JJ))
12925 C    &                                    DT_SAMPEX(XPSQTH,XPSQ(JJ))
12926 **
12927                                        XPVD(IPVAL) =
12928      &                                    XPVD(IPVAL)+XPSQ(JJ)-XPSQXX
12929                                        XPSQ(JJ)    = XPSQXX
12930 *             chain mass below minimum - reset sea-q x-value and correct
12931 *                                        diquark-x of the same nucleon
12932                                     ELSEIF (AMSVQ1.LT.AMCHK1) THEN
12933                                        XPSQW =
12934      &                                    AMCHK1/(XTVD(IXVTA)*ECM**2)
12935                                        DXPSQ = XPSQW-XPSQ(JJ)
12936                                        IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
12937      &                                                            THEN
12938                                           XPVD(IPVAL) =
12939      &                                       XPVD(IPVAL)-DXPSQ
12940                                           XPSQ(JJ)    = XPSQW
12941                                        ENDIF
12942                                     ENDIF
12943 *           aq-q chain
12944 *             chain mass below minimum - reset sea-aq x-value and correct
12945 *                                        diquark-x of the same nucleon
12946                                     IF (AMSVQ2.LT.AMCHK2) THEN
12947                                        XPSQW =
12948      &                                    AMCHK2/(XTVQ(IXVTA)*ECM**2)
12949                                        DXPSQ = XPSQW-XPSAQ(JJ)
12950                                        IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
12951      &                                                            THEN
12952                                           XPVD(IPVAL) =
12953      &                                       XPVD(IPVAL)-DXPSQ
12954                                           XPSAQ(JJ)   = XPSQW
12955                                        ENDIF
12956                                     ENDIF
12957 *>>>>>>>>>>>end of chain mass correction
12958  4202                               CONTINUE
12959
12960 *         (b) assign new v-s chains
12961 *         ~~~~~~~~~~~~~~~~~~~~~~~~~
12962                                     IF (LSEADI.AND.(
12963      &                                  DT_RNDM(AMSVQ2).GT.FRCDIQ))
12964      &                                                             THEN
12965 *           sample sea-diquark pair
12966                                        CALL DT_SAMSDQ(ECM,IXVPR,J,1,
12967      &                                                      IREJ1)
12968                                        IF (IREJ1.EQ.0) GOTO 4203
12969                                     ENDIF
12970                                     NVS           = NVS+1
12971                                     ISKPCH(6,NVS) = 0
12972                                     INTVS1(NVS)   = IXVPR
12973                                     INTVS2(NVS)   = J
12974 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
12975 *           the actual chain masses
12976                                     AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2
12977                                     AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2
12978 *           get lower mass cuts
12979                                     IF (ITSQ(J).EQ.3) THEN
12980 *             q being s-quark
12981                                        AMCHK1 = AMIS
12982                                        AMCHK2 = AMAS
12983                                     ELSE
12984 *             q being u/d-quark
12985                                        AMCHK1 = AMIU
12986                                        AMCHK2 = AMAU
12987                                     ENDIF
12988 *           q-aq chain
12989 *             chain mass below minimum - reset sea-aq x-value and correct
12990 *                                        diquark-x of the same nucleon
12991                                     IF (AMVSQ1.LT.AMCHK1) THEN
12992                                        XTSQW =
12993      &                                    AMCHK1/(XPVQ(IXVPR)*ECM**2)
12994                                        DXTSQ = XTSQW-XTSAQ(J)
12995                                        IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
12996      &                                                            THEN
12997                                           XTVD(ITVAL) =
12998      &                                       XTVD(ITVAL)-DXTSQ
12999                                           XTSAQ(J)    = XTSQW
13000                                        ENDIF
13001                                     ENDIF
13002                                     IF (AMVSQ2.GT.AMCHK2) THEN
13003                                        XTSQTH      =
13004      &                                    AMCHK2/(XPVD(IXVPR)*ECM**2)
13005 **sr 8.4.98 (1/sqrt(x))
13006                                        XTSQXX      =
13007      &                                    DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13008 C    &                                    DT_SAMSQX(XTSQTH,XTSQ(J))
13009 C    &                                    DT_SAMPEX(XTSQTH,XTSQ(J))
13010 **
13011                                        XTVD(ITVAL) =
13012      &                                    XTVD(ITVAL)+XTSQ(J)-XTSQXX
13013                                        XTSQ(J)     = XTSQXX
13014                                     ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13015                                        XTSQW =
13016      &                                    AMCHK2/(XPVD(IXVPR)*ECM**2)
13017                                        DXTSQ = XTSQW-XTSQ(J)
13018                                        IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13019      &                                                            THEN
13020                                           XTVD(ITVAL) =
13021      &                                       XTVD(ITVAL)-DXTSQ
13022                                           XTSQ(J)     = XTSQW
13023                                        ENDIF
13024                                     ENDIF
13025 *>>>>>>>>>end of chain mass correction
13026  4203                               CONTINUE
13027 *       jump out of s-s chain loop
13028                                     GOTO 420
13029                                  ENDIF
13030                               ENDIF
13031  4201                      CONTINUE
13032                         ENDIF
13033 *---->end of chain recombination option
13034
13035 *     sample sea-diquark pair (projectile)
13036                         IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN
13037                            CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1)
13038                            IF (IREJ1.EQ.0) THEN
13039                               ISKPCH(1,NSS) = 99
13040                               GOTO 410
13041                            ENDIF
13042                         ENDIF
13043 *     sample sea-diquark pair (target)
13044                         IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13045                            CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1)
13046                            IF (IREJ1.EQ.0) THEN
13047                               ISKPCH(1,NSS) = 99
13048                               GOTO 410
13049                            ENDIF
13050                         ENDIF
13051 *>>>>>correct chain kinematics according to minimum chain masses
13052 *     the actual chain masses
13053                         SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2
13054                         SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2
13055 *     check for lower mass cuts
13056                         IF ((SSMA1Q.LT.SSMIMQ).OR.
13057      &                      (SSMA2Q.LT.SSMIMQ)) THEN
13058                            IPVAL = ITOVP(INTER1(I))
13059                            ITVAL = ITOVT(INTER2(I))
13060                            IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND.
13061      &                         (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN
13062 *       maximum allowed x values for sea quarks
13063                               XSPMAX = ONE-XPVQ(IPVAL)-XDTHR-
13064      &                                           1.2D0*XSSTHR
13065                               XSTMAX = ONE-XTVQ(ITVAL)-XDTHR-
13066      &                                           1.2D0*XSSTHR
13067 *       resampling of x values not possible - skip sea-sea chains
13068                               IF ((XSPMAX.LE.XSSTHR+0.05D0).OR.
13069      &                            (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380
13070 *       resampling of x for projectile sea quark pair
13071                               ICOUS = 0
13072   310                         CONTINUE
13073                               ICOUS = ICOUS+1
13074                               IF (XSSTHR.GT.0.05D0) THEN
13075                                  XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13076      &                                                         XSPMAX)
13077                                  XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13078      &                                                         XSPMAX)
13079                               ELSE
13080   320                            CONTINUE
13081                                  XPSQI = DT_DBETAR(XSEACU,UNOSEA)
13082                                  IF ((XPSQI.LT.XSSTHR).OR.
13083      &                               (XPSQI.GT.XSPMAX))  GOTO 320
13084   330                            CONTINUE
13085                                  XPSAQI = DT_DBETAR(XSEACU,UNOSEA)
13086                                  IF ((XPSAQI.LT.XSSTHR).OR.
13087      &                               (XPSAQI.GT.XSPMAX)) GOTO 330
13088                               ENDIF
13089 *       final test of remaining x for projectile diquark
13090                               XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI
13091      &                                            +XPSQ(JJ)+XPSAQ(JJ)
13092                               IF (XPVDCO.LE.XDTHR) THEN
13093 *!!!
13094 C                                IF (ICOUS.LT.5) GOTO 310
13095                                  IF (ICOUS.LT.0.5D0) GOTO 310
13096                                  GOTO 380
13097                               ENDIF
13098 *       resampling of x for target sea quark pair
13099                               ICOUS = 0
13100   350                         CONTINUE
13101                               ICOUS = ICOUS+1
13102                               IF (XSSTHR.GT.0.05D0) THEN
13103                                  XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13104      &                                                         XSTMAX)
13105                                  XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13106      &                                                         XSTMAX)
13107                               ELSE
13108   360                            CONTINUE
13109                                  XTSQI = DT_DBETAR(XSEACU,UNOSEA)
13110                                  IF ((XTSQI.LT.XSSTHR).OR.
13111      &                               (XTSQI.GT.XSTMAX))  GOTO 360
13112   370                            CONTINUE
13113                                  XTSAQI = DT_DBETAR(XSEACU,UNOSEA)
13114                                  IF ((XTSAQI.LT.XSSTHR).OR.
13115      &                               (XTSAQI.GT.XSTMAX)) GOTO 370
13116                               ENDIF
13117 *       final test of remaining x for target diquark
13118                               XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI
13119      &                                            +XTSQ(J)+XTSAQ(J)
13120                               IF (XTVDCO.LT.XDTHR) THEN
13121                                  IF (ICOUS.LT.5) GOTO 350
13122                                  GOTO 380
13123                               ENDIF
13124                               XPVD(IPVAL) = XPVDCO
13125                               XTVD(ITVAL) = XTVDCO
13126                               XPSQ(JJ)    = XPSQI
13127                               XPSAQ(JJ)   = XPSAQI
13128                               XTSQ(J)     = XTSQI
13129                               XTSAQ(J)    = XTSAQI
13130 *>>>>>end of chain mass correction
13131                               GOTO 410
13132                            ENDIF
13133 *     come here to discard s-s interaction
13134 *     resampling of x values not allowed or unsuccessful
13135   380                      CONTINUE
13136                            INTLO(I)  = .FALSE.
13137                            ZUOST(J)  = .TRUE.
13138                            ZUOSP(JJ) = .TRUE.
13139                            NSS       = NSS-1
13140                         ENDIF
13141 *   consider next s-s interaction
13142                         GOTO 410
13143                      ENDIF
13144   390             CONTINUE
13145                ENDIF
13146   400       CONTINUE
13147          ENDIF
13148   410    CONTINUE
13149   420 CONTINUE
13150
13151 * correct x-values of valence quarks for non-matching sea quarks
13152       DO 430 I=1,IXPS
13153          IF (ZUOSP(I)) THEN
13154             IPVAL       = ITOVP(IFROSP(I))
13155             XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I)
13156             XPSQ(I)     = ZERO
13157             XPSAQ(I)    = ZERO
13158             ZUOSP(I)    = .FALSE.
13159          ENDIF
13160   430 CONTINUE
13161       DO 440 I=1,IXTS
13162          IF (ZUOST(I)) THEN
13163             ITVAL       = ITOVT(IFROST(I))
13164             XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I)
13165             XTSQ(I)     = ZERO
13166             XTSAQ(I)    = ZERO
13167             ZUOST(I)    = .FALSE.
13168          ENDIF
13169   440 CONTINUE
13170       DO 450 I=1,IXPV
13171          IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13
13172   450 CONTINUE
13173       DO 460 I=1,IXTV
13174          IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14
13175   460 CONTINUE
13176
13177       RETURN
13178       END
13179
13180 *$ CREATE DT_SAMSDQ.FOR
13181 *COPY DT_SAMSDQ
13182 *
13183 *===samsdq=============================================================*
13184 *
13185       SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ)
13186
13187 ************************************************************************
13188 * SAMpling of Sea-DiQuarks                                             *
13189 *              ECM        cm-energy of the nucleon-nucleon system      *
13190 *              IDX1,2     indices of x-values of the participating     *
13191 *                         partons (IDX2 is always the sea-q-pair to be *
13192 *                         changed to sea-qq-pair)                      *
13193 *              MODE       = 1  valence-q - sea-diq                     *
13194 *                         = 2  sea-diq   - valence-q                   *
13195 *                         = 3  sea-q     - sea-diq                     *
13196 *                         = 4  sea-diq   - sea-q                       *
13197 * Based on DIQVS, DIQSV, DIQSSD, DIQDSS.                               *
13198 * This version dated 17.10.95 is written by S. Roesler                 *
13199 ************************************************************************
13200
13201       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13202       SAVE
13203
13204       PARAMETER (ZERO=0.0D0)
13205
13206 * threshold values for x-sampling (DTUNUC 1.x)
13207       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
13208      &                SSMIMQ,VVMTHR
13209 * various options for treatment of partons (DTUNUC 1.x)
13210 * (chain recombination, Cronin,..)
13211       LOGICAL LCO2CR,LINTPT
13212       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
13213      &                LCO2CR,LINTPT
13214       PARAMETER ( MAXNCL = 260,
13215      &            MAXVQU = MAXNCL,
13216      &            MAXSQU = 20*MAXVQU,
13217      &            MAXINT = MAXVQU+MAXSQU)
13218 * x-values of partons (DTUNUC 1.x)
13219       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
13220      &                XTVQ(MAXVQU),XTVD(MAXVQU),
13221      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
13222      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
13223 * flavors of partons (DTUNUC 1.x)
13224       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
13225      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
13226      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
13227      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
13228      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
13229      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
13230      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
13231 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13232       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
13233      &                IXPV,IXPS,IXTV,IXTS,
13234      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
13235      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
13236      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
13237      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
13238      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
13239      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
13240      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
13241      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
13242 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13243       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
13244      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
13245 * auxiliary common for chain system storage (DTUNUC 1.x)
13246       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
13247
13248       IREJ = 0
13249 *  threshold-x for valence diquarks
13250       XDTHR = CDQ/ECM
13251
13252       GOTO (1,2,3,4) MODE
13253
13254 *---------------------------------------------------------------------
13255 * proj. valence partons - targ. sea partons
13256 * get x-values and flavors for target sea-diquark pair
13257
13258     1 CONTINUE
13259       IDXVP = IDX1
13260       IDXST = IDX2
13261
13262 *  index of corr. val-diquark-x in target nucleon
13263       IDXVT = ITOVT(IFROST(IDXST))
13264 *  available x above diquark thresholds for valence- and sea-diquarks
13265       XXD   = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13266
13267       IF (XXD.GE.ZERO) THEN
13268 *  x-values for the three diquarks of the target nucleon
13269          RR1    = DT_RNDM(XXD)
13270          RR2    = DT_RNDM(RR1)
13271          RR3    = DT_RNDM(RR2)
13272          SR123  = RR1+RR2+RR3
13273          XXTV   = XDTHR+RR1*XXD/SR123
13274          XXTSQ  = XDTHR+RR2*XXD/SR123
13275          XXTSAQ = XDTHR+RR3*XXD/SR123
13276       ELSE
13277          XXTV   = XTVD(IDXVT)
13278          XXTSQ  = XTSQ(IDXST)
13279          XXTSAQ = XTSAQ(IDXST)
13280       ENDIF
13281 *  flavor of the second quarks in the sea-diquark pair
13282       ITSQ2(IDXST)  = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13283       ITSAQ2(IDXST) = -ITSQ2(IDXST)
13284 *  check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains
13285       AM1    = XXTSQ *XPVQ(IDXVP)*ECM**2
13286       AM2    = XXTSAQ*XPVD(IDXVP)*ECM**2
13287       IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13288 *    ss-asas pair
13289      &     ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0))            ) THEN
13290          IREJ = 1
13291          RETURN
13292       ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13293 *    at least one strange quark
13294      &         ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0))        ) THEN
13295          IREJ = 1
13296          RETURN
13297       ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13298          IREJ = 1
13299          RETURN
13300       ENDIF
13301 *  accept the new sea-diquark
13302       XTVD(IDXVT)   = XXTV
13303       XTSQ(IDXST)   = XXTSQ
13304       XTSAQ(IDXST)  = XXTSAQ
13305       NVD           = NVD+1
13306       INTVD1(NVD)   = IDXVP
13307       INTVD2(NVD)   = IDXST
13308       ISKPCH(7,NVD) = 0
13309       RETURN
13310
13311 *---------------------------------------------------------------------
13312 * proj. sea partons - targ. valence partons
13313 * get x-values and flavors for projectile sea-diquark pair
13314
13315     2 CONTINUE
13316       IDXSP = IDX2
13317       IDXVT = IDX1
13318
13319 *  index of corr. val-diquark-x in projectile nucleon
13320       IDXVP = ITOVP(IFROSP(IDXSP))
13321 *  available x above diquark thresholds for valence- and sea-diquarks
13322       XXD   = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13323
13324       IF (XXD.GE.ZERO) THEN
13325 *  x-values for the three diquarks of the projectile nucleon
13326          RR1    = DT_RNDM(XXD)
13327          RR2    = DT_RNDM(RR1)
13328          RR3    = DT_RNDM(RR2)
13329          SR123  = RR1+RR2+RR3
13330          XXPV   = XDTHR+RR1*XXD/SR123
13331          XXPSQ  = XDTHR+RR2*XXD/SR123
13332          XXPSAQ = XDTHR+RR3*XXD/SR123
13333       ELSE
13334          XXPV   = XPVD(IDXVP)
13335          XXPSQ  = XPSQ(IDXSP)
13336          XXPSAQ = XPSAQ(IDXSP)
13337       ENDIF
13338 *  flavor of the second quarks in the sea-diquark pair
13339       IPSQ2(IDXSP)  = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13340       IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13341 *  check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains
13342       AM1    = XXPSQ *XTVQ(IDXVT)*ECM**2
13343       AM2    = XXPSAQ*XTVD(IDXVT)*ECM**2
13344       IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13345 *    ss-asas pair
13346      &     ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0))            ) THEN
13347          IREJ = 1
13348          RETURN
13349       ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13350 *    at least one strange quark
13351      &         ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0))        ) THEN
13352          IREJ = 1
13353          RETURN
13354       ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13355          IREJ = 1
13356          RETURN
13357       ENDIF
13358 *  accept the new sea-diquark
13359       XPVD(IDXVP)   = XXPV
13360       XPSQ(IDXSP)   = XXPSQ
13361       XPSAQ(IDXSP)  = XXPSAQ
13362       NDV           = NDV+1
13363       INTDV1(NDV)   = IDXSP
13364       INTDV2(NDV)   = IDXVT
13365       ISKPCH(5,NDV) = 0
13366       RETURN
13367
13368 *---------------------------------------------------------------------
13369 * proj. sea partons - targ. sea partons
13370 * get x-values and flavors for target sea-diquark pair
13371
13372     3 CONTINUE
13373       IDXSP = IDX1
13374       IDXST = IDX2
13375
13376 *  index of corr. val-diquark-x in target nucleon
13377       IDXVT = ITOVT(IFROST(IDXST))
13378 *  available x above diquark thresholds for valence- and sea-diquarks
13379       XXD   = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13380
13381       IF (XXD.GE.ZERO) THEN
13382 *  x-values for the three diquarks of the target nucleon
13383          RR1    = DT_RNDM(XXD)
13384          RR2    = DT_RNDM(RR1)
13385          RR3    = DT_RNDM(RR2)
13386          SR123  = RR1+RR2+RR3
13387          XXTV   = XDTHR+RR1*XXD/SR123
13388          XXTSQ  = XDTHR+RR2*XXD/SR123
13389          XXTSAQ = XDTHR+RR3*XXD/SR123
13390       ELSE
13391          XXTV   = XTVD(IDXVT)
13392          XXTSQ  = XTSQ(IDXST)
13393          XXTSAQ = XTSAQ(IDXST)
13394       ENDIF
13395 *  flavor of the second quarks in the sea-diquark pair
13396       ITSQ2(IDXST)  = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13397       ITSAQ2(IDXST) = -ITSQ2(IDXST)
13398 *  check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains
13399       AM1    = XXTSQ *XPSQ(IDXSP)*ECM**2
13400       AM2    = XXTSAQ*XPSAQ(IDXSP)*ECM**2
13401       IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13402 *    ss-asas pair
13403      &     ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0))            ) THEN
13404          IREJ = 1
13405          RETURN
13406       ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13407 *    at least one strange quark
13408      &         ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0))        ) THEN
13409          IREJ = 1
13410          RETURN
13411       ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13412          IREJ = 1
13413          RETURN
13414       ENDIF
13415 *  accept the new sea-diquark
13416       XTVD(IDXVT)   = XXTV
13417       XTSQ(IDXST)   = XXTSQ
13418       XTSAQ(IDXST)  = XXTSAQ
13419       NSD           = NSD+1
13420       INTSD1(NSD)   = IDXSP
13421       INTSD2(NSD)   = IDXST
13422       ISKPCH(3,NSD) = 0
13423       RETURN
13424
13425 *---------------------------------------------------------------------
13426 * proj. sea partons - targ. sea partons
13427 * get x-values and flavors for projectile sea-diquark pair
13428
13429     4 CONTINUE
13430       IDXSP = IDX2
13431       IDXST = IDX1
13432
13433 *  index of corr. val-diquark-x in projectile nucleon
13434       IDXVP = ITOVP(IFROSP(IDXSP))
13435 *  available x above diquark thresholds for valence- and sea-diquarks
13436       XXD   = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13437
13438       IF (XXD.GE.ZERO) THEN
13439 *  x-values for the three diquarks of the projectile nucleon
13440          RR1    = DT_RNDM(XXD)
13441          RR2    = DT_RNDM(RR1)
13442          RR3    = DT_RNDM(RR2)
13443          SR123  = RR1+RR2+RR3
13444          XXPV   = XDTHR+RR1*XXD/SR123
13445          XXPSQ  = XDTHR+RR2*XXD/SR123
13446          XXPSAQ = XDTHR+RR3*XXD/SR123
13447       ELSE
13448          XXPV   = XPVD(IDXVP)
13449          XXPSQ  = XPSQ(IDXSP)
13450          XXPSAQ = XPSAQ(IDXSP)
13451       ENDIF
13452 *  flavor of the second quarks in the sea-diquark pair
13453       IPSQ2(IDXSP)  = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13454       IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13455 *  check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains
13456       AM1    = XXPSQ *XTSQ(IDXST)*ECM**2
13457       AM2    = XXPSAQ*XTSAQ(IDXST)*ECM**2
13458       IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13459 *    ss-asas pair
13460      &     ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0))            ) THEN
13461          IREJ = 1
13462          RETURN
13463       ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13464 *    at least one strange quark
13465      &         ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0))        ) THEN
13466          IREJ = 1
13467          RETURN
13468       ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13469          IREJ = 1
13470          RETURN
13471       ENDIF
13472 *  accept the new sea-diquark
13473       XPVD(IDXVP)   = XXPV
13474       XPSQ(IDXSP)   = XXPSQ
13475       XPSAQ(IDXSP)  = XXPSAQ
13476       NDS           = NDS+1
13477       INTDS1(NDS)   = IDXSP
13478       INTDS2(NDS)   = IDXST
13479       ISKPCH(2,NDS) = 0
13480       RETURN
13481       END
13482
13483 *$ CREATE DT_DIFEVT.FOR
13484 *COPY DT_DIFEVT
13485 *
13486 *===difevt=============================================================*
13487 *
13488       SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP,
13489      &                  IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ)
13490
13491 ************************************************************************
13492 * Interface to treatment of diffractive interactions.                  *
13493 *  (input)          IFP1/2        PDG-indizes of projectile partons    *
13494 *                                 (baryon: IFP2 - adiquark)            *
13495 *                   PP(4)         projectile 4-momentum                *
13496 *                   IFT1/2        PDG-indizes of target partons        *
13497 *                                 (baryon: IFT1 - adiquark)            *
13498 *                   PT(4)         target 4-momentum                    *
13499 *  (output)         JDIFF = 0     no diffraction                       *
13500 *                         = 1/-1  LMSD/LMDD                            *
13501 *                         = 2/-2  HMSD/HMDD                            *
13502 *                   NCSY          counter for two-chain systems        *
13503 *                                 dumped to DTEVT1                     *
13504 * This version dated 14.02.95 is written by S. Roesler                 *
13505 ************************************************************************
13506
13507       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13508       SAVE
13509       PARAMETER ( LINP = 10 ,
13510      &            LOUT = 6 ,
13511      &            LDAT = 9 )
13512       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5,
13513      &           OHALF=0.5D0)
13514
13515 * event history
13516       PARAMETER (NMXHKK=200000)
13517       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
13518      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
13519      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
13520 * extended event history
13521       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
13522      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
13523      &                IHIST(2,NMXHKK)
13524 * flags for diffractive interactions (DTUNUC 1.x)
13525       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
13526
13527       DIMENSION PP(4),PT(4)
13528
13529       LOGICAL LFIRST
13530       DATA LFIRST /.TRUE./
13531
13532       IREJ   = 0
13533       JDIFF  = 0
13534       IFLAGD = JDIFF
13535
13536 * cm. energy
13537       XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
13538      &          (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
13539 * identities of projectile hadron / target nucleon
13540       KPROJ = IDT_ICIHAD(IDHKK(MOP))
13541       KTARG = IDT_ICIHAD(IDHKK(MOT))
13542
13543 * single diffractive xsections
13544       CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM)
13545 * double diffractive xsections
13546 **!! no double diff yet
13547 C     CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM)
13548       DDTOT = 0.0D0
13549       DDHM  = 0.0D0
13550 **!!
13551 * total inelastic xsection
13552 C     SIGIN  = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM)
13553       DUMZER = ZERO
13554       CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL)
13555       SIGIN  = MAX(SIGTO-SIGEL,ZERO)
13556
13557 * fraction of diffractive processes
13558       FRADIF = (SDTOT+DDTOT)/SIGIN
13559
13560       IF (LFIRST) THEN
13561          WRITE(LOUT,1000) XM,SDTOT,SIGIN
13562  1000    FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ',
13563      &          F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ',
13564      &          F5.1,' mb',/)
13565          LFIRST = .FALSE.
13566       ENDIF
13567
13568       IF ((DT_RNDM(DDHM).LE.FRADIF).OR.
13569      &    (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN
13570 * diffractive interaction requested by x-section or by user
13571          FRASD  = SDTOT/(SDTOT+DDTOT)
13572          FRASDH = SDHM/SDTOT
13573 **sr needs to be specified!!
13574 C        FRADDH = DDHM/DDTOT
13575          FRADDH = 1.0D0
13576 **
13577          IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN
13578 *   single diffraction
13579             KDIFF = 1
13580             IF (DT_RNDM(DDTOT).LE.FRASDH) THEN
13581                KP = 2
13582                KT = 0
13583                IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND.
13584      &               ISINGD.NE.3) THEN
13585                   KP = 0
13586                   KT = 2
13587                ENDIF
13588             ELSE
13589                KP = 1
13590                KT = 0
13591                IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND.
13592      &               ISINGD.NE.3) THEN
13593                   KP = 0
13594                   KT = 1
13595                ENDIF
13596             ENDIF
13597          ELSE
13598 *   double diffraction
13599             KDIFF = -1
13600             IF (DT_RNDM(FRADDH).LE.FRADDH) THEN
13601                KP = 2
13602                KT = 2
13603             ELSE
13604                KP = 1
13605                KT = 1
13606             ENDIF
13607          ENDIF
13608          CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13609      &               IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13610          IF (IREJ1.EQ.0) THEN
13611             IFLAGD = 2*KDIFF
13612             IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF
13613          ELSE
13614             GOTO 9999
13615          ENDIF
13616       ENDIF
13617       JDIFF = IFLAGD
13618
13619       RETURN
13620
13621  9999 CONTINUE
13622       IREJ  = 1
13623       RETURN
13624       END
13625
13626 *$ CREATE DT_DIFFKI.FOR
13627 *COPY DT_DIFFKI
13628 *
13629 *===difkin=============================================================*
13630 *
13631       SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13632      &                  IFT1,IFT2,PT,MOT,KT,NCSY,IREJ)
13633
13634 ************************************************************************
13635 * Kinematics of diffractive nucleon-nucleon interaction.               *
13636 *          IFP1/2   PDG-indizes of projectile partons                  *
13637 *                   (baryon: IFP2 - adiquark)                          *
13638 *          PP(4)    projectile 4-momentum                              *
13639 *          IFT1/2   PDG-indizes of target partons                      *
13640 *                   (baryon: IFT1 - adiquark)                          *
13641 *          PT(4)    target 4-momentum                                  *
13642 *          KP   = 0 projectile quasi-elastically scattered             *
13643 *               = 1            excited to low-mass diff. state         *
13644 *               = 2            excited to high-mass diff. state        *
13645 *          KT   = 0 target     quasi-elastically scattered             *
13646 *               = 1            excited to low-mass diff. state         *
13647 *               = 2            excited to high-mass diff. state        *
13648 * This version dated 12.02.95 is written by S. Roesler                 *
13649 ************************************************************************
13650
13651       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13652       SAVE
13653       PARAMETER ( LINP = 10 ,
13654      &            LOUT = 6 ,
13655      &            LDAT = 9 )
13656       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5)
13657
13658       LOGICAL LSTART
13659
13660 * particle properties (BAMJET index convention)
13661       CHARACTER*8  ANAME
13662       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
13663      &                IICH(210),IIBAR(210),K1(210),K2(210)
13664 * flags for input different options
13665       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
13666       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
13667      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
13668 * rejection counter
13669       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
13670      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
13671      &                IREXCI(3),IRDIFF(2),IRINC
13672 * kinematics of diffractive interactions (DTUNUC 1.x)
13673       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13674      &                PPF(4),PTF(4),
13675      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13676      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13677
13678       DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4),
13679      &          PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4)
13680
13681       DATA LSTART /.TRUE./
13682
13683       IF (LSTART) THEN
13684          WRITE(LOUT,2000)
13685  2000    FORMAT(/,1X,'DIFEVT:  diffractive interactions treated ')
13686          LSTART = .FALSE.
13687       ENDIF
13688
13689       IREJ = 0
13690
13691 * initialize common /DTDIKI/
13692       CALL DT_DIFINI
13693 * store momenta of initial incoming particles for emc-check
13694       IF (LEMCCK) THEN
13695          CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM)
13696          CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM)
13697       ENDIF
13698
13699 * masses of initial particles
13700       XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2
13701       XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2
13702       IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999
13703       XMP  = SQRT(XMP2)
13704       XMT  = SQRT(XMT2)
13705 * check quark-input (used to adjust coherence cond. for M-selection)
13706       IBP  = 0
13707       IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1
13708       IBT  = 0
13709       IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1
13710
13711 * parameter for Lorentz-transformation into nucleon-nucleon cms
13712       DO 3 K=1,4
13713          PITOT(K) = PP(K)+PT(K)
13714     3 CONTINUE
13715       XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2
13716       IF (XMTOT2.LE.ZERO) THEN
13717          WRITE(LOUT,1000) XMTOT2
13718  1000    FORMAT(1X,'DIFEVT:   negative cm. energy!  ',
13719      &          'XMTOT2 = ',E12.3)
13720          GOTO 9999
13721       ENDIF
13722       XMTOT = SQRT(XMTOT2)
13723       DO 4 K=1,4
13724          BGTOT(K) = PITOT(K)/XMTOT
13725     4 CONTINUE
13726 * transformation of nucleons into cms
13727       CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2),
13728      &            PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4))
13729       CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2),
13730      &            PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4))
13731 * rotation angles
13732       COD = PP1(3)/PPTOT
13733 C     SID = SQRT((ONE-COD)*(ONE+COD))
13734       PPT = SQRT(PP1(1)**2+PP1(2)**2)
13735       SID = PPT/PPTOT
13736       COF = ONE
13737       SIF = ZERO
13738       IF(PPTOT*SID.GT.TINY10) THEN
13739          COF   = PP1(1)/(SID*PPTOT)
13740          SIF   = PP1(2)/(SID*PPTOT)
13741          ANORF = SQRT(COF*COF+SIF*SIF)
13742          COF   = COF/ANORF
13743          SIF   = SIF/ANORF
13744       ENDIF
13745 * check consistency
13746       DO 5 K=1,4
13747          DEV1(K) = ABS(PP1(K)+PT1(K))
13748     5 CONTINUE
13749       DEV1(4) = ABS(DEV1(4)-XMTOT)
13750       IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR.
13751      &    (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10))     THEN
13752          WRITE(LOUT,1001) DEV1
13753  1001    FORMAT(1X,'DIFEVT:   inconsitent Lorentz-transformation! ',
13754      &          /,8X,4E12.3)
13755          GOTO 9999
13756       ENDIF
13757
13758 * select x-fractions in high-mass diff. interactions
13759       IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT)
13760
13761 * select diffractive masses
13762 * - projectile
13763       IF (KP.EQ.1) THEN
13764          XMPF = DT_XMLMD(XMTOT)
13765          CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1)
13766          IF (IREJ1.GT.0) GOTO 9999
13767       ELSEIF (KP.EQ.2) THEN
13768          XMPF = DT_XMHMD(XMTOT,IBP,1)
13769       ELSE
13770          XMPF = XMP
13771       ENDIF
13772 * - target
13773       IF (KT.EQ.1) THEN
13774          XMTF = DT_XMLMD(XMTOT)
13775          CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1)
13776          IF (IREJ1.GT.0) GOTO 9999
13777       ELSEIF (KT.EQ.2) THEN
13778          XMTF = DT_XMHMD(XMTOT,IBT,2)
13779       ELSE
13780          XMTF = XMT
13781       ENDIF
13782
13783 * kinematical treatment of "two-particle" system (masses - XMPF,XMTF)
13784       XMPF2 = XMPF**2
13785       XMTF2 = XMTF**2
13786       PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT)
13787       PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2)
13788
13789 * select momentum transfer (all t-values used here are <0)
13790 *   minimum absolute value to produce diffractive masses
13791       TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3))
13792       TT   = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1)
13793       IF (IREJ1.GT.0) GOTO 9999
13794
13795 * longitudinal momentum of excited/elastically scattered projectile
13796       PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT)
13797 * total transverse momentum due to t-selection
13798       PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2
13799       IF (PPBLT2.LT.ZERO) THEN
13800          WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT
13801  1002    FORMAT(1X,'DIFEVT:   inconsistent transverse momentum! ',
13802      &          E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3)
13803          GOTO 9999
13804       ENDIF
13805       CALL DT_DSFECF(SINPHI,COSPHI)
13806       PPBLT     = SQRT(PPBLT2)
13807       PPBLOB(1) = COSPHI*PPBLT
13808       PPBLOB(2) = SINPHI*PPBLT
13809
13810 * rotate excited/elastically scattered projectile into n-n cms.
13811       CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF,
13812      &                                                    XX,YY,ZZ)
13813       PPBLOB(1) = XX
13814       PPBLOB(2) = YY
13815       PPBLOB(3) = ZZ
13816
13817 * 4-momentum of excited/elastically scattered target and of exchanged
13818 * Pomeron
13819       DO 6 K=1,4
13820          IF (K.LT.4) PTBLOB(K) = -PPBLOB(K)
13821          PPOM1(K) = PP1(K)-PPBLOB(K)
13822     6 CONTINUE
13823       PTBLOB(4) = XMTOT-PPBLOB(4)
13824
13825 * Lorentz-transformation back into system of initial diff. collision
13826       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13827      &            PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4),
13828      &            PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4))
13829       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13830      &            PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4),
13831      &            PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4))
13832       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13833      &            PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4),
13834      &            PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4))
13835
13836 * store 4-momentum of elastically scattered particle (in single diff.
13837 * events)
13838       IF (KP.EQ.0) THEN
13839          DO 7 K=1,4
13840             PSC(K) = PPF(K)
13841     7    CONTINUE
13842       ELSEIF (KT.EQ.0) THEN
13843          DO 8 K=1,4
13844             PSC(K) = PTF(K)
13845     8    CONTINUE
13846       ENDIF
13847
13848 * check consistency of kinematical treatment so far
13849       IF (LEMCCK) THEN
13850          CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM)
13851          CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM)
13852          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1)
13853          IF (IREJ1.NE.0) GOTO 9999
13854       ENDIF
13855       DO 9 K=1,4
13856          DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K))
13857          DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K))
13858     9 CONTINUE
13859       IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR.
13860      &    (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR.
13861      &    (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR.
13862      &    (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5))     THEN
13863          WRITE(LOUT,1003) DEV1,DEV2
13864  1003    FORMAT(1X,'DIFEVT:   inconsitent kinematical treatment!  ',
13865      &          2(/,8X,4E12.3))
13866          GOTO 9999
13867       ENDIF
13868
13869 * kinematical treatment for low-mass diffraction
13870       CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1)
13871       IF (IREJ1.NE.0) GOTO 9999
13872
13873 * dump diffractive chains into DTEVT1
13874       CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13875       IF (IREJ1.NE.0) GOTO 9999
13876
13877       RETURN
13878
13879  9999 CONTINUE
13880       IRDIFF(1) = IRDIFF(1)+1
13881       IREJ      = 1
13882       RETURN
13883       END
13884
13885 *$ CREATE DT_XMHMD.FOR
13886 *COPY DT_XMHMD
13887 *
13888 *===xmhmd==============================================================*
13889 *
13890       DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE)
13891
13892 ************************************************************************
13893 * Diffractive mass in high mass single/double diffractive events.      *
13894 * This version dated 11.02.95 is written by S. Roesler                 *
13895 ************************************************************************
13896
13897       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13898       SAVE
13899       PARAMETER ( LINP = 10 ,
13900      &            LOUT = 6 ,
13901      &            LDAT = 9 )
13902       PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)
13903
13904 * kinematics of diffractive interactions (DTUNUC 1.x)
13905       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13906      &                PPF(4),PTF(4),
13907      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13908      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13909
13910 C     DATA XCOLOW /0.05D0/
13911       DATA XCOLOW /0.15D0/
13912
13913       DT_XMHMD = ZERO
13914       XH = XPH(2)
13915       IF (MODE.EQ.2) XH = XTH(2)
13916
13917 * minimum Pomeron-x for high-mass diffraction
13918 * (adjusted to get a smooth transition between HM and LM component)
13919       R = DT_RNDM(XH)
13920       XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2)
13921       IF (ECM.LE.300.0D0) THEN
13922          RR     = (1.0D0-EXP(-((ECM/140.0D0)**4)))
13923          XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2)
13924       ENDIF
13925 * maximum Pomeron-x for high-mass diffraction
13926 * (coherence condition, adjusted to fit to experimental data)
13927       IF (IB.NE.0) THEN
13928 *   baryon-diffraction
13929          XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2)))
13930       ELSE
13931 *   meson-diffraction
13932          XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2)))
13933       ENDIF
13934 * check boundaries
13935       IF (XDIMIN.GE.XDIMAX) THEN
13936          XDIMIN = OHALF*XDIMAX
13937       ENDIF
13938
13939       KLOOP = 0
13940     1 CONTINUE
13941       KLOOP = KLOOP+1
13942       IF (KLOOP.GT.20) RETURN
13943 * sample Pomeron-x from 1/x-distribution (critical Pomeron)
13944       XDIFF = DT_SAMPEX(XDIMIN,XDIMAX)
13945 * corr. diffr. mass
13946       DT_XMHMD = ECM*SQRT(XDIFF)
13947       IF (DT_XMHMD.LT.2.5D0) GOTO 1
13948
13949       RETURN
13950       END
13951
13952 *$ CREATE DT_XMLMD.FOR
13953 *COPY DT_XMLMD
13954 *
13955 *===xmlmd==============================================================*
13956 *
13957       DOUBLE PRECISION FUNCTION DT_XMLMD(ECM)
13958
13959 ************************************************************************
13960 * Diffractive mass in high mass single/double diffractive events.      *
13961 * This version dated 11.02.95 is written by S. Roesler                 *
13962 ************************************************************************
13963
13964       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13965       SAVE
13966       PARAMETER ( LINP = 10 ,
13967      &            LOUT = 6 ,
13968      &            LDAT = 9 )
13969
13970 * minimum Pomeron-x for low-mass diffraction
13971 C     AMO = 1.5D0
13972       AMO = 2.0D0
13973 * maximum Pomeron-x for low-mass diffraction
13974 * (adjusted to get a smooth transition between HM and LM component)
13975       R   = DT_RNDM(AMO)
13976       SAM = 1.0D0
13977       IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4))
13978       R   = DT_RNDM(AMO)*SAM
13979       AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0)
13980       AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX
13981
13982 * selection of diffractive mass
13983 * (adjusted to get a smooth transition between HM and LM component)
13984       R   = DT_RNDM(AMU)
13985       IF (ECM.LE.50.0D0) THEN
13986          DT_XMLMD = AMO*(AMU/AMO)**R
13987       ELSE
13988          A = 0.7D0
13989          IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2)))
13990          DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A))
13991       ENDIF
13992
13993       RETURN
13994       END
13995
13996 *$ CREATE DT_TDIFF.FOR
13997 *COPY DT_TDIFF
13998 *
13999 *===tdiff==============================================================*
14000 *
14001       DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ)
14002
14003 ************************************************************************
14004 * t-selection for single/double diffractive interactions.              *
14005 *          ECM      cm. energy                                         *
14006 *          TMIN     minimum momentum transfer to produce diff. masses  *
14007 *          XM1/XM2  diffractively produced masses                      *
14008 *                   (for single diffraction XM2 is obsolete)           *
14009 *          K1/K2= 0 not excited                                        *
14010 *               = 1 low-mass excitation                                *
14011 *               = 2 high-mass excitation                               *
14012 * This version dated 11.02.95 is written by S. Roesler                 *
14013 ************************************************************************
14014
14015       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14016       SAVE
14017       PARAMETER ( LINP = 10 ,
14018      &            LOUT = 6 ,
14019      &            LDAT = 9 )
14020       PARAMETER (ZERO=0.0D0)
14021
14022       PARAMETER ( BTP0   = 3.7D0,
14023      &            ALPHAP = 0.24D0 )
14024
14025       IREJ   = 0
14026       NCLOOP = 0
14027       DT_TDIFF  = ZERO
14028
14029       IF (K1.GT.0) THEN
14030          XM1 = XM1I
14031          XM2 = XM2I
14032       ELSE
14033          XM1 = XM2I
14034       ENDIF
14035       XDI = (XM1/ECM)**2
14036       IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN
14037 * slope for single diffraction
14038          SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI)
14039       ELSE
14040 * slope for double diffraction
14041          SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2)
14042       ENDIF
14043
14044     1 CONTINUE
14045       NCLOOP = NCLOOP+1
14046       IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999
14047       Y = DT_RNDM(XDI)
14048       T = -LOG(1.0D0-Y)/SLOPE
14049       IF (ABS(T).LE.ABS(TMIN)) GOTO 1
14050       DT_TDIFF = -ABS(T)
14051
14052       RETURN
14053
14054  9999 CONTINUE
14055       WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2
14056  1000 FORMAT(1X,'DT_TDIFF:   t-selection rejected!',/,
14057      &       1X,'ECM  = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ',
14058      &       E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2)
14059       IREJ = 1
14060       RETURN
14061       END
14062
14063 *$ CREATE DT_XVALHM.FOR
14064 *COPY DT_XVALHM
14065 *
14066 *===xvalhm=============================================================*
14067 *
14068       SUBROUTINE DT_XVALHM(KP,KT)
14069
14070 ************************************************************************
14071 * Sampling of parton x-values in high-mass diffractive interactions.   *
14072 * This version dated 12.02.95 is written by S. Roesler                 *
14073 ************************************************************************
14074
14075       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14076       SAVE
14077       PARAMETER ( LINP = 10 ,
14078      &            LOUT = 6 ,
14079      &            LDAT = 9 )
14080       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2)
14081
14082 * kinematics of diffractive interactions (DTUNUC 1.x)
14083       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14084      &                PPF(4),PTF(4),
14085      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14086      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14087 * various options for treatment of partons (DTUNUC 1.x)
14088 * (chain recombination, Cronin,..)
14089       LOGICAL LCO2CR,LINTPT
14090       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
14091      &                LCO2CR,LINTPT
14092
14093       DATA UNON,XVQTHR /2.0D0,0.8D0/
14094
14095       IF (KP.EQ.2) THEN
14096 * x-fractions of projectile valence partons
14097     1    CONTINUE
14098          XPH(1) = DT_DBETAR(OHALF,UNON)
14099          IF (XPH(1).GE.XVQTHR) GOTO 1
14100          XPH(2) = ONE-XPH(1)
14101 * x-fractions of Pomeron q-aq-pair
14102          XPOLO = TINY2
14103          XPOHI = ONE-TINY2
14104          XPPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14105          XPPO(2) = ONE-XPPO(1)
14106 * flavors of Pomeron q-aq-pair
14107          IFLAV    = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ))
14108          IFPPO(1) = IFLAV
14109          IFPPO(2) = -IFLAV
14110          IF (DT_RNDM(UNON).GT.OHALF) THEN
14111             IFPPO(1) = -IFLAV
14112             IFPPO(2) = IFLAV
14113          ENDIF
14114       ENDIF
14115
14116       IF (KT.EQ.2) THEN
14117 * x-fractions of projectile target partons
14118     2    CONTINUE
14119          XTH(1) = DT_DBETAR(OHALF,UNON)
14120          IF (XTH(1).GE.XVQTHR) GOTO 2
14121          XTH(2) = ONE-XTH(1)
14122 * x-fractions of Pomeron q-aq-pair
14123          XPOLO = TINY2
14124          XPOHI = ONE-TINY2
14125          XTPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14126          XTPO(2) = ONE-XTPO(1)
14127 * flavors of Pomeron q-aq-pair
14128          IFLAV    = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ))
14129          IFTPO(1) = IFLAV
14130          IFTPO(2) = -IFLAV
14131          IF (DT_RNDM(XPOLO).GT.OHALF) THEN
14132             IFTPO(1) = -IFLAV
14133             IFTPO(2) = IFLAV
14134          ENDIF
14135       ENDIF
14136
14137       RETURN
14138       END
14139
14140 *$ CREATE DT_LM2RES.FOR
14141 *COPY DT_LM2RES
14142 *
14143 *===lm2res=============================================================*
14144 *
14145       SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ)
14146
14147 ************************************************************************
14148 * Check low-mass diffractive excitation for resonance mass.            *
14149 *   (input)   IF1/2    PDG-indizes of valence partons                  *
14150 *   (in/out)  XM       diffractive mass requested/corrected            *
14151 *   (output)  IDR/IDXR id./BAMJET-index of resonance                   *
14152 * This version dated 12.02.95 is written by S. Roesler                 *
14153 ************************************************************************
14154
14155       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14156       SAVE
14157       PARAMETER ( LINP = 10 ,
14158      &            LOUT = 6 ,
14159      &            LDAT = 9 )
14160       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14161
14162 * kinematics of diffractive interactions (DTUNUC 1.x)
14163       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14164      &                PPF(4),PTF(4),
14165      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14166      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14167
14168       IREJ = 0
14169       IF1B = 0
14170       IF2B = 0
14171       XMI  = XM
14172
14173 * BAMJET indices of partons
14174       IF1A = IDT_IPDG2B(IF1,1,2)
14175       IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2)
14176       IF2A = IDT_IPDG2B(IF2,1,2)
14177       IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2)
14178
14179 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq)
14180       IDCH = 2
14181       IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1
14182
14183 * check for resonance mass
14184       CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1)
14185       IF (IREJ1.NE.0) GOTO 9999
14186
14187       XM = XMN
14188       RETURN
14189
14190  9999 CONTINUE
14191       IREJ = 1
14192       RETURN
14193       END
14194
14195 *$ CREATE DT_LMKINE.FOR
14196 *COPY DT_LMKINE
14197 *
14198 *===lmkine=============================================================*
14199 *
14200       SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ)
14201
14202 ************************************************************************
14203 * Kinematical treatment of low-mass excitations.                       *
14204 * This version dated 12.02.95 is written by S. Roesler                 *
14205 ************************************************************************
14206
14207       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14208       SAVE
14209       PARAMETER ( LINP = 10 ,
14210      &            LOUT = 6 ,
14211      &            LDAT = 9 )
14212       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14213
14214 * flags for input different options
14215       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14216       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14217      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14218 * kinematics of diffractive interactions (DTUNUC 1.x)
14219       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14220      &                PPF(4),PTF(4),
14221      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14222      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14223
14224       DIMENSION P1(4),P2(4)
14225
14226       IREJ = 0
14227
14228       IF (KP.EQ.1) THEN
14229          PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2)
14230          POE  = PPF(4)/PABS
14231          FAC1 = OHALF*(POE+ONE)
14232          FAC2 = -OHALF*(POE-ONE)
14233          DO 1 K=1,3
14234             PPLM1(K) = FAC1*PPF(K)
14235             PPLM2(K) = FAC2*PPF(K)
14236     1    CONTINUE
14237          PPLM1(4) = FAC1*PABS
14238          PPLM2(4) = -FAC2*PABS
14239          IF (IMSHL.EQ.1) THEN
14240             XM1 = PYMASS(IFP1)
14241             XM2 = PYMASS(IFP2)
14242             CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1)
14243             IF (IREJ1.NE.0) GOTO 9999
14244             DO 2 K=1,4
14245                PPLM1(K) = P1(K)
14246                PPLM2(K) = P2(K)
14247     2       CONTINUE
14248          ENDIF
14249       ENDIF
14250
14251       IF (KT.EQ.1) THEN
14252          PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2)
14253          POE  = PTF(4)/PABS
14254          FAC1 = OHALF*(POE+ONE)
14255          FAC2 = -OHALF*(POE-ONE)
14256          DO 3 K=1,3
14257             PTLM2(K) = FAC1*PTF(K)
14258             PTLM1(K) = FAC2*PTF(K)
14259     3    CONTINUE
14260          PTLM2(4) = FAC1*PABS
14261          PTLM1(4) = -FAC2*PABS
14262          IF (IMSHL.EQ.1) THEN
14263             XM1 = PYMASS(IFT1)
14264             XM2 = PYMASS(IFT2)
14265             CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1)
14266             IF (IREJ1.NE.0) GOTO 9999
14267             DO 4 K=1,4
14268                PTLM1(K) = P1(K)
14269                PTLM2(K) = P2(K)
14270     4       CONTINUE
14271          ENDIF
14272       ENDIF
14273
14274       RETURN
14275
14276  9999 CONTINUE
14277       WRITE(LOUT,'(A)') 'LMKINE:   kinematical treatment rejected'
14278       IREJ = 1
14279       RETURN
14280       END
14281
14282 *$ CREATE DT_DIFINI.FOR
14283 *COPY DT_DIFINI
14284 *
14285 *===difini=============================================================*
14286 *
14287       SUBROUTINE DT_DIFINI
14288
14289 ************************************************************************
14290 * Initialization of common /DTDIKI/                                    *
14291 * This version dated 12.02.95 is written by S. Roesler                 *
14292 ************************************************************************
14293
14294       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14295       SAVE
14296       PARAMETER ( LINP = 10 ,
14297      &            LOUT = 6 ,
14298      &            LDAT = 9 )
14299       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14300
14301 * kinematics of diffractive interactions (DTUNUC 1.x)
14302       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14303      &                PPF(4),PTF(4),
14304      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14305      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14306
14307       DO 1 K=1,4
14308          PPOM(K)  = ZERO
14309          PSC(K)   = ZERO
14310          PPF(K)   = ZERO
14311          PTF(K)   = ZERO
14312          PPLM1(K) = ZERO
14313          PPLM2(K) = ZERO
14314          PTLM1(K) = ZERO
14315          PTLM2(K) = ZERO
14316     1 CONTINUE
14317       DO 2 K=1,2
14318          XPH(K)   = ZERO
14319          XPPO(K)  = ZERO
14320          XTH(K)   = ZERO
14321          XTPO(K)  = ZERO
14322          IFPPO(K) = 0
14323          IFTPO(K) = 0
14324     2 CONTINUE
14325       IDPR  = 0
14326       IDXPR = 0
14327       IDTR  = 0
14328       IDXTR = 0
14329
14330       RETURN
14331       END
14332
14333 *$ CREATE DT_DIFPUT.FOR
14334 *COPY DT_DIFPUT
14335 *
14336 *===difput=============================================================*
14337 *
14338       SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,
14339      &                                                          IREJ)
14340
14341 ************************************************************************
14342 * Dump diffractive chains into DTEVT1                                  *
14343 * This version dated 12.02.95 is written by S. Roesler                 *
14344 ************************************************************************
14345
14346       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14347       SAVE
14348       PARAMETER ( LINP = 10 ,
14349      &            LOUT = 6 ,
14350      &            LDAT = 9 )
14351       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14352
14353       LOGICAL LCHK
14354
14355 * kinematics of diffractive interactions (DTUNUC 1.x)
14356       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14357      &                PPF(4),PTF(4),
14358      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14359      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14360 * event history
14361       PARAMETER (NMXHKK=200000)
14362       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14363      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14364      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14365 * extended event history
14366       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14367      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14368      &                IHIST(2,NMXHKK)
14369 * rejection counter
14370       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
14371      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
14372      &                IREXCI(3),IRDIFF(2),IRINC
14373
14374       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4),
14375      &          P1(4),P2(4),P3(4),P4(4)
14376
14377       IREJ = 0
14378
14379       IF (KP.EQ.1) THEN
14380          DO 1 K=1,4
14381             PCH(K) = PPLM1(K)+PPLM2(K)
14382     1    CONTINUE
14383          ID1 = IFP1
14384          ID2 = IFP2
14385          IF (DT_RNDM(PT).GT.OHALF) THEN
14386             ID1 = IFP2
14387             ID2 = IFP1
14388          ENDIF
14389          CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3),
14390      &                                        PPLM1(4),0,0,0)
14391          CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3),
14392      &                                        PPLM2(4),0,0,0)
14393          CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14394      &                                              IDPR,IDXPR,8)
14395       ELSEIF (KP.EQ.2) THEN
14396          DO 2 K=1,4
14397             PP1(K) = XPH(1)*PP(K)
14398             PP2(K) = XPH(2)*PP(K)
14399             PT1(K) = -XPPO(1)*PPOM(K)
14400             PT2(K) = -XPPO(2)*PPOM(K)
14401     2    CONTINUE
14402          CALL  DT_CHKCSY(IFP1,IFPPO(1),LCHK)
14403          XM1 = ZERO
14404          XM2 = ZERO
14405          IF (LCHK) THEN
14406             CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14407             IF (IREJ1.NE.0) GOTO 9999
14408             CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14409             IF (IREJ1.NE.0) GOTO 9999
14410             DO 3 K=1,4
14411                PP1(K) = P1(K)
14412                PT1(K) = P2(K)
14413                PP2(K) = P3(K)
14414                PT2(K) = P4(K)
14415     3       CONTINUE
14416             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14417      &                                                       0,0,8)
14418             CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14419      &                                             PT1(4),0,0,8)
14420             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14421      &                                                       0,0,8)
14422             CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14423      &                                             PT2(4),0,0,8)
14424          ELSE
14425             CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14426             IF (IREJ1.NE.0) GOTO 9999
14427             CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14428             IF (IREJ1.NE.0) GOTO 9999
14429             DO 4 K=1,4
14430                PP1(K) = P1(K)
14431                PT2(K) = P2(K)
14432                PP2(K) = P3(K)
14433                PT1(K) = P4(K)
14434     4       CONTINUE
14435             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14436      &                                                       0,0,8)
14437             CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14438      &                                                PT2(4),0,0,8)
14439             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14440      &                                                       0,0,8)
14441             CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14442      &                                                PT1(4),0,0,8)
14443          ENDIF
14444          NCSY = NCSY+1
14445       ELSE
14446          CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4),
14447      &                                                        0,0,0)
14448       ENDIF
14449
14450       IF (KT.EQ.1) THEN
14451          DO 5 K=1,4
14452             PCH(K) = PTLM1(K)+PTLM2(K)
14453     5    CONTINUE
14454          ID1 = IFT1
14455          ID2 = IFT2
14456          IF (DT_RNDM(PT).GT.OHALF) THEN
14457             ID1 = IFT2
14458             ID2 = IFT1
14459          ENDIF
14460          CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3),
14461      &                                              PTLM1(4),0,0,0)
14462          CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3),
14463      &                                              PTLM2(4),0,0,0)
14464          CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14465      &                                              IDTR,IDXTR,8)
14466       ELSEIF (KT.EQ.2) THEN
14467          DO 6 K=1,4
14468             PP1(K) = XTPO(1)*PPOM(K)
14469             PP2(K) = XTPO(2)*PPOM(K)
14470             PT1(K) = XTH(2)*PT(K)
14471             PT2(K) = XTH(1)*PT(K)
14472     6    CONTINUE
14473          CALL  DT_CHKCSY(IFTPO(1),IFT1,LCHK)
14474          XM1 = ZERO
14475          XM2 = ZERO
14476          IF (LCHK) THEN
14477             CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14478             IF (IREJ1.NE.0) GOTO 9999
14479             CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14480             IF (IREJ1.NE.0) GOTO 9999
14481             DO 7 K=1,4
14482                PP1(K) = P1(K)
14483                PT1(K) = P2(K)
14484                PP2(K) = P3(K)
14485                PT2(K) = P4(K)
14486     7       CONTINUE
14487             CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14488      &                                                PP1(4),0,0,8)
14489             CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14490      &                                                       0,0,8)
14491             CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14492      &                                                PP2(4),0,0,8)
14493             CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14494      &                                                       0,0,8)
14495          ELSE
14496             CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14497             IF (IREJ1.NE.0) GOTO 9999
14498             CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14499             IF (IREJ1.NE.0) GOTO 9999
14500             DO 8 K=1,4
14501                PP1(K) = P1(K)
14502                PT2(K) = P2(K)
14503                PP2(K) = P3(K)
14504                PT1(K) = P4(K)
14505     8       CONTINUE
14506             CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14507      &                                                PP1(4),0,0,8)
14508             CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14509      &                                                       0,0,8)
14510             CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14511      &                                                PP2(4),0,0,8)
14512             CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14513      &                                                       0,0,8)
14514          ENDIF
14515          NCSY = NCSY+1
14516       ELSE
14517          CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4),
14518      &                                                        0,0,0)
14519       ENDIF
14520
14521       RETURN
14522
14523  9999 CONTINUE
14524       IRDIFF(2) = IRDIFF(2)+1
14525       IREJ      = 1
14526       RETURN
14527       END
14528
14529 *$ CREATE DT_EVTFRG.FOR
14530 *COPY DT_EVTFRG
14531 *
14532 *===evtfrg=============================================================*
14533 *
14534       SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ)
14535
14536 ************************************************************************
14537 * Hadronization of chains in DTEVT1.                                   *
14538 *                                                                      *
14539 * Input:                                                               *
14540 *   KMODE = 1   hadronization of PHOJET-chains (id=77xxx)              *
14541 *         = 2   hadronization of DTUNUC-chains (id=88xxx)              *
14542 *   NFRG  if KMODE = 1 : upper index of PHOJET-scatterings to be       *
14543 *                        hadronized with one PYEXEC call               *
14544 *         if KMODE = 2 : max. number of DTUNUC-chains to be hadronized *
14545 *                        with one PYEXEC call                          *
14546 * Output:                                                              *
14547 *   NPYMEM      number of entries in JETSET-common after hadronization *
14548 *   IREJ        rejection flag                                         *
14549 *                                                                      *
14550 * This version dated 17.09.00 is written by S. Roesler                 *
14551 ************************************************************************
14552
14553       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14554       SAVE
14555       PARAMETER ( LINP = 10 ,
14556      &            LOUT = 6 ,
14557      &            LDAT = 9 )
14558       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1)
14559       PARAMETER (ONE=1.0D0,ZERO=0.0D0)
14560
14561       LOGICAL LACCEP
14562
14563       PARAMETER (MXJOIN=200)
14564
14565 * event history
14566       PARAMETER (NMXHKK=200000)
14567       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14568      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14569      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14570 * extended event history
14571       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14572      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14573      &                IHIST(2,NMXHKK)
14574 * flags for input different options
14575       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14576       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14577      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14578 * statistics
14579       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
14580      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
14581      &                ICEVTG(8,0:30)
14582 * flags for diffractive interactions (DTUNUC 1.x)
14583       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
14584 * nucleon-nucleon event-generator
14585       CHARACTER*8 CMODEL
14586       LOGICAL LPHOIN
14587       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
14588 * phojet
14589 C  model switches and parameters
14590       CHARACTER*8 MDLNA
14591       INTEGER ISWMDL,IPAMDL
14592       DOUBLE PRECISION PARMDL
14593       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14594 * jetset
14595       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14596       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
14597       PARAMETER (MAXLND=4000)
14598       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
14599       INTEGER PYK
14600       DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
14601       INTEGER PYCOMP
14602       MODE = KMODE
14603       ISTSTG = 7
14604       IF (MODE.NE.1) ISTSTG = 8
14605       IREJ = 0
14606
14607       IP     = 0
14608       ISH    = 0
14609       INIEMC = 1
14610       NEND   = NHKK
14611       NACCEP = 0
14612       IFRG   = 0
14613       IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
14614       DO 10 I=NPOINT(3),NEND
14615 * sr 14.02.00: seems to be not necessary anymore, commented
14616 C        LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
14617 C    &            ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
14618          LACCEP = .TRUE.
14619 * pick up chains from dtevt1
14620          IDCHK = IDHKK(I)/10000
14621          IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN
14622             IF (IDCHK.EQ.7) THEN
14623                IPJE = IDHKK(I)-IDCHK*10000
14624                IF (IPJE.NE.IFRG) THEN
14625                   IFRG = IPJE
14626                   IF (IFRG.GT.NFRG) GOTO 16
14627                ENDIF
14628             ELSE
14629                IPJE = 1
14630                IFRG = IFRG+1
14631                IF (IFRG.GT.NFRG) THEN
14632                   NFRG = -1
14633                   GOTO 16
14634                ENDIF
14635             ENDIF
14636 *   statistics counter
14637 c           IF (IDCH(I).LE.8)
14638 c    &         ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
14639 c           IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
14640 * special treatment for small chains already corrected to hadrons
14641             IF (IDRES(I).NE.0) THEN
14642                IF (IDRES(I).EQ.11) THEN
14643                   ID = IDXRES(I)
14644                ELSE
14645                   ID = IDT_IPDGHA(IDXRES(I))
14646                ENDIF
14647                IF (LEMCCK) THEN
14648                   CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
14649      &                              PHKK(4,I),INIEMC,IDUM,IDUM)
14650                   INIEMC = 2
14651                ENDIF
14652                IP = IP+1
14653                IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
14654                P(IP,1) = PHKK(1,I)
14655                P(IP,2) = PHKK(2,I)
14656                P(IP,3) = PHKK(3,I)
14657                P(IP,4) = PHKK(4,I)
14658                P(IP,5) = PHKK(5,I)
14659                K(IP,1) = 1
14660                K(IP,2) = ID
14661                K(IP,3) = 0
14662                K(IP,4) = 0
14663                K(IP,5) = 0
14664                IHIST(2,I) = 10000*IPJE+IP
14665                IF (IHIST(1,I).LE.-100) THEN
14666                   ISH = ISH+1
14667                   IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14668                   ISJOIN(ISH) = I
14669                ENDIF
14670                N = IP
14671                IHISMO(IP) = I
14672             ELSE
14673                IJ  = 0
14674                DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
14675                   IF (LEMCCK) THEN
14676                      CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK),
14677      &                                   PHKK(4,KK),INIEMC,IDUM,IDUM)
14678                      CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM)
14679                      INIEMC = 2
14680                   ENDIF
14681                   ID = IDHKK(KK)
14682                   IF (ID.EQ.0) ID = 21
14683 c                  PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
14684 c                  AM0  = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
14685 c                  AMRQ   = PYMASS(ID)
14686 c                  AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
14687 c                  IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
14688 c     &                (ABS(IDIFF).EQ.0)) THEN
14689 cC                    WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
14690 c                     DELTA      = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
14691 c                     PHKK(4,KK) = PHKK(4,KK)+DELTA
14692 c                     PTOT1      = PTOT-DELTA
14693 c                     PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
14694 c                     PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
14695 c                     PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
14696 c                     PHKK(5,KK) = AMRQ
14697 c                  ENDIF
14698                   IP = IP+1
14699                   IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
14700                   P(IP,1) = PHKK(1,KK)
14701                   P(IP,2) = PHKK(2,KK)
14702                   P(IP,3) = PHKK(3,KK)
14703                   P(IP,4) = PHKK(4,KK)
14704                   P(IP,5) = PHKK(5,KK)
14705                   K(IP,1) = 1
14706                   K(IP,2) = ID
14707                   K(IP,3) = 0
14708                   K(IP,4) = 0
14709                   K(IP,5) = 0
14710                   IHIST(2,KK) = 10000*IPJE+IP
14711                   IF (IHIST(1,KK).LE.-100) THEN
14712                      ISH = ISH+1
14713                      IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14714                      ISJOIN(ISH) = KK
14715                   ENDIF
14716                   IJ = IJ+1
14717                   IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
14718                   IJOIN(IJ)  = IP
14719                   IHISMO(IP) = I
14720    11          CONTINUE
14721                N = IP
14722 * join the two-parton system
14723                CALL PYJOIN(IJ,IJOIN)
14724             ENDIF
14725             IDHKK(I) = 99999
14726          ENDIF
14727    10 CONTINUE
14728    16 CONTINUE
14729       N = IP
14730
14731       IF (IP.GT.0) THEN
14732
14733 * final state parton shower
14734          DO 136 NPJE=1,IPJE
14735             IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
14736                IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
14737                   DO 130 K1=1,ISH
14738                      IF (ISJOIN(K1).EQ.0) GOTO 130
14739                      I = ISJOIN(K1)
14740                      IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
14741      &                                                       GOTO 130
14742                      IH1 = IHIST(2,I)/10000
14743                      IF (IH1.NE.NPJE) GOTO 130
14744                      IH1 = IHIST(2,I)-IH1*10000
14745                      DO 135 K2=K1+1,ISH
14746                         IF (ISJOIN(K2).EQ.0) GOTO 135
14747                         II = ISJOIN(K2)
14748                         IH2 = IHIST(2,II)/10000
14749                         IF (IH2.NE.NPJE) GOTO 135
14750                         IH2 = IHIST(2,II)-IH2*10000
14751                         IF (IHIST(1,I).EQ.IHIST(1,II)) THEN
14752                            PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2)
14753                            PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2)
14754                            RQLUN = MIN(PT1,PT2)
14755                            CALL PYSHOW(IH1,IH2,RQLUN)
14756
14757                            ISJOIN(K1) = 0
14758                            ISJOIN(K2) = 0
14759                            GOTO 130
14760                         ENDIF
14761  135                 CONTINUE
14762  130              CONTINUE
14763                ENDIF
14764             ENDIF
14765  136     CONTINUE
14766
14767          CALL DT_INITJS(MODE)
14768 * hadronization
14769
14770          CALL PYEXEC
14771
14772          IF (MSTU(24).NE.0) THEN
14773             WRITE(LOUT,*) ' JETSET-reject at event',
14774      &                    NEVHKK,MSTU(24),KMODE
14775 C           CALL DT_EVTOUT(4)
14776
14777 C           CALL PYLIST(2)
14778
14779             GOTO 9999
14780          ENDIF
14781
14782 *   number of entries in LUJETS
14783
14784          NLINES = PYK(0,1)
14785
14786          NPYMEM = NLINES
14787
14788          DO 12 I=1,NLINES
14789             IFLG(I) = 0
14790    12    CONTINUE
14791
14792          DO 13 II=1,NLINES
14793
14794             IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
14795
14796 *  pick up mother resonance if possible and put it together with
14797 *  their decay-products into the common
14798                IDXMOR = K(II,3)
14799                IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
14800                   KFMOR = K(IDXMOR,2)
14801                   ISMOR = K(IDXMOR,1)
14802                ELSE
14803                   KFMOR = 91
14804                   ISMOR = 1
14805                ENDIF
14806                IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
14807      &             (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
14808                   ID = K(IDXMOR,2)
14809                   MO = IHISMO(PYK(IDXMOR,15))
14810                   PX = PYP(IDXMOR,1)
14811                   PY = PYP(IDXMOR,2)
14812                   PZ = PYP(IDXMOR,3)
14813                   PE = PYP(IDXMOR,4)
14814                   CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14815                   IFLG(IDXMOR) = 1
14816                   MO = NHKK
14817                   DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
14818                      IF (PYK(JDAUG,7).EQ.1) THEN
14819                         ID = PYK(JDAUG,8)
14820                         PX = PYP(JDAUG,1)
14821                         PY = PYP(JDAUG,2)
14822                         PZ = PYP(JDAUG,3)
14823                         PE = PYP(JDAUG,4)
14824                         CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14825                         IF (LEMCCK) THEN
14826                            PX = -PYP(JDAUG,1)
14827                            PY = -PYP(JDAUG,2)
14828                            PZ = -PYP(JDAUG,3)
14829                            PE = -PYP(JDAUG,4)
14830                            CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14831                         ENDIF
14832                         IFLG(JDAUG) = 1
14833                      ENDIF
14834    15             CONTINUE
14835                ELSE
14836 *  there was no mother resonance
14837                   MO = IHISMO(PYK(II,15))
14838                   ID = PYK(II,8)
14839                   PX = PYP(II,1)
14840                   PY = PYP(II,2)
14841                   PZ = PYP(II,3)
14842                   PE = PYP(II,4)
14843                   CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14844                   IF (LEMCCK) THEN
14845                      PX = -PYP(II,1)
14846                      PY = -PYP(II,2)
14847                      PZ = -PYP(II,3)
14848                      PE = -PYP(II,4)
14849                      CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14850                   ENDIF
14851                ENDIF
14852             ENDIF
14853    13    CONTINUE
14854          IF (LEMCCK) THEN
14855             CHKLEV = TINY1
14856             CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
14857 C           IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
14858          ENDIF
14859
14860 * global energy-momentum & flavor conservation check
14861 **sr 16.5. this check is skipped in case of phojet-treatment
14862          IF (MCGENE.EQ.1)
14863      &      CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
14864
14865 * update statistics-counter for diffraction
14866 c        IF (IFLAGD.NE.0) THEN
14867 c           ICDIFF(1) = ICDIFF(1)+1
14868 c           IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
14869 c           IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
14870 c           IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
14871 c           IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
14872 c        ENDIF
14873
14874       ENDIF
14875
14876       RETURN
14877
14878  9999 CONTINUE
14879       IREJ = 1
14880       RETURN
14881       END
14882
14883 *$ CREATE DT_DECAYS.FOR
14884 *COPY DT_DECAYS
14885 *
14886 *===decay==============================================================*
14887 *
14888       SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
14889
14890 ************************************************************************
14891 * Resonance-decay.                                                     *
14892 * This subroutine replaces DDECAY/DECHKK.                              *
14893 *             PIN(4)      4-momentum of resonance          (input)     *
14894 *             IDXIN       BAMJET-index of resonance        (input)     *
14895 *             POUT(20,4)  4-momenta of decay-products      (output)    *
14896 *             IDXOUT(20)  BAMJET-indices of decay-products (output)    *
14897 *             NSEC        number of secondaries            (output)    *
14898 * Adopted from the original version DECHKK.                            *
14899 * This version dated 09.01.95 is written by S. Roesler                 *
14900 ************************************************************************
14901
14902       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14903       SAVE
14904       PARAMETER ( LINP = 10 ,
14905      &            LOUT = 6 ,
14906      &            LDAT = 9 )
14907       PARAMETER (TINY17=1.0D-17)
14908
14909 * HADRIN: decay channel information
14910       PARAMETER (IDMAX9=602)
14911       CHARACTER*8 ZKNAME
14912       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
14913 * particle properties (BAMJET index convention)
14914       CHARACTER*8  ANAME
14915       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
14916      &                IICH(210),IIBAR(210),K1(210),K2(210)
14917 * flags for input different options
14918       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14919       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14920      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14921
14922       DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20),
14923      &          EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3),
14924      &          CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3)
14925
14926 * ISTAB = 1 strong and weak decays
14927 *       = 2 strong decays only
14928 *       = 3 strong decays, weak decays for charmed particles and tau
14929 *           leptons only
14930       DATA ISTAB /2/
14931
14932       IREJ = 0
14933       NSEC = 0
14934 * put initial resonance to stack
14935       NSTK = 1
14936       IDXSTK(NSTK) = IDXIN
14937       DO 5 I=1,4
14938          PI(NSTK,I) = PIN(I)
14939     5 CONTINUE
14940
14941 * store initial configuration for energy-momentum cons. check
14942       IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3),
14943      &                                   PI(NSTK,4),1,IDUM,IDUM)
14944
14945   100 CONTINUE
14946 * get particle from stack
14947       IDXI = IDXSTK(NSTK)
14948 * skip stable particles
14949       IF (ISTAB.EQ.1) THEN
14950          IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10
14951          IF ((IDXI.GE.  1).AND.(IDXI.LE.  7)) GOTO 10
14952       ELSEIF (ISTAB.EQ.2) THEN
14953          IF ((IDXI.GE.  1).AND.(IDXI.LE. 30)) GOTO 10
14954          IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
14955          IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10
14956          IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10
14957          IF ( IDXI.EQ.109)                    GOTO 10
14958          IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10
14959       ELSEIF (ISTAB.EQ.3) THEN
14960          IF ((IDXI.GE.  1).AND.(IDXI.LE. 23)) GOTO 10
14961          IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
14962          IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10
14963          IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10
14964       ENDIF
14965
14966 * calculate direction cosines and Lorentz-parameter of decaying part.
14967       PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2)
14968       PTOT = MAX(PTOT,TINY17)
14969       DO 1 I=1,3
14970          DCOS(I) = PI(NSTK,I)/PTOT
14971     1 CONTINUE
14972       GAM  = PI(NSTK,4)/AAM(IDXI)
14973       BGAM = PTOT/AAM(IDXI)
14974
14975 * get decay-channel
14976       KCHAN = K1(IDXI)-1
14977     2 CONTINUE
14978       KCHAN = KCHAN+1
14979       IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
14980
14981 * identities of secondaries
14982       IDX(1) = NZK(KCHAN,1)
14983       IDX(2) = NZK(KCHAN,2)
14984       IF (IDX(2).LT.1) GOTO 9999
14985       IDX(3) = NZK(KCHAN,3)
14986
14987 * handle decay in rest system of decaying particle
14988       IF (IDX(3).EQ.0) THEN
14989 *   two-particle decay
14990          NDEC = 2
14991          CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2),
14992      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
14993      &               AAM(IDX(1)),AAM(IDX(2)))
14994       ELSE
14995 *   three-particle decay
14996          NDEC = 3
14997          CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3),
14998      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
14999      &               CODF(3),COFF(3),SIFF(3),
15000      &               AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3)))
15001       ENDIF
15002       NSTK = NSTK-1
15003
15004 * transform decay products back
15005       DO 3 I=1,NDEC
15006          NSTK = NSTK+1
15007          CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3),
15008      &               CODF(I),COFF(I),SIFF(I),PF(I),EF(I),
15009      &               PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4))
15010 * add particle to stack
15011          IDXSTK(NSTK) = IDX(I)
15012          DO 4 J=1,3
15013             PI(NSTK,J) = DCOSF(J)*PFF(I)
15014     4    CONTINUE
15015     3 CONTINUE
15016       GOTO 100
15017
15018    10 CONTINUE
15019 * stable particle, put to output-arrays
15020       NSEC = NSEC+1
15021       DO 6 I=1,4
15022          POUT(NSEC,I) = PI(NSTK,I)
15023     6 CONTINUE
15024       IDXOUT(NSEC) = IDXSTK(NSTK)
15025 * store secondaries for energy-momentum conservation check
15026       IF (LEMCCK)
15027      &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
15028      &            -POUT(NSEC,4),2,IDUM,IDUM)
15029       NSTK = NSTK-1
15030       IF (NSTK.GT.0) GOTO 100
15031
15032 * check energy-momentum conservation
15033       IF (LEMCCK) THEN
15034          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
15035          IF (IREJ1.NE.0) GOTO 9999
15036       ENDIF
15037
15038       RETURN
15039
15040  9999 CONTINUE
15041       IREJ = 1
15042       RETURN
15043       END
15044
15045 *$ CREATE DT_DECAY1.FOR
15046 *COPY DT_DECAY1
15047 *
15048 *===decay1=============================================================*
15049 *
15050       SUBROUTINE DT_DECAY1
15051
15052 ************************************************************************
15053 * Decay of resonances stored in DTEVT1.                                *
15054 * This version dated 20.01.95 is written by S. Roesler                 *
15055 ************************************************************************
15056
15057       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15058       SAVE
15059       PARAMETER ( LINP = 10 ,
15060      &            LOUT = 6 ,
15061      &            LDAT = 9 )
15062
15063 * event history
15064       PARAMETER (NMXHKK=200000)
15065       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15066      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15067      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15068 * extended event history
15069       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15070      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15071      &                IHIST(2,NMXHKK)
15072
15073       DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
15074
15075       NEND = NHKK
15076 C     DO 1 I=NPOINT(5),NEND
15077       DO 1 I=NPOINT(4),NEND
15078          IF (ABS(ISTHKK(I)).EQ.1) THEN
15079             DO 2 K=1,4
15080                PIN(K) = PHKK(K,I)
15081     2       CONTINUE
15082             IDXIN = IDBAM(I)
15083             CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15084             IF (NSEC.GT.1) THEN
15085                DO 3 N=1,NSEC
15086                   IDHAD = IDT_IPDGHA(IDXOUT(N))
15087                   CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2),
15088      &                               POUT(N,3),POUT(N,4),0,0,0)
15089     3          CONTINUE
15090             ENDIF
15091          ENDIF
15092     1 CONTINUE
15093
15094       RETURN
15095       END
15096
15097 *$ CREATE DT_DECPI0.FOR
15098 *COPY DT_DECPI0
15099 *
15100 *===decpi0=============================================================*
15101 *
15102       SUBROUTINE DT_DECPI0
15103
15104 ************************************************************************
15105 * Decay of pi0 handled with JETSET.                                    *
15106 * This version dated 18.02.96 is written by S. Roesler                 *
15107 ************************************************************************
15108
15109       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15110       SAVE
15111       PARAMETER ( LINP = 10 ,
15112      &            LOUT = 6 ,
15113      &            LDAT = 9 )
15114       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0)
15115
15116 * event history
15117       PARAMETER (NMXHKK=200000)
15118       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15119      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15120      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15121 * extended event history
15122       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15123      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15124      &                IHIST(2,NMXHKK)
15125       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15126       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15127       PARAMETER (MAXLND=4000)
15128       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15129 * flags for input different options
15130       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15131       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15132      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15133
15134       INTEGER PYCOMP,PYK
15135
15136       DIMENSION IHISMO(NMXHKK),P1(4)
15137
15138       TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
15139
15140       CALL DT_INITJS(2)
15141 * allow pi0 decay
15142       KC = PYCOMP(111)
15143       MDCY(KC,1) = 1
15144
15145       NN  = 0
15146       INI = 0
15147       DO 1 I=1,NHKK
15148          IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
15149             IF (INI.EQ.0) THEN
15150                INI = 1
15151             ELSE
15152                INI = 2
15153             ENDIF
15154             IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15155      &                                    PHKK(4,I),INI,IDUM,IDUM)
15156             PT    = SQRT(PHKK(1,I)**2+PHKK(2,I)**2)
15157             PTOT  = SQRT(PT**2+PHKK(3,I)**2)
15158             COSTH = PHKK(3,I)/(PTOT+TINY10)
15159             IF (COSTH.GT.ONE) THEN
15160                THETA = ZERO
15161             ELSEIF (COSTH.LT.-ONE) THEN
15162                THETA = TWOPI/2.0D0
15163             ELSE
15164                THETA = ACOS(COSTH)
15165             ENDIF
15166             PHI     = ASIN(PHKK(2,I)/(PT  +TINY10))
15167             IF (PHKK(1,I).LT.0.0D0)
15168      &         PHI  = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
15169             ENER    = PHKK(4,I)
15170             NN      = NN+1
15171             KTEMP   = MSTU(10)
15172             MSTU(10)= 1
15173             P(NN,5) = PHKK(5,I)
15174             CALL PY1ENT(NN,111,ENER,THETA,PHI)
15175             MSTU(10)  = KTEMP
15176             IHISMO(NN)= I
15177          ENDIF
15178     1 CONTINUE
15179       IF (NN.GT.0) THEN
15180          CALL PYEXEC
15181          NLINES = PYK(0,1)
15182          DO 2 II=1,NLINES
15183             IF (PYK(II,7).EQ.1) THEN
15184                DO 3 KK=1,4
15185                   P1(KK) = PYP(II,KK)
15186     3          CONTINUE
15187                ID = PYK(II,8)
15188                MO = IHISMO(PYK(II,15))
15189                CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
15190                IF (LEMCCK)
15191      &            CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
15192      &                                            IDUM,IDUM)
15193 *sr: flag with neg. sign (for HELIOS p/A-W jobs)
15194                ISTHKK(MO) = -2
15195             ENDIF
15196     2    CONTINUE
15197          IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
15198       ENDIF
15199       MDCY(KC,1) = 0
15200
15201       RETURN
15202       END
15203
15204 *$ CREATE DT_DTWOPD.FOR
15205 *COPY DT_DTWOPD
15206 *
15207 *===dtwopd=============================================================*
15208 *
15209       SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
15210      &                                            COF2,SIF2,AM1,AM2)
15211
15212 ************************************************************************
15213 * Two-particle decay.                                                  *
15214 *  UMO                 cm-energy of the decaying system       (input)  *
15215 *  AM1/AM2             masses of the decay products           (input)  *
15216 *  ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) *
15217 *  COD,COF,SIF         direction cosines of the decay prod.   (output) *
15218 * Revised by S. Roesler, 20.11.95                                      *
15219 ************************************************************************
15220
15221       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15222       SAVE
15223       PARAMETER ( LINP = 10 ,
15224      &            LOUT = 6 ,
15225      &            LDAT = 9 )
15226       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
15227
15228       IF (UMO.LT.(AM1+AM2)) THEN
15229          WRITE(LOUT,1000) UMO,AM1,AM2
15230  1000    FORMAT(1X,'DTWOPD:    inconsistent kinematics - UMO,AM1,AM2 ',
15231      &          3E12.3)
15232          STOP
15233       ENDIF
15234
15235       ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
15236       ECM2 = UMO-ECM1
15237       PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
15238       PCM2 = PCM1
15239       CALL DT_DSFECF(SIF1,COF1)
15240       COD1 = TWO*DT_RNDM(PCM2)-ONE
15241       COD2 = -COD1
15242       COF2 = -COF1
15243       SIF2 = -SIF1
15244
15245       RETURN
15246       END
15247
15248 *$ CREATE DT_DTHREP.FOR
15249 *COPY DT_DTHREP
15250 *
15251 *===dthrep=============================================================*
15252 *
15253       SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
15254      &                  SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
15255
15256 ************************************************************************
15257 * Three-particle decay.                                                *
15258 *  UMO                 cm-energy of the decaying system       (input)  *
15259 *  AM1/2/3             masses of the decay products           (input)  *
15260 *  ECM1/2/2,PCM1/2/3   cm-energies/momenta of the decay prod. (output) *
15261 *  COD,COF,SIF         direction cosines of the decay prod.   (output) *
15262 *                                                                      *
15263 * Threpd89: slight revision by A. Ferrari                              *
15264 * Last change on   11-oct-93   by    Alfredo Ferrari, INFN - Milan     *
15265 * Revised by S. Roesler, 20.11.95                                      *
15266 ************************************************************************
15267
15268       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15269       SAVE
15270       PARAMETER ( LINP = 10 ,
15271      &            LOUT = 6 ,
15272      &            LDAT = 9 )
15273
15274       PARAMETER ( ANGLSQ = 2.5D-31 )
15275       PARAMETER ( AZRZRZ = 1.0D-30 )
15276       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
15277       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
15278       PARAMETER ( ONEONE = 1.D+00 )
15279       PARAMETER ( TWOTWO = 2.D+00 )
15280       PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
15281
15282       COMMON /HNGAMR/ REDU,AMO,AMM(15)
15283 * flags for input different options
15284       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15285       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15286      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15287
15288       DIMENSION F(5),XX(5)
15289       DATA EPS /AZRZRZ/
15290
15291       UMOO=UMO+UMO
15292 C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
15293 C***J. VON NEUMANN - RANDOM - SELECTION OF S2
15294 C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
15295       UUMO=UMO
15296       AAM1=AM1
15297       AAM2=AM2
15298       AAM3=AM3
15299       GU=(AM2+AM3)**2
15300       GO=(UMO-AM1)**2
15301 *     UFAK=1.0000000000001D0
15302 *     IF (GU.GT.GO) UFAK=0.9999999999999D0
15303       IF (GU.GT.GO) THEN
15304          UFAK=ONEMNS
15305       ELSE
15306          UFAK=ONEPLS
15307       END IF
15308       OFAK=2.D0-UFAK
15309       GU=GU*UFAK
15310       GO=GO*OFAK
15311       DS2=(GO-GU)/99.D0
15312       AM11=AM1*AM1
15313       AM22=AM2*AM2
15314       AM33=AM3*AM3
15315       UMO2=UMO*UMO
15316       RHO2=0.D0
15317       S22=GU
15318       DO 124 I=1,100
15319          S21=S22
15320          S22=GU+(I-1.D0)*DS2
15321          RHO1=RHO2
15322          RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
15323      *                                             (S22+EPS)
15324          IF(RHO2.LT.RHO1) GO TO 125
15325   124 CONTINUE
15326   125 S2SUP=(S22-S21)*.5D0+S21
15327       SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
15328      *                                           (S2SUP+EPS)
15329       SUPRHO=SUPRHO*1.05D0
15330       XO=S21-DS2
15331       IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
15332       IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
15333       XX(1)=XO
15334       XX(3)=S22
15335       X1=(XO+S22)*0.5D0
15336       XX(2)=X1
15337       F(3)=RHO2
15338       F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS)
15339       F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS)
15340       DO 126 I=1,16
15341          X4=(XX(1)+XX(2))*0.5D0
15342          X5=(XX(2)+XX(3))*0.5D0
15343          F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/
15344      *                                               (X4+EPS)
15345          F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
15346      *                                               (X5+EPS)
15347          XX(4)=X4
15348          XX(5)=X5
15349          DO 128 II=1,5
15350             IA=II
15351             DO 128 III=IA,5
15352                IF (F (II).GE.F (III)) GO TO 128
15353                FH=F(II)
15354                F(II)=F(III)
15355                F(III)=FH
15356                FH=XX(II)
15357                XX(II)=XX(III)
15358                XX(III)=FH
15359 128      CONTINUE
15360          SUPRHO=F(1)
15361          S2SUP=XX(1)
15362          DO 129 II=1,3
15363             IA=II
15364             DO 129 III=IA,3
15365                IF (XX(II).GE.XX(III)) GO TO 129
15366                FH=F(II)
15367                F(II)=F(III)
15368                F(III)=FH
15369                FH=XX(II)
15370                XX(II)=XX(III)
15371                XX(III)=FH
15372 129      CONTINUE
15373 126   CONTINUE
15374       AM23=(AM2+AM3)**2
15375       ITH=0
15376       REDU=2.D0
15377     1 CONTINUE
15378       ITH=ITH+1
15379       IF (ITH.GT.200) REDU=-9.D0
15380       IF (ITH.GT.200) GO TO 400
15381       C=DT_RNDM(REDU)
15382 *     S2=AM23+C*((UMO-AM1)**2-AM23)
15383       S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
15384       Y=DT_RNDM(S2)
15385       Y=Y*SUPRHO
15386       RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
15387       IF(Y.GT.RHO) GO TO 1
15388 C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
15389       S1=DT_RNDM(S2)
15390       S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
15391      &RHO*.5D0
15392       S3=UMO2+AM11+AM22+AM33-S1-S2
15393       ECM1=(UMO2+AM11-S2)/UMOO
15394       ECM2=(UMO2+AM22-S3)/UMOO
15395       ECM3=(UMO2+AM33-S1)/UMOO
15396       PCM1=SQRT((ECM1+AM1)*(ECM1-AM1))
15397       PCM2=SQRT((ECM2+AM2)*(ECM2-AM2))
15398       PCM3=SQRT((ECM3+AM3)*(ECM3-AM3))
15399       CALL DT_DSFECF(SFE,CFE)
15400 C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
15401 C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
15402       PCM12 = PCM1 * PCM2
15403       IF ( PCM12 .LT. ANGLSQ ) GO TO 200
15404       COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12
15405       GO TO 300
15406  200  CONTINUE
15407          UW=DT_RNDM(S1)
15408          COSTH=(UW-0.5D+00)*2.D+00
15409  300  CONTINUE
15410 *     IF(ABS(COSTH).GT.0.9999999999999999D0)
15411 *    &COSTH=SIGN(0.9999999999999999D0,COSTH)
15412       IF(ABS(COSTH).GT.ONEONE)
15413      &COSTH=SIGN(ONEONE,COSTH)
15414       IF (REDU.LT.1.D+00) RETURN
15415       COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3)
15416 *     IF(ABS(COSTH2).GT.0.9999999999999999D0)
15417 *    &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
15418       IF(ABS(COSTH2).GT.ONEONE)
15419      &COSTH2=SIGN(ONEONE,COSTH2)
15420       SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2))
15421       SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH))
15422       SINTH1=COSTH2*SINTH-COSTH*SINTH2
15423       COSTH1=COSTH*COSTH2+SINTH2*SINTH
15424 C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
15425 C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
15426 C***THE DIRECTION OF PARTICLE 3
15427 C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
15428       CX11=-COSTH1
15429       CY11=SINTH1*CFE
15430       CZ11=SINTH1*SFE
15431       CX22=-COSTH2
15432       CY22=-SINTH2*CFE
15433       CZ22=-SINTH2*SFE
15434       CALL DT_DSFECF(SIF3,COF3)
15435       COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
15436       SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
15437     2 FORMAT(5F20.15)
15438       COD1=CX11*COD3+CZ11*SID3
15439       CHLP=(ONEONE-COD1)*(ONEONE+COD1)
15440       IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3,
15441      &CX11,CZ11
15442       SID1=SQRT(CHLP)
15443       COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1
15444       SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1
15445       COD2=CX22*COD3+CZ22*SID3
15446       SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2))
15447       COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2
15448       SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2
15449  400  CONTINUE
15450 * === Energy conservation check: === *
15451       EOCHCK = UMO - ECM1 - ECM2 - ECM3
15452 *     SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
15453 *     SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
15454 *     SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
15455       PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3
15456       PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2
15457      &       + PCM3 * COF3 * SID3
15458       PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2
15459      &       + PCM3 * SIF3 * SID3
15460       EOCMPR = 1.D-12 * UMO
15461       IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK)
15462      &     .GT. EOCMPR ) THEN
15463 **sr 5.5.95 output-unit changed
15464          IF (IOULEV(1).GT.0) THEN
15465             WRITE(LOUT,*)
15466      &      ' *** Threpd: energy/momentum conservation failure! ***',
15467      &      EOCHCK,PXCHCK,PYCHCK,PZCHCK
15468             WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
15469          ENDIF
15470 **
15471       END IF
15472       RETURN
15473       END
15474
15475 *$ CREATE DT_DBKLAS.FOR
15476 *COPY DT_DBKLAS
15477 *
15478 *===dbklas=============================================================*
15479 *
15480       SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
15481
15482       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15483       SAVE
15484       PARAMETER ( LINP = 10 ,
15485      &            LOUT = 6 ,
15486      &            LDAT = 9 )
15487
15488 * quark-content to particle index conversion (DTUNUC 1.x)
15489       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15490      &                IA08(6,21),IA10(6,21)
15491
15492       IF (I) 20,20,10
15493 * baryons
15494    10 CONTINUE
15495       CALL DT_INDEXD(J,K,IND)
15496       I8  = IB08(I,IND)
15497       I10 = IB10(I,IND)
15498       IF (I8.LE.0) I8 = I10
15499       RETURN
15500 * antibaryons
15501    20 CONTINUE
15502       II = IABS(I)
15503       JJ = IABS(J)
15504       KK = IABS(K)
15505       CALL DT_INDEXD(JJ,KK,IND)
15506       I8  = IA08(II,IND)
15507       I10 = IA10(II,IND)
15508       IF (I8.LE.0) I8 = I10
15509
15510       RETURN
15511       END
15512
15513 *$ CREATE DT_INDEXD.FOR
15514 *COPY DT_INDEXD
15515 *
15516 *===indexd=============================================================*
15517 *
15518       SUBROUTINE DT_INDEXD(KA,KB,IND)
15519
15520       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15521       SAVE
15522       PARAMETER ( LINP = 10 ,
15523      &            LOUT = 6 ,
15524      &            LDAT = 9 )
15525
15526       KP = KA*KB
15527       KS = KA+KB
15528       IF (KP.EQ.1) IND=1
15529       IF (KP.EQ.2) IND=2
15530       IF (KP.EQ.3) IND=3
15531       IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
15532       IF (KP.EQ.5) IND=5
15533       IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6
15534       IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7
15535       IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8
15536       IF (KP.EQ.8)  IND=9
15537       IF (KP.EQ.10) IND=10
15538       IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11
15539       IF (KP.EQ.9)  IND=12
15540       IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13
15541       IF (KP.EQ.15) IND=14
15542       IF (KP.EQ.18) IND=15
15543       IF (KP.EQ.16) IND=16
15544       IF (KP.EQ.20) IND=17
15545       IF (KP.EQ.24) IND=18
15546       IF (KP.EQ.25) IND=19
15547       IF (KP.EQ.30) IND=20
15548       IF (KP.EQ.36) IND=21
15549
15550       RETURN
15551       END
15552
15553 *$ CREATE DT_DCHANT.FOR
15554 *COPY DT_DCHANT
15555 *
15556 *===dchant=============================================================*
15557 *
15558       SUBROUTINE DT_DCHANT
15559
15560       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15561       SAVE
15562       PARAMETER ( LINP = 10 ,
15563      &            LOUT = 6 ,
15564      &            LDAT = 9 )
15565       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15566
15567 * HADRIN: decay channel information
15568       PARAMETER (IDMAX9=602)
15569       CHARACTER*8 ZKNAME
15570       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15571 * particle properties (BAMJET index convention)
15572       CHARACTER*8  ANAME
15573       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15574      &                IICH(210),IIBAR(210),K1(210),K2(210)
15575
15576       DIMENSION HWT(IDMAX9)
15577
15578 * change of weights wt from absolut values into the sum of wt of a dec.
15579       DO 10 J=1,IDMAX9
15580          HWT(J) = ZERO
15581    10 CONTINUE
15582 C     DO 999 KKK=1,210
15583 C        WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
15584 C    &      ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
15585 C    &      K1(KKK),K2(KKK)
15586 C 999 CONTINUE
15587 C     STOP
15588       DO 30 I=1,210
15589          IK1 = K1(I)
15590          IK2 = K2(I)
15591          HV  = ZERO
15592          DO 20 J=IK1,IK2
15593             HV     = HV+WT(J)
15594             HWT(J) = HV
15595 **sr 13.1.95
15596             IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1
15597  1000       FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
15598    20    CONTINUE
15599    30 CONTINUE
15600       DO 40 J=1,IDMAX9
15601          WT(J) = HWT(J)
15602    40 CONTINUE
15603
15604       RETURN
15605       END
15606
15607 *$ CREATE DT_DDATAR.FOR
15608 *COPY DT_DDATAR
15609 *
15610 *===ddatar=============================================================*
15611 *
15612       SUBROUTINE DT_DDATAR
15613
15614       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15615       SAVE
15616       PARAMETER ( LINP = 10 ,
15617      &            LOUT = 6 ,
15618      &            LDAT = 9 )
15619       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15620
15621 * quark-content to particle index conversion (DTUNUC 1.x)
15622       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15623      &                IA08(6,21),IA10(6,21)
15624
15625       DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
15626
15627       DATA IV/ 33, 34, 38,123,  0,  0, 32, 33, 39,124,
15628      &          0,  0, 36, 37, 96,127,  0,  0,126,125,
15629      &        128,129,14*0/
15630       DATA IP/ 23, 14, 16,116,  0,  0, 13, 23, 25,117,
15631      &          0,  0, 15, 24, 31,120,  0,  0,119,118,
15632      &        121,122,14*0/
15633       DATA IB/  0,  1, 21,140,  0,  0,  8, 22,137,  0,
15634      &          0, 97,138,  0,  0,146,  0,  0,  0,  0,
15635      &          0,  1,  8, 22,137,  0,  0,  0, 20,142,
15636      &          0,  0, 98,139,  0,  0,147,  0,  0,  0,
15637      &          0,  0, 21, 22, 97,138,  0,  0, 20, 98,
15638      &        139,  0,  0,  0,145,  0,  0,148,  0,  0,
15639      &          0,  0,  0,140,137,138,146,  0,  0,142,
15640      &        139,147,  0,  0,145,148,           50*0/
15641       DATA IBB/53, 54,104,161,  0,  0, 55,105,162,  0,
15642      &          0,107,164,  0,  0,167,  0,  0,  0,  0,
15643      &          0, 54, 55,105,162,  0,  0, 56,106,163,
15644      &          0,  0,108,165,  0,  0,168,  0,  0,  0,
15645      &          0,  0,104,105,107,164,  0,  0,106,108,
15646      &        165,  0,  0,109,166,  0,  0,169,  0,  0,
15647      &          0,  0,  0,161,162,164,167,  0,  0,163,
15648      &        165,168,  0,  0,166,169,  0,  0,170,47*0/
15649       DATA IA/  0,  2, 99,152,  0,  0,  9,100,149,  0,
15650      &          0,102,150,  0,  0,158,  0,  0,  0,  0,
15651      &          0,  2,  9,100,149,  0,  0,  0,101,154,
15652      &          0,  0,103,151,  0,  0,159,  0,  0,  0,
15653      &          0,  0, 99,100,102,150,  0,  0,101,103,
15654      &        151,  0,  0,  0,157,  0,  0,160,  0,  0,
15655      &          0,  0,  0,152,149,150,158,  0,  0,154,
15656      &        151,159,  0,  0,157,160,           50*0/
15657       DATA IAA/67, 68,110,171,  0,  0, 69,111,172,  0,
15658      &          0,113,174,  0,  0,177,  0,  0,  0,  0,
15659      &          0, 68, 69,111,172,  0,  0, 70,112,173,
15660      &          0,  0,114,175,  0,  0,178,  0,  0,  0,
15661      &          0,  0,110,111,113,174,  0,  0,112,114,
15662      &        175,  0,  0,115,176,  0,  0,179,  0,  0,
15663      &          0,  0,  0,171,172,174,177,  0,  0,173,
15664      &        175,178,  0,  0,176,179,  0,  0,180,47*0/
15665
15666       L=0
15667       DO 2 I=1,6
15668          DO 1 J=1,6
15669             L = L+1
15670             IMPS(I,J) = IP(L)
15671             IMVE(I,J) = IV(L)
15672     1    CONTINUE
15673     2 CONTINUE
15674       L=0
15675       DO 4 I=1,6
15676          DO 3 J=1,21
15677             L = L+1
15678             IB08(I,J) = IB(L)
15679             IB10(I,J) = IBB(L)
15680             IA08(I,J) = IA(L)
15681             IA10(I,J) = IAA(L)
15682     3    CONTINUE
15683     4 CONTINUE
15684 C     A1  = 0.88D0
15685 C     B1  = 3.0D0
15686 C     B2  = 3.0D0
15687 C     B3  = 8.0D0
15688 C     LT  = 0
15689 C     LB  = 0
15690 C     BET = 12.0D0
15691 C     AS  = 0.25D0
15692 C     B8  = 0.33D0
15693 C     AME = 0.95D0
15694 C     DIQ = 0.375D0
15695 C     ISU = 4
15696
15697       RETURN
15698       END
15699
15700 *$ CREATE DT_INITJS.FOR
15701 *COPY DT_INITJS
15702 *
15703 *===initjs=============================================================*
15704 *
15705       SUBROUTINE DT_INITJS(MODE)
15706
15707 ************************************************************************
15708 * Initialize JETSET paramters.                                         *
15709 *           MODE = 0 default settings                                  *
15710 *                = 1 PHOJET settings                                   *
15711 *                = 2 DTUNUC settings                                   *
15712 * This version dated 16.02.96 is written by S. Roesler                 *
15713 *                                                                      *
15714 * Last change 27.12.2006 by S. Roesler.                                *
15715 ************************************************************************
15716
15717       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15718       SAVE
15719       PARAMETER ( LINP = 10 ,
15720      &            LOUT = 6 ,
15721      &            LDAT = 9 )
15722       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15723
15724       LOGICAL LFIRST,LFIRDT,LFIRPH
15725
15726       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15727       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15728       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15729 * flags for particle decays
15730       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
15731      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
15732      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
15733 * flags for input different options
15734       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15735       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15736      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15737
15738       INTEGER PYCOMP
15739
15740       DIMENSION IDXSTA(40)
15741       DATA IDXSTA
15742 *          K0s   pi0  lam   alam  sig+  asig+ sig-  asig- tet0  atet0
15743      &  /  310,  111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322,
15744 *          tet- atet-  om-  aom-   D+    D-    D0    aD0   Ds+   aDs+
15745      &    3312,-3312, 3334,-3334,  411, -411,  421, -421,  431, -431,
15746 *          etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+
15747      &     441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232,
15748 *         Ksic0 aKsic+aKsic0 sig0 asig0
15749      &    4132,-4232,-4132, 3212,-3212, 5*0/
15750
15751       DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
15752
15753       IF (LFIRST) THEN
15754 * save default settings
15755          PDEF1  = PARJ(1)
15756          PDEF2  = PARJ(2)
15757          PDEF3  = PARJ(3)
15758          PDEF5  = PARJ(5)
15759          PDEF6  = PARJ(6)
15760          PDEF7  = PARJ(7)
15761          PDEF18 = PARJ(18)
15762          PDEF19 = PARJ(19)
15763          PDEF21 = PARJ(21)
15764          PDEF42 = PARJ(42)
15765          MDEF12 = MSTJ(12)
15766 * LUJETS / PYJETS array-dimensions
15767          MSTU(4) = 4000
15768 * increase maximum number of JETSET-error prints
15769          MSTU(22) = 50000
15770 * prevent particles decaying
15771          DO 1 I=1,35
15772             IF (I.LT.34) THEN
15773                KC = PYCOMP(IDXSTA(I))
15774                IF (KC.GT.0) THEN
15775                   IF (I.EQ.2) THEN
15776 *  pi0 decay
15777 C                    MDCY(KC,1) = 1
15778                      MDCY(KC,1) = 0
15779 **cr mode
15780 C                 ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
15781 C   &                    (I.EQ.8).OR.(I.EQ.10)) THEN
15782 C                 ELSEIF (I.EQ.4) THEN
15783 C                    MDCY(KC,1) = 1
15784 **
15785                   ELSE
15786 C AM                     MDCY(KC,1) = 0
15787                   ENDIF
15788                ENDIF
15789             ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
15790                KC = PYCOMP(IDXSTA(I))
15791                IF (KC.GT.0) THEN
15792 C AM                 MDCY(KC,1) = 0
15793                ENDIF
15794             ENDIF
15795     1    CONTINUE
15796 *
15797 *
15798 * popcorn:
15799          IF (PDB.LE.ZERO) THEN
15800 *   no popcorn-mechanism
15801             MSTJ(12) = 1
15802          ELSE
15803             MSTJ(12) = 3
15804             PARJ(5)  = PDB
15805          ENDIF
15806 * set JETSET-parameter requested by input cards
15807          IF (NMSTU.GT.0) THEN
15808             DO 2 I=1,NMSTU
15809                MSTU(IMSTU(I)) = MSTUX(I)
15810     2       CONTINUE
15811          ENDIF
15812          IF (NMSTJ.GT.0) THEN
15813             DO 3 I=1,NMSTJ
15814                MSTJ(IMSTJ(I)) = MSTJX(I)
15815     3       CONTINUE
15816          ENDIF
15817          IF (NPARU.GT.0) THEN
15818             DO 4 I=1,NPARU
15819                PARU(IPARU(I)) = PARUX(I)
15820     4       CONTINUE
15821          ENDIF
15822          LFIRST = .FALSE.
15823       ENDIF
15824 *
15825 * PARJ(1)  suppression of qq-aqaq pair prod. compared to
15826 *          q-aq pair prod.                      (default: 0.1)
15827 * PARJ(2)  strangeness suppression               (default: 0.3)
15828 * PARJ(3)  extra suppression of strange diquarks (default: 0.4)
15829 * PARJ(6)  extra suppression of sas-pair shared by B and
15830 *          aB in BMaB                           (default: 0.5)
15831 * PARJ(7)  extra suppression of strange meson M in BMaB
15832 *          configuration                        (default: 0.5)
15833 * PARJ(18) spin 3/2 baryon suppression           (default: 1.0)
15834 * PARJ(21) width sigma in Gaussian p_x, p_y transverse
15835 *          momentum distrib. for prim. hadrons  (default: 0.35)
15836 * PARJ(42) b-parameter for symmetric Lund-fragmentation
15837 *          function                             (default: 0.9 GeV^-2)
15838 *
15839 * PHOJET settings
15840       IF (MODE.EQ.1) THEN
15841 *   JETSET default
15842 C        PARJ(1)  = PDEF1
15843 C        PARJ(2)  = PDEF2
15844 C        PARJ(3)  = PDEF3
15845 C        PARJ(6)  = PDEF6
15846 C        PARJ(7)  = PDEF7
15847 C        PARJ(18) = PDEF18
15848 C        PARJ(21) = PDEF21
15849 C        PARJ(42) = PDEF42
15850 **sr 18.11.98 parameter tuning
15851 C        PARJ(1)  = 0.092D0
15852 C        PARJ(2)  = 0.25D0
15853 C        PARJ(3)  = 0.45D0
15854 C        PARJ(19) = 0.3D0
15855 C        PARJ(21) = 0.45D0
15856 C        PARJ(42) = 1.0D0
15857 **sr 28.04.99 parameter tuning (May 99 minor modifications)
15858          PARJ(1)  = 0.085D0
15859          PARJ(2)  = 0.26D0
15860          PARJ(3)  = 0.8D0
15861          PARJ(11) = 0.38D0
15862          PARJ(18) = 0.3D0
15863          PARJ(19) = 0.4D0
15864          PARJ(21) = 0.36D0
15865          PARJ(41) = 0.3D0
15866          PARJ(42) = 0.86D0
15867          IF (NPARJ.GT.0) THEN
15868             DO 10 I=1,NPARJ
15869                IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
15870    10       CONTINUE
15871          ENDIF
15872          IF (LFIRPH) THEN
15873             WRITE(LOUT,'(1X,A)')
15874      &         'DT_INITJS: JETSET-parameter for PHOJET'
15875             CALL DT_JSPARA(0)
15876             LFIRPH = .FALSE.
15877          ENDIF
15878 * DTUNUC settings
15879       ELSEIF (MODE.EQ.2) THEN
15880          IF (IFRAG(2).EQ.1) THEN
15881 **sr parameters before 9.3.96
15882 C           PARJ(2)  = 0.27D0
15883 C           PARJ(3)  = 0.6D0
15884 C           PARJ(6)  = 0.75D0
15885 C           PARJ(7)  = 0.75D0
15886 C           PARJ(21) = 0.55D0
15887 C           PARJ(42) = 1.3D0
15888 **sr 18.11.98 parameter tuning
15889 C           PARJ(1)  = 0.05D0
15890 C           PARJ(2)  = 0.27D0
15891 C           PARJ(3)  = 0.4D0
15892 C           PARJ(19) = 0.2D0
15893 C           PARJ(21) = 0.45D0
15894 C           PARJ(42) = 1.0D0
15895 **sr 28.04.99 parameter tuning
15896             PARJ(1)  = 0.11D0
15897             PARJ(2)  = 0.36D0
15898             PARJ(3)  = 0.8D0
15899             PARJ(19) = 0.2D0
15900             PARJ(21) = 0.3D0
15901             PARJ(41) = 0.3D0
15902             PARJ(42) = 0.58D0
15903             IF (NPARJ.GT.0) THEN
15904                DO 20 I=1,NPARJ
15905                   IF (IPARJ(I).LT.0) THEN
15906                      IDX = ABS(IPARJ(I))
15907                      PARJ(IDX) = PARJX(I)
15908                   ENDIF
15909    20          CONTINUE
15910             ENDIF
15911             IF (LFIRDT) THEN
15912                WRITE(LOUT,'(1X,A)')
15913      &           'DT_INITJS: JETSET-parameter for DTUNUC'
15914                CALL DT_JSPARA(0)
15915                LFIRDT = .FALSE.
15916             ENDIF
15917          ELSEIF (IFRAG(2).EQ.2) THEN
15918             PARJ(1)  = 0.11D0
15919             PARJ(2)  = 0.27D0
15920             PARJ(3)  = 0.3D0
15921             PARJ(6)  = 0.35D0
15922             PARJ(7)  = 0.45D0
15923             PARJ(18) = 0.66D0
15924 C           PARJ(21) = 0.55D0
15925 C           PARJ(42) = 1.0D0
15926             PARJ(21) = 0.60D0
15927             PARJ(42) = 1.3D0
15928          ELSE
15929             PARJ(1)  = PDEF1
15930             PARJ(2)  = PDEF2
15931             PARJ(3)  = PDEF3
15932             PARJ(6)  = PDEF6
15933             PARJ(7)  = PDEF7
15934             PARJ(18) = PDEF18
15935             PARJ(21) = PDEF21
15936             PARJ(42) = PDEF42
15937          ENDIF
15938       ELSE
15939          PARJ(1)  = PDEF1
15940          PARJ(2)  = PDEF2
15941          PARJ(3)  = PDEF3
15942          PARJ(5)  = PDEF5
15943          PARJ(6)  = PDEF6
15944          PARJ(7)  = PDEF7
15945          PARJ(18) = PDEF18
15946          PARJ(19) = PDEF19
15947          PARJ(21) = PDEF21
15948          PARJ(42) = PDEF42
15949          MSTJ(12) = MDEF12
15950       ENDIF
15951
15952       RETURN
15953       END
15954
15955 *$ CREATE DT_JSPARA.FOR
15956 *COPY DT_JSPARA
15957 *
15958 *===jspara=============================================================*
15959 *
15960       SUBROUTINE DT_JSPARA(MODE)
15961
15962       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15963       SAVE
15964       PARAMETER ( LINP = 10 ,
15965      &            LOUT = 6 ,
15966      &            LDAT = 9 )
15967       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
15968      &           ONE=1.0D0,ZERO=0.0D0)
15969
15970       LOGICAL LFIRST
15971
15972       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15973
15974       DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
15975
15976       DATA LFIRST /.TRUE./
15977
15978 * save the default JETSET-parameter on the first call
15979       IF (LFIRST) THEN
15980          DO 1 I=1,200
15981             ISTU(I) = MSTU(I)
15982             QARU(I) = PARU(I)
15983             ISTJ(I) = MSTJ(I)
15984             QARJ(I) = PARJ(I)
15985     1    CONTINUE
15986          LFIRST = .FALSE.
15987       ENDIF
15988
15989       WRITE(LOUT,1000)
15990  1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
15991
15992 * compare the default JETSET-parameter with the present values
15993       DO 2 I=1,200
15994          IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
15995             WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
15996 C           ISTU(I) = MSTU(I)
15997          ENDIF
15998          DIFF = ABS(PARU(I)-QARU(I))
15999          IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
16000             WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
16001 C           QARU(I) = PARU(I)
16002          ENDIF
16003          IF (MSTJ(I).NE.ISTJ(I)) THEN
16004             WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
16005 C           ISTJ(I) = MSTJ(I)
16006          ENDIF
16007          DIFF = ABS(PARJ(I)-QARJ(I))
16008          IF (DIFF.GE.1.0D-5) THEN
16009             WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
16010 C           QARJ(I) = PARJ(I)
16011          ENDIF
16012     2 CONTINUE
16013  1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
16014  1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
16015
16016       RETURN
16017       END
16018
16019 *$ CREATE DT_FOZOCA.FOR
16020 *COPY DT_FOZOCA
16021 *
16022 *===fozoca=============================================================*
16023 *
16024       SUBROUTINE DT_FOZOCA(LFZC,IREJ)
16025
16026 ************************************************************************
16027 * This subroutine treats the complete FOrmation ZOne supressed intra-  *
16028 * nuclear CAscade.                                                     *
16029 *               LFZC = .true.  cascade has been treated                *
16030 *                    = .false. cascade skipped                         *
16031 * This is a completely revised version of the original FOZOKL.         *
16032 * This version dated 18.11.95 is written by S. Roesler                 *
16033 ************************************************************************
16034
16035       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16036       SAVE
16037       PARAMETER ( LINP = 10 ,
16038      &            LOUT = 6 ,
16039      &            LDAT = 9 )
16040       PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
16041       PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16042
16043       LOGICAL LSTART,LCAS,LFZC
16044
16045 * event history
16046       PARAMETER (NMXHKK=200000)
16047       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16048      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16049      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16050 * extended event history
16051       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16052      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16053      &                IHIST(2,NMXHKK)
16054 * rejection counter
16055       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
16056      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
16057      &                IREXCI(3),IRDIFF(2),IRINC
16058 * properties of interacting particles
16059       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
16060 * Glauber formalism: collision properties
16061       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16062      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16063 * flags for input different options
16064       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16065       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16066      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16067 * final state after intranuclear cascade step
16068       COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16069 * parameter for intranuclear cascade
16070       LOGICAL LPAULI
16071       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16072
16073       DIMENSION NCWOUN(2)
16074
16075       DATA LSTART /.TRUE./
16076
16077       LFZC = .TRUE.
16078       IREJ = 0
16079
16080 * skip cascade if hadron-hadron interaction or if supressed by user
16081       IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999
16082 * skip cascade if not all possible chains systems are hadronized
16083       DO 1 I=1,8
16084          IF (.NOT.LHADRO(I)) GOTO 9999
16085     1 CONTINUE
16086
16087       IF (LSTART) THEN
16088          WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD
16089  1000    FORMAT(/,1X,'FOZOCA:  intranuclear cascade treated for a ',
16090      &          'maximum of',I4,' generations',/,10X,'formation time ',
16091      &          'parameter:',F5.1,'  fm/c',9X,'modus:',I2)
16092          IF (ITAUVE.EQ.1) WRITE(LOUT,1001)
16093          IF (ITAUVE.EQ.2) WRITE(LOUT,1002)
16094  1001    FORMAT(10X,'p_t dependent formation zone',/)
16095  1002    FORMAT(10X,'constant formation zone',/)
16096          LSTART = .FALSE.
16097       ENDIF
16098
16099 * in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons
16100 * which may interact with final state particles are stored in a seperate
16101 * array - here all proj./target nucleon-indices (just for simplicity)
16102       NOINC = 0
16103       DO 9 I=1,NPOINT(1)-1
16104          NOINC = NOINC+1
16105          IDXINC(NOINC) = I
16106     9 CONTINUE
16107
16108 * initialize Pauli-principle treatment (find wounded nucleons)
16109       NWOUND(1) = 0
16110       NWOUND(2) = 0
16111       NCWOUN(1) = 0
16112       NCWOUN(2) = 0
16113       DO 2 J=1,NPOINT(1)
16114          DO 3 I=1,2
16115             IF (ISTHKK(J).EQ.10+I) THEN
16116                NWOUND(I) = NWOUND(I)+1
16117                EWOUND(I,NWOUND(I)) = PHKK(4,J)
16118                IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1
16119             ENDIF
16120     3    CONTINUE
16121     2 CONTINUE
16122
16123 * modify nuclear potential for wounded nucleons
16124       IPRCL  = IP -NWOUND(1)
16125       IPZRCL = IPZ-NCWOUN(1)
16126       ITRCL  = IT -NWOUND(2)
16127       ITZRCL = ITZ-NCWOUN(2)
16128       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
16129
16130       NSTART = NPOINT(4)
16131       NEND   = NHKK
16132
16133     7 CONTINUE
16134       DO 8 I=NSTART,NEND
16135
16136          IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
16137 * select nucleus the cascade starts first (proj. - 1, target - -1)
16138             NCAS   = 1
16139 *   projectile/target with probab. 1/2
16140             IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN
16141                IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16142 *   in the nucleus with highest mass
16143             ELSEIF (INCMOD.EQ.2) THEN
16144                IF (IP.GT.IT) THEN
16145                   NCAS = -NCAS
16146                ELSEIF (IP.EQ.IT) THEN
16147                   IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16148                ENDIF
16149 * the nucleus the cascade starts first is requested to be the one
16150 * moving in the direction of the secondary
16151             ELSEIF (INCMOD.EQ.3) THEN
16152                NCAS = INT(SIGN(1.0D0,PHKK(3,I)))
16153             ENDIF
16154 * check that the selected "nucleus" is not a hadron
16155             IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR.
16156      &          ((NCAS.EQ.-1).AND.(IT.LE.1)))    NCAS = -NCAS
16157
16158 * treat intranuclear cascade in the nucleus selected first
16159             LCAS = .FALSE.
16160             CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16161             IF (IREJ1.NE.0) GOTO 9998
16162 * treat intranuclear cascade in the other nucleus if this isn't a had.
16163             NCAS = -NCAS
16164             IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR.
16165      &          ((NCAS.EQ.-1).AND.(IT.GT.1)))    THEN
16166                IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16167                IF (IREJ1.NE.0) GOTO 9998
16168             ENDIF
16169
16170          ENDIF
16171
16172     8 CONTINUE
16173       NSTART = NEND+1
16174       NEND   = NHKK
16175       IF (NSTART.LE.NEND) GOTO 7
16176
16177       RETURN
16178
16179  9998 CONTINUE
16180 * reject this event
16181       IRINC = IRINC+1
16182       IREJ = 1
16183
16184  9999 CONTINUE
16185 * intranucl. cascade not treated because of interaction properties or
16186 * it is supressed by user or it was rejected or...
16187       LFZC = .FALSE.
16188 * reset flag characterizing direction of motion in n-n-cms
16189 **sr14-11-95
16190 C     DO 9990 I=NPOINT(5),NHKK
16191 C        IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
16192 C9990 CONTINUE
16193
16194       RETURN
16195       END
16196
16197 *$ CREATE DT_INUCAS.FOR
16198 *COPY DT_INUCAS
16199 *
16200 *===inucas=============================================================*
16201 *
16202       SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
16203
16204 ************************************************************************
16205 * Formation zone supressed IntraNUclear CAScade for one final state    *
16206 * particle.                                                            *
16207 *           IT, IP    mass numbers of target, projectile nuclei        *
16208 *           IDXCAS    index of final state particle in DTEVT1          *
16209 *           NCAS =  1 intranuclear cascade in projectile               *
16210 *                = -1 intranuclear cascade in target                   *
16211 * This version dated 18.11.95 is written by S. Roesler                 *
16212 ************************************************************************
16213
16214       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16215       SAVE
16216       PARAMETER ( LINP = 10 ,
16217      &            LOUT = 6 ,
16218      &            LDAT = 9 )
16219
16220       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
16221      &           OHALF=0.5D0,ONE=1.0D0)
16222       PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16223       PARAMETER (TWOPI=6.283185307179586454D+00)
16224       PARAMETER (PLOWH=0.01D0,PHIH=9.0D0)
16225
16226       LOGICAL LABSOR,LCAS
16227
16228 * event history
16229       PARAMETER (NMXHKK=200000)
16230       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16231      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16232      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16233 * extended event history
16234       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16235      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16236      &                IHIST(2,NMXHKK)
16237 * final state after inc step
16238       PARAMETER (MAXFSP=10)
16239       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
16240 * flags for input different options
16241       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16242       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16243      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16244 * particle properties (BAMJET index convention)
16245       CHARACTER*8  ANAME
16246       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
16247      &                IICH(210),IIBAR(210),K1(210),K2(210)
16248 * Glauber formalism: collision properties
16249       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16250      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16251 * nuclear potential
16252       LOGICAL LFERMI
16253       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
16254      &                EBINDP(2),EBINDN(2),EPOT(2,210),
16255      &                ETACOU(2),ICOUL,LFERMI
16256 * parameter for intranuclear cascade
16257       LOGICAL LPAULI
16258       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16259 * final state after intranuclear cascade step
16260       COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16261 * nucleon-nucleon event-generator
16262       CHARACTER*8 CMODEL
16263       LOGICAL LPHOIN
16264       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
16265 * statistics: residual nuclei
16266       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
16267      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
16268      &                NINCST(2,4),NINCEV(2),
16269      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
16270      &                NRESPB(2),NRESCH(2),NRESEV(4),
16271      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
16272      &                NEVAFI(2,2)
16273
16274       DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4),
16275      &          PCAS1(5),PNUC(5),BGTA(4),
16276      &          BGCAS(2),GACAS(2),BECAS(2),
16277      &          RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2)
16278
16279       DATA PDIF /0.545D0/
16280
16281       IREJ = 0
16282
16283 * update counter
16284       IF (NINCEV(1).NE.NEVHKK) THEN
16285          NINCEV(1) = NEVHKK
16286          NINCEV(2) = NINCEV(2)+1
16287       ENDIF
16288
16289 * "BAMJET-index" of this hadron
16290       IDCAS = IDBAM(IDXCAS)
16291       IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
16292
16293 * skip gammas, electrons, etc..
16294       IF (AAM(IDCAS).LT.TINY2) RETURN
16295
16296 * Lorentz-trsf. into projectile rest system
16297       IF (IP.GT.1) THEN
16298          CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16299      &               PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3),
16300      &               PCAS(1,4),IDCAS,-2)
16301          PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2)
16302          PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1))
16303          IF (PCAS(1,5).GT.ZERO) THEN
16304             PCAS(1,5) = SQRT(PCAS(1,5))
16305          ELSE
16306             PCAS(1,5) = AAM(IDCAS)
16307          ENDIF
16308          DO 20 K=1,3
16309             COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
16310    20    CONTINUE
16311 * Lorentz-parameters
16312 *   particle rest system --> projectile rest system
16313          BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10)
16314          GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10)
16315          BECAS(1) = BGCAS(1)/GACAS(1)
16316       ELSE
16317          DO 21 K=1,5
16318             PCAS(1,K) = ZERO
16319             IF (K.LE.3) COSCAS(1,K) = ZERO
16320    21    CONTINUE
16321          PTOCAS(1) = ZERO
16322          BGCAS(1)  = ZERO
16323          GACAS(1)  = ZERO
16324          BECAS(1)  = ZERO
16325       ENDIF
16326 * Lorentz-trsf. into target rest system
16327       IF (IT.GT.1) THEN
16328 * LEPTO: final state particles are already in target rest frame
16329 C        IF (MCGENE.EQ.3) THEN
16330 C           PCAS(2,1) = PHKK(1,IDXCAS)
16331 C           PCAS(2,2) = PHKK(2,IDXCAS)
16332 C           PCAS(2,3) = PHKK(3,IDXCAS)
16333 C           PCAS(2,4) = PHKK(4,IDXCAS)
16334 C        ELSE
16335             CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16336      &                  PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3),
16337      &                  PCAS(2,4),IDCAS,-3)
16338 C        ENDIF
16339          PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2)
16340          PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2))
16341          IF (PCAS(2,5).GT.ZERO) THEN
16342             PCAS(2,5) = SQRT(PCAS(2,5))
16343          ELSE
16344             PCAS(2,5) = AAM(IDCAS)
16345          ENDIF
16346          DO 22 K=1,3
16347             COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
16348    22    CONTINUE
16349 * Lorentz-parameters
16350 *   particle rest system --> target rest system
16351          BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10)
16352          GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10)
16353          BECAS(2) = BGCAS(2)/GACAS(2)
16354       ELSE
16355          DO 23 K=1,5
16356             PCAS(2,K) = ZERO
16357             IF (K.LE.3) COSCAS(2,K) = ZERO
16358    23    CONTINUE
16359          PTOCAS(2) = ZERO
16360          BGCAS(2)  = ZERO
16361          GACAS(2)  = ZERO
16362          BECAS(2)  = ZERO
16363       ENDIF
16364
16365 * radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
16366 * potential (see CONUCL)
16367       RNUC(1)  = (RPROJ+4.605D0*PDIF)*FM2MM
16368       RNUC(2)  = (RTARG+4.605D0*PDIF)*FM2MM
16369 * impact parameter (the projectile moving along z)
16370       BIMPC(1) = ZERO
16371       BIMPC(2) = BIMPAC*FM2MM
16372
16373 * get position of initial hadron in projectile/target rest-syst.
16374       DO 3 K=1,4
16375          VTXCAS(1,K) = WHKK(K,IDXCAS)
16376          VTXCAS(2,K) = VHKK(K,IDXCAS)
16377     3 CONTINUE
16378
16379       ICAS = 1
16380       I2   = 2
16381       IF (NCAS.EQ.-1) THEN
16382          ICAS = 2
16383          I2   = 1
16384       ENDIF
16385
16386       IF (PTOCAS(ICAS).LT.TINY10) THEN
16387          WRITE(LOUT,1000) PTOCAS
16388  1000    FORMAT(1X,'INUCAS:   warning! zero momentum of initial',
16389      &          '  hadron ',/,20X,2E12.4)
16390          GOTO 9999
16391       ENDIF
16392
16393 * reset spectator flags
16394       NSPE = 0
16395       IDXSPE(1) = 0
16396       IDXSPE(2) = 0
16397       IDSPE(1)  = 0
16398       IDSPE(2)  = 0
16399
16400 * formation length (in fm)
16401 C     IF (LCAS) THEN
16402 C        DEL0 = ZERO
16403 C     ELSE
16404          DEL0 = TAUFOR*BGCAS(ICAS)
16405          IF (ITAUVE.EQ.1) THEN
16406             AMT  = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2
16407             DEL0 = DEL0*PCAS(ICAS,5)**2/AMT
16408          ENDIF
16409 C     ENDIF
16410 *   sample from exp(-del/del0)
16411       DEL1   = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10))
16412 * save formation time
16413       TAUSA1 = DEL1/BGCAS(ICAS)
16414       REL1   = TAUSA1*BGCAS(I2)
16415
16416       DEL    = DEL1
16417       TAUSAM = DEL/BGCAS(ICAS)
16418       REL    = TAUSAM*BGCAS(I2)
16419
16420 * special treatment for negative particles unable to escape
16421 * nuclear potential (implemented for ap, pi-, K- only)
16422       LABSOR = .FALSE.
16423       IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN
16424 *   threshold energy = nuclear potential + Coulomb potential
16425 *   (nuclear potential for hadron-nucleus interactions only)
16426          ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS)
16427          IF (PCAS(ICAS,4).LT.ETHR) THEN
16428             DO 4 K=1,5
16429                PCAS1(K) = PCAS(ICAS,K)
16430     4       CONTINUE
16431 *   "absorb" negative particle in nucleus
16432             CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1)
16433             IF (IREJ1.NE.0) GOTO 9999
16434             IF (NSPE.GE.1) LABSOR = .TRUE.
16435          ENDIF
16436       ENDIF
16437
16438 * if the initial particle has not been absorbed proceed with
16439 * "normal" cascade
16440       IF (.NOT.LABSOR) THEN
16441
16442 *   calculate coordinates of hadron at the end of the formation zone
16443 *   transport-time and -step in the rest system where this step is
16444 *   treated
16445          DSTEP  = DEL*FM2MM
16446          DTIME  = DSTEP/BECAS(ICAS)
16447          RSTEP  = REL*FM2MM
16448          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16449             RTIME = RSTEP/BECAS(I2)
16450          ELSE
16451             RTIME = ZERO
16452          ENDIF
16453 *   save step whithout considering the overlapping region
16454          DSTEP1 = DEL1*FM2MM
16455          DTIME1 = DSTEP1/BECAS(ICAS)
16456          RSTEP1 = REL1*FM2MM
16457          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16458             RTIME1 = RSTEP1/BECAS(I2)
16459          ELSE
16460             RTIME1 = ZERO
16461          ENDIF
16462 *   transport to the end of the formation zone in this system
16463          DO 5 K=1,3
16464             VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K)
16465             VTXCA1(I2,K)   = VTXCAS(I2,K)  +RSTEP1*COSCAS(I2,K)
16466             VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K)
16467             VTXCAS(I2,K)   = VTXCAS(I2,K)  +RSTEP*COSCAS(I2,K)
16468     5    CONTINUE
16469          VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1
16470          VTXCA1(I2,4)   = VTXCAS(I2,4)  +RTIME1
16471          VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME
16472          VTXCAS(I2,4)   = VTXCAS(I2,4)  +RTIME
16473
16474          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16475             XCAS   = VTXCAS(ICAS,1)
16476             YCAS   = VTXCAS(ICAS,2)
16477             XNCLTA = BIMPAC*FM2MM
16478             RNCLPR = (RPROJ+RNUCLE)*FM2MM
16479             RNCLTA = (RTARG+RNUCLE)*FM2MM
16480 C           RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
16481 C           RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
16482 C           RNCLPR = (RPROJ)*FM2MM
16483 C           RNCLTA = (RTARG)*FM2MM
16484             RCASPR = SQRT( XCAS**2        +YCAS**2)
16485             RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2)
16486             IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN
16487                IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3
16488             ENDIF
16489          ENDIF
16490
16491 *   check if particle is already outside of the corresp. nucleus
16492          RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+
16493      &                VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2)
16494          IF (RDIST.GE.RNUC(ICAS)) THEN
16495 *   here: IDCH is the generation of the final state part. starting
16496 *   with zero for hadronization products
16497 *   flag particles of generation 0 being outside the nuclei after
16498 *   formation time (to be used for excitation energy calculation)
16499             IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3))
16500      &         NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS
16501             GOTO 9997
16502          ENDIF
16503          DIST   = DLARGE
16504          DISTP  = DLARGE
16505          DISTN  = DLARGE
16506          IDXP   = 0
16507          IDXN   = 0
16508
16509 *   already here: skip particles being outside HADRIN "energy-window"
16510 *   to avoid wasting of time
16511          NINCHR(ICAS,1) = NINCHR(ICAS,1)+1
16512          IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN
16513             NINCHR(ICAS,2) = NINCHR(ICAS,2)+1
16514 C           WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
16515 C1002       FORMAT(1X,'INUCAS:   warning! momentum of particle with ',
16516 C    &             'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
16517 C    &             E12.4,', above or below HADRIN-thresholds',I6)
16518             NSPE = 0
16519             GOTO 9997
16520          ENDIF
16521
16522          DO 7 IDXHKK=1,NOINC
16523             I = IDXINC(IDXHKK)
16524 *   scan DTEVT1 for unwounded or excited nucleons
16525             IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
16526                DO 8 K=1,3
16527                   IF (ICAS.EQ.1) THEN
16528                      VTXDST(K) = WHKK(K,I)-VTXCAS(1,K)
16529                   ELSEIF (ICAS.EQ.2) THEN
16530                      VTXDST(K) = VHKK(K,I)-VTXCAS(2,K)
16531                   ENDIF
16532     8          CONTINUE
16533                POSNUC = VTXDST(1)*COSCAS(ICAS,1)+
16534      &                  VTXDST(2)*COSCAS(ICAS,2)+
16535      &                  VTXDST(3)*COSCAS(ICAS,3)
16536 *   check if nucleon is situated in forward direction
16537                IF (POSNUC.GT.ZERO) THEN
16538 *   distance between hadron and this nucleon
16539                   DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16540      &                          VTXDST(3)**2)
16541 *   impact parameter
16542                   BIMNU2 = DISTNU**2-POSNUC**2
16543                   IF (BIMNU2.LT.ZERO) THEN
16544                      WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2
16545  1001                FORMAT(1X,'INUCAS:   warning! inconsistent impact',
16546      &                      '  parameter ',/,20X,3E12.4)
16547                      GOTO 7
16548                   ENDIF
16549                   BIMNU  = SQRT(BIMNU2)
16550 *   maximum impact parameter to have interaction
16551                   IDNUC  = IDT_ICIHAD(IDHKK(I))
16552                   IDNUC1 = IDT_MCHAD(IDNUC)
16553                   IDCAS1 = IDT_MCHAD(IDCAS)
16554                   DO 19 K=1,5
16555                      PCAS1(K) = PCAS(ICAS,K)
16556                      PNUC(K)  = PHKK(K,I)
16557    19             CONTINUE
16558 * Lorentz-parameter for trafo into rest-system of target
16559                   DO 18 K=1,4
16560                      BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
16561    18             CONTINUE
16562 * transformation of projectile into rest-system of target
16563                   CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
16564      &                        PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4),
16565      &                        PPTOT,PX,PY,PZ,PE)
16566 **
16567 C                 CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
16568 C                 CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
16569                   DUMZER = ZERO
16570                   CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL)
16571                   CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB)
16572                   IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND.
16573      &                (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0
16574                   SIGIN = SIGTOT-SIGEL-SIGAB
16575 C                 SIGTOT = SIGIN+SIGEL+SIGAB
16576 **
16577                   BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM
16578 *   check if interaction is possible
16579                   IF (BIMNU.LE.BIMMAX) THEN
16580 *   get nucleon with smallest distance and kind of interaction
16581 *   (elastic/inelastic)
16582                      IF (DISTNU.LT.DIST) THEN
16583                         DIST      = DISTNU
16584                         BINT      = BIMNU
16585                         IF (IDNUC.NE.IDSPE(1)) THEN
16586                            IDSPE(2)  = IDSPE(1)
16587                            IDXSPE(2) = IDXSPE(1)
16588                            IDSPE(1)  = IDNUC
16589                         ENDIF
16590                         IDXSPE(1) = I
16591                         NSPE      = 1
16592 **sr
16593                         SELA = SIGEL
16594                         SABS = SIGAB
16595                         STOT = SIGTOT
16596 C                       IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
16597 C                          SELA = SIGEL
16598 C                          STOT = SIGIN+SIGEL
16599 C                       ELSE
16600 C                          SELA = SIGEL+0.75D0*SIGIN
16601 C                          STOT = 0.25D0*SIGIN+SELA
16602 C                       ENDIF
16603 **
16604                      ENDIF
16605                   ENDIf
16606                ENDIF
16607                DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16608      &                       VTXDST(3)**2)
16609                IDNUC  = IDT_ICIHAD(IDHKK(I))
16610                IF (IDNUC.EQ.1) THEN
16611                   IF (DISTNU.LT.DISTP) THEN
16612                      DISTP = DISTNU
16613                      IDXP  = I
16614                      POSP  = POSNUC
16615                   ENDIF
16616                ELSEIF (IDNUC.EQ.8) THEN
16617                   IF (DISTNU.LT.DISTN) THEN
16618                      DISTN = DISTNU
16619                      IDXN  = I
16620                      POSN  = POSNUC
16621                   ENDIF
16622                ENDIF
16623             ENDIF
16624     7    CONTINUE
16625
16626 * there is no nucleon for a secondary interaction
16627          IF (NSPE.EQ.0) GOTO 9997
16628
16629 C        IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
16630 C    &      WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
16631          IF (IDXSPE(2).EQ.0) THEN
16632             IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
16633 C              DO 80 K=1,3
16634 C                 IF (ICAS.EQ.1) THEN
16635 C                    VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
16636 C                 ELSEIF (ICAS.EQ.2) THEN
16637 C                    VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
16638 C                 ENDIF
16639 C  80          CONTINUE
16640 C              DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16641 C    &                       VTXDST(3)**2)
16642 C              IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
16643                   IDXSPE(2) = IDXN
16644                   IDSPE(2)  = 8
16645 C              ELSE
16646 C                 STOT = STOT-SABS
16647 C                 SABS = ZERO
16648 C              ENDIF
16649             ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
16650 C              DO 81 K=1,3
16651 C                 IF (ICAS.EQ.1) THEN
16652 C                    VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
16653 C                 ELSEIF (ICAS.EQ.2) THEN
16654 C                    VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
16655 C                 ENDIF
16656 C  81          CONTINUE
16657 C              DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16658 C    &                       VTXDST(3)**2)
16659 C              IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
16660                   IDXSPE(2) = IDXP
16661                   IDSPE(2)  = 1
16662 C              ELSE
16663 C                 STOT = STOT-SABS
16664 C                 SABS = ZERO
16665 C              ENDIF
16666             ELSE
16667                STOT = STOT-SABS
16668                SABS = ZERO
16669             ENDIF
16670          ENDIF
16671          RR = DT_RNDM(DIST)
16672          IF (RR.LT.SELA/STOT) THEN
16673             IPROC = 2
16674          ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
16675             IPROC = 3
16676          ELSE
16677             IPROC = 1
16678          ENDIF
16679
16680          DO 9 K=1,5
16681             PCAS1(K) = PCAS(ICAS,K)
16682             PNUC(K)  = PHKK(K,IDXSPE(1))
16683     9    CONTINUE
16684          IF (IPROC.EQ.3) THEN
16685 * 2-nucleon absorption of pion
16686             NSPE = 2
16687             CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1)
16688             IF (IREJ1.NE.0) GOTO 9999
16689             IF (NSPE.GE.1) LABSOR = .TRUE.
16690          ELSE
16691 * sample secondary interaction
16692             IDNUC = IDBAM(IDXSPE(1))
16693             CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1)
16694             IF (IREJ1.EQ.1) GOTO 9999
16695             IF (IREJ1.GT.1) GOTO 9998
16696          ENDIF
16697       ENDIF
16698
16699 * update arrays to include Pauli-principle
16700       DO 10 I=1,NSPE
16701          IF (NWOUND(ICAS).LE.299) THEN
16702             NWOUND(ICAS) = NWOUND(ICAS)+1
16703             EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
16704          ENDIF
16705    10 CONTINUE
16706
16707 * dump initial hadron for energy-momentum conservation check
16708       IF (LEMCCK)
16709      &   CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
16710      &               PCAS(ICAS,4),1,IDUM,IDUM)
16711
16712 * dump final state particles into DTEVT1
16713
16714 *   check if Pauli-principle is fulfilled
16715       NPAULI = 0
16716       NWTMP(1) = NWOUND(1)
16717       NWTMP(2) = NWOUND(2)
16718       DO 111 I=1,NFSP
16719          NPAULI = 0
16720          J1 = 2
16721          IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16722      &       ((NCAS.EQ.-1).AND.(IP.LE.1)))    J1 = 1
16723          DO 117 J=1,J1
16724             IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
16725             IF (J.EQ.1) THEN
16726                IDX = ICAS
16727                PE  = PFSP(4,I)
16728             ELSE
16729                IDX  = I2
16730                MODE = 1
16731                IF (IDX.EQ.1) MODE = -1
16732                CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
16733             ENDIF
16734 * first check if cascade step is forbidden due to Pauli-principle
16735 * (in case of absorpion this step is forced)
16736             IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16737      &          (IDFSP(I).EQ.8))) THEN
16738 *   get nuclear potential barrier
16739                POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16740                IF (IDFSP(I).EQ.1) THEN
16741                   POTLOW = POT-EBINDP(IDX)
16742                ELSE
16743                   POTLOW = POT-EBINDN(IDX)
16744                ENDIF
16745 *   final state particle not able to escape nucleus
16746                IF (PE.LE.POTLOW) THEN
16747 *     check if there are wounded nucleons
16748                   IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16749      &                 EWOUND(IDX,NWOUND(IDX)))) THEN
16750                      NPAULI      = NPAULI+1
16751                      NWOUND(IDX) = NWOUND(IDX)-1
16752                   ELSE
16753 *     interaction prohibited by Pauli-principle
16754                      NWOUND(1) = NWTMP(1)
16755                      NWOUND(2) = NWTMP(2)
16756                      GOTO 9997
16757                   ENDIF
16758                ENDIF
16759             ENDIF
16760   117    CONTINUE
16761   111 CONTINUE
16762
16763       NPAULI = 0
16764       NWOUND(1) = NWTMP(1)
16765       NWOUND(2) = NWTMP(2)
16766
16767       DO 11 I=1,NFSP
16768
16769          IST = ISTHKK(IDXCAS)
16770
16771          NPAULI = 0
16772          J1 = 2
16773          IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16774      &       ((NCAS.EQ.-1).AND.(IP.LE.1)))    J1 = 1
16775          DO 17 J=1,J1
16776             IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
16777             IDX = ICAS
16778             PE  = PFSP(4,I)
16779             IF (J.EQ.2) THEN
16780                IDX = I2
16781                CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
16782             ENDIF
16783 * first check if cascade step is forbidden due to Pauli-principle
16784 * (in case of absorpion this step is forced)
16785             IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16786      &          (IDFSP(I).EQ.8))) THEN
16787 *   get nuclear potential barrier
16788                POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16789                IF (IDFSP(I).EQ.1) THEN
16790                   POTLOW = POT-EBINDP(IDX)
16791                ELSE
16792                   POTLOW = POT-EBINDN(IDX)
16793                ENDIF
16794 *   final state particle not able to escape nucleus
16795                IF (PE.LE.POTLOW) THEN
16796 *     check if there are wounded nucleons
16797                   IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16798      &                 EWOUND(IDX,NWOUND(IDX)))) THEN
16799                      NWOUND(IDX) = NWOUND(IDX)-1
16800                      NPAULI = NPAULI+1
16801                      IST    = 14+IDX
16802                   ELSE
16803 *     interaction prohibited by Pauli-principle
16804                      NWOUND(1) = NWTMP(1)
16805                      NWOUND(2) = NWTMP(2)
16806                      GOTO 9997
16807                   ENDIF
16808 **sr
16809 c               ELSEIF (PE.LE.POT) THEN
16810 cC              ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
16811 cC                 NWOUND(IDX) = NWOUND(IDX)-1
16812 c**
16813 c                  NPAULI = NPAULI+1
16814 c                  IST    = 14+IDX
16815                ENDIF
16816             ENDIF
16817    17    CONTINUE
16818
16819 * dump final state particles for energy-momentum conservation check
16820          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I),
16821      &                           -PFSP(4,I),2,IDUM,IDUM)
16822
16823          PX = PFSP(1,I)
16824          PY = PFSP(2,I)
16825          PZ = PFSP(3,I)
16826          PE = PFSP(4,I)
16827          IF (ABS(IST).EQ.1) THEN
16828 * transform particles back into n-n cms
16829 * LEPTO: leave final state particles in target rest frame
16830 C           IF (MCGENE.EQ.3) THEN
16831 C              PFSP(1,I) = PX
16832 C              PFSP(2,I) = PY
16833 C              PFSP(3,I) = PZ
16834 C              PFSP(4,I) = PE
16835 C           ELSE
16836                IMODE = ICAS+1
16837                CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16838      &                     PFSP(4,I),IDFSP(I),IMODE)
16839 C           ENDIF
16840          ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN
16841 * target cascade but fsp got stuck in proj. --> transform it into
16842 * proj. rest system
16843             CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16844      &                  PFSP(4,I),IDFSP(I),-1)
16845          ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN
16846 * proj. cascade but fsp got stuck in target --> transform it into
16847 * target rest system
16848             CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16849      &                  PFSP(4,I),IDFSP(I),1)
16850          ENDIF
16851
16852 * dump final state particles into DTEVT1
16853          IGEN = IDCH(IDXCAS)+1
16854          ID   = IDT_IPDGHA(IDFSP(I))
16855          IXR  = 0
16856          IF (LABSOR) IXR = 99
16857          CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I),
16858      &               PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN)
16859
16860 * update the counter for particles which got stuck inside the nucleus
16861          IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
16862             NOINC = NOINC+1
16863             IDXINC(NOINC) = NHKK
16864          ENDIF
16865          IF (LABSOR) THEN
16866 *   in case of absorption the spatial treatment is an approximate
16867 *   solution anyway (the positions of the nucleons which "absorb" the
16868 *   cascade particle are not taken into consideration) therefore the
16869 *   particles are produced at the position of the cascade particle
16870             DO 12 K=1,4
16871                WHKK(K,NHKK) = WHKK(K,IDXCAS)
16872                VHKK(K,NHKK) = VHKK(K,IDXCAS)
16873    12       CONTINUE
16874          ELSE
16875 *   DDISTL - distance the cascade particle moves to the intera. point
16876 *   (the position where impact-parameter = distance to the interacting
16877 *   nucleon), DIST - distance to the interacting nucleon at the time of
16878 *   formation of the cascade particle, BINT - impact-parameter of this
16879 *   cascade-interaction
16880             DDISTL = SQRT(DIST**2-BINT**2)
16881             DTIME  = DDISTL/BECAS(ICAS)
16882             DTIMEL = DDISTL/BGCAS(ICAS)
16883             RDISTL = DTIMEL*BGCAS(I2)
16884             IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16885                RTIME = RDISTL/BECAS(I2)
16886             ELSE
16887                RTIME = ZERO
16888             ENDIF
16889 *   RDISTL, RTIME are this step and time in the rest system of the other
16890 *   nucleus
16891             DO 13 K=1,3
16892                VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
16893                VTXCA1(I2,K)   = VTXCAS(I2,K)  +COSCAS(I2,K)  *RDISTL
16894    13       CONTINUE
16895             VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME
16896             VTXCA1(I2,4)   = VTXCAS(I2,4)  +RTIME
16897 *   position of particle production is half the impact-parameter to
16898 *   the interacting nucleon
16899             DO 14 K=1,3
16900                WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
16901                VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
16902    14       CONTINUE
16903 *   time of production of secondary = time of interaction
16904             WHKK(4,NHKK) = VTXCA1(1,4)
16905             VHKK(4,NHKK) = VTXCA1(2,4)
16906          ENDIF
16907
16908    11 CONTINUE
16909
16910 * modify status and position of cascade particle (the latter for
16911 * statistics reasons only)
16912       ISTHKK(IDXCAS) = 2
16913       IF (LABSOR) ISTHKK(IDXCAS) = 19
16914       IF (.NOT.LABSOR) THEN
16915          DO 15 K=1,4
16916             WHKK(K,IDXCAS) = VTXCA1(1,K)
16917             VHKK(K,IDXCAS) = VTXCA1(2,K)
16918    15    CONTINUE
16919       ENDIF
16920
16921       DO 16 I=1,NSPE
16922          IS = IDXSPE(I)
16923 * dump interacting nucleons for energy-momentum conservation check
16924          IF (LEMCCK)
16925      &      CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
16926      &                                                  2,IDUM,IDUM)
16927 * modify entry for interacting nucleons
16928          IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS
16929          IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2
16930          IF (I.GE.2) THEN
16931             JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
16932             JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
16933          ENDIF
16934    16 CONTINUE
16935
16936 * check energy-momentum conservation
16937       IF (LEMCCK) THEN
16938          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
16939          IF (IREJ1.NE.0) GOTO 9999
16940       ENDIF
16941
16942 * update counter
16943       IF (LABSOR) THEN
16944          NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
16945       ELSE
16946          IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
16947          IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
16948       ENDIF
16949
16950       RETURN
16951
16952  9997 CONTINUE
16953  9998 CONTINUE
16954 * transport-step but no cascade step due to configuration (i.e. there
16955 * is no nucleon for interaction etc.)
16956       IF (LCAS) THEN
16957          DO 100 K=1,4
16958 C           WHKK(K,IDXCAS) = VTXCAS(1,K)
16959 C           VHKK(K,IDXCAS) = VTXCAS(2,K)
16960             WHKK(K,IDXCAS) = VTXCA1(1,K)
16961             VHKK(K,IDXCAS) = VTXCA1(2,K)
16962   100    CONTINUE
16963       ENDIF
16964
16965 C9998 CONTINUE
16966 * no cascade-step because of configuration
16967 * (i.e. hadron outside nucleus etc.)
16968       LCAS = .TRUE.
16969       RETURN
16970
16971  9999 CONTINUE
16972 * rejection
16973       IREJ = 1
16974       RETURN
16975       END
16976
16977 *$ CREATE DT_ABSORP.FOR
16978 *COPY DT_ABSORP
16979 *
16980 *===absorp=============================================================*
16981 *
16982       SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
16983
16984 ************************************************************************
16985 * Two-nucleon absorption of antiprotons, pi-, and K-.                  *
16986 * Antiproton absorption is handled by HADRIN.                          *
16987 * The following channels for meson-absorption are considered:          *
16988 *          pi- + p + p ---> n + p                                      *
16989 *          pi- + p + n ---> n + n                                      *
16990 *          K-  + p + p ---> sigma+ + n / Lam + p / sigma0 + p          *
16991 *          K-  + p + n ---> sigma- + n / Lam + n / sigma0 + n          *
16992 *          K-  + p + p ---> sigma- + n                                 *
16993 *      IDCAS, PCAS   identity, momentum of particle to be absorbed     *
16994 *      NCAS =  1     intranuclear cascade in projectile                *
16995 *           = -1     intranuclear cascade in target                    *
16996 *      NSPE          number of spectator nucleons involved             *
16997 *      IDXSPE(2)     DTEVT1-indices of spectator nucleons involved     *
16998 * Revised version of the original STOPIK written by HJM and J. Ranft.  *
16999 * This version dated 24.02.95 is written by S. Roesler                 *
17000 ************************************************************************
17001
17002       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17003       SAVE
17004       PARAMETER ( LINP = 10 ,
17005      &            LOUT = 6 ,
17006      &            LDAT = 9 )
17007       PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0,
17008      &           ONETHI=0.3333D0,TWOTHI=0.6666D0)
17009
17010 * event history
17011       PARAMETER (NMXHKK=200000)
17012       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17013      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17014      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17015 * extended event history
17016       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17017      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17018      &                IHIST(2,NMXHKK)
17019 * flags for input different options
17020       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17021       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17022      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17023 * final state after inc step
17024       PARAMETER (MAXFSP=10)
17025       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17026 * particle properties (BAMJET index convention)
17027       CHARACTER*8  ANAME
17028       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17029      &                IICH(210),IIBAR(210),K1(210),K2(210)
17030
17031       DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5),
17032      &          PTOT3P(4),BG3P(4),
17033      &          ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2)
17034
17035       IREJ = 0
17036       NFSP = 0
17037
17038 * skip particles others than ap, pi-, K- for mode=0
17039       IF ((MODE.EQ.0).AND.
17040      &    (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN
17041 * skip particles others than pions for mode=1
17042 * (2-nucleon absorption in intranuclear cascade)
17043       IF ((MODE.EQ.1).AND.
17044      &    (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN
17045
17046       NUCAS = NCAS
17047       IF (NUCAS.EQ.-1) NUCAS = 2
17048
17049       IF (MODE.EQ.0) THEN
17050 * scan spectator nucleons for nucleons being able to "absorb"
17051          NSPE      = 0
17052          IDXSPE(1) = 0
17053          IDXSPE(2) = 0
17054          DO 1 I=1,NHKK
17055             IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
17056                NSPE         = NSPE+1
17057                IDXSPE(NSPE) = I
17058                IDSPE(NSPE)  = IDBAM(I)
17059                IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2
17060                IF (NSPE.EQ.2) THEN
17061                   IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND.
17062      &                                  (IDSPE(2).EQ.8)) THEN
17063 *    there is no pi-+n+n channel
17064                      NSPE = 1
17065                      GOTO 1
17066                   ELSE
17067                      GOTO 2
17068                   ENDIF
17069                ENDIF
17070             ENDIF
17071     1    CONTINUE
17072
17073     2    CONTINUE
17074       ENDIF
17075 * transform excited projectile nucleons (status=15) into proj. rest s.
17076       DO 3 I=1,NSPE
17077          DO 4 K=1,5
17078             PSPE(I,K) = PHKK(K,IDXSPE(I))
17079     4    CONTINUE
17080     3 CONTINUE
17081
17082 * antiproton absorption
17083       IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
17084          DO 5 K=1,5
17085             PSPE1(K) = PSPE(1,K)
17086     5    CONTINUE
17087          CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
17088          IF (IREJ1.NE.0) GOTO 9999
17089
17090 * meson absorption
17091       ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23)
17092      &                      .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN
17093          IF (IDCAS.EQ.14) THEN
17094 *   pi- absorption
17095             IDFSP(1) = 8
17096             IDFSP(2) = 8
17097             IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
17098          ELSEIF (IDCAS.EQ.13) THEN
17099 *   pi+ absorption
17100             IDFSP(1) = 1
17101             IDFSP(2) = 1
17102             IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
17103          ELSEIF (IDCAS.EQ.23) THEN
17104 *   pi0 absorption
17105             IDFSP(1) = IDSPE(1)
17106             IDFSP(2) = IDSPE(2)
17107          ELSEIF (IDCAS.EQ.16) THEN
17108 *   K- absorption
17109             R = DT_RNDM(PCAS)
17110             IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
17111                IF (R.LT.ONETHI) THEN
17112                   IDFSP(1) = 21
17113                   IDFSP(2) = 8
17114                ELSEIF (R.LT.TWOTHI) THEN
17115                   IDFSP(1) = 17
17116                   IDFSP(2) = 1
17117                ELSE
17118                   IDFSP(1) = 22
17119                   IDFSP(2) = 1
17120                ENDIF
17121             ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
17122                IDFSP(1) = 20
17123                IDFSP(2) = 8
17124             ELSE
17125                IF (R.LT.ONETHI) THEN
17126                   IDFSP(1) = 20
17127                   IDFSP(2) = 1
17128                ELSEIF (R.LT.TWOTHI) THEN
17129                   IDFSP(1) = 17
17130                   IDFSP(2) = 8
17131                ELSE
17132                   IDFSP(1) = 22
17133                   IDFSP(2) = 8
17134                ENDIF
17135             ENDIF
17136          ENDIF
17137 *   dump initial particles for energy-momentum cons. check
17138          IF (LEMCCK) THEN
17139             CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM)
17140             CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2,
17141      &                                                    IDUM,IDUM)
17142             CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
17143      &                                                    IDUM,IDUM)
17144          ENDIF
17145 *   get Lorentz-parameter of 3 particle initial state
17146          DO 6 K=1,4
17147             PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
17148     6    CONTINUE
17149          P3P  = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
17150          AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
17151          DO 7 K=1,4
17152             BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
17153     7    CONTINUE
17154 *   2-particle decay of the 3-particle compound system
17155          CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2),
17156      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
17157      &               AAM(IDFSP(1)),AAM(IDFSP(2)))
17158          DO 8 I=1,2
17159             SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I)))
17160             PX  = PCMF(I)*COFF(I)*SDF
17161             PY  = PCMF(I)*SIFF(I)*SDF
17162             PZ  = PCMF(I)*CODF(I)
17163             CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ,
17164      &                  ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17165      &                  PFSP(4,I))
17166             PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) )
17167 *   check consistency of kinematics
17168             IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN
17169                WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I)
17170  1001          FORMAT(1X,'ABSORP:   warning! inconsistent',
17171      &                ' tree-particle kinematics',/,20X,'id: ',I3,
17172      &                ' AAM = ',E10.4,' MFSP = ',E10.4)
17173             ENDIF
17174 *   dump final state particles for energy-momentum cons. check
17175             IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17176      &                              -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17177     8    CONTINUE
17178          NFSP = 2
17179          IF (LEMCCK) THEN
17180             CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1)
17181             IF (IREJ1.NE.0) THEN
17182                WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)),
17183      &                      AM3P
17184                GOTO 9999
17185             ENDIF
17186          ENDIF
17187       ELSE
17188          IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
17189  1000    FORMAT(1X,'ABSORP:   warning! absorption for particle ',I3,
17190      &          ' impossible',/,20X,'too few spectators (',I2,')')
17191          NSPE = 0
17192       ENDIF
17193
17194       RETURN
17195
17196  9999 CONTINUE
17197       IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
17198       IREJ = 1
17199       RETURN
17200       END
17201
17202 *$ CREATE DT_HADRIN.FOR
17203 *COPY DT_HADRIN
17204 *
17205 *===hadrin=============================================================*
17206 *
17207       SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
17208
17209 ************************************************************************
17210 * Interface to the HADRIN-routines for inelastic and elastic           *
17211 * scattering.                                                          *
17212 *      IDPR,PPR(5)   identity, momentum of projectile                  *
17213 *      IDTA,PTA(5)   identity, momentum of target                      *
17214 *      MODE  = 1     inelastic interaction                             *
17215 *            = 2     elastic   interaction                             *
17216 * Revised version of the original FHAD.                                *
17217 * This version dated 27.10.95 is written by S. Roesler                 *
17218 ************************************************************************
17219
17220       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17221       SAVE
17222       PARAMETER ( LINP = 10 ,
17223      &            LOUT = 6 ,
17224      &            LDAT = 9 )
17225       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,
17226      &           TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0)
17227
17228       LOGICAL LCORR,LMSSG
17229
17230 * flags for input different options
17231       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17232       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17233      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17234 * final state after inc step
17235       PARAMETER (MAXFSP=10)
17236       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17237 * particle properties (BAMJET index convention)
17238       CHARACTER*8  ANAME
17239       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17240      &                IICH(210),IIBAR(210),K1(210),K2(210)
17241 * output-common for DHADRI/ELHAIN
17242 * final state from HADRIN interaction
17243       PARAMETER (MAXFIN=10)
17244       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
17245      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
17246
17247       DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
17248      &          P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
17249
17250       DATA LMSSG /.TRUE./
17251
17252       IREJ  = 0
17253       NFSP  = 0
17254       KCORR = 0
17255       IMCORR(1) = 0
17256       IMCORR(2) = 0
17257       LCORR = .FALSE.
17258
17259 *   dump initial particles for energy-momentum cons. check
17260       IF (LEMCCK) THEN
17261          CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM)
17262          CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM)
17263       ENDIF
17264
17265       AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2
17266       AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2
17267       IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR.
17268      &    (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR.
17269      &    (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN
17270          IF (LMSSG.AND.(IOULEV(3).GT.0))
17271      &   WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2
17272  1000    FORMAT(1X,'HADRIN:   warning! inconsistent projectile/target',
17273      &          ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ',
17274      &          E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4)
17275          LMSSG = .FALSE.
17276          LCORR = .TRUE.
17277       ENDIF
17278
17279 * convert initial state particles into particles which can be
17280 * handled by HADRIN
17281       IDHPR = IDPR
17282       IDHTA = IDTA
17283       IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
17284          IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
17285          DO 1 K=1,4
17286             P1IN(K) = PPR(K)
17287             P2IN(K) = PTA(K)
17288     1    CONTINUE
17289          XM1 = AAM(IDHPR)
17290          XM2 = AAM(IDHTA)
17291          CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17292          IF (IREJ1.GT.0) THEN
17293             WRITE(LOUT,'(1X,A)') 'HADRIN:   inconsistent mass trsf.'
17294             GOTO 9999
17295          ENDIF
17296          DO 2 K=1,4
17297             PPR(K) = P1OUT(K)
17298             PTA(K) = P2OUT(K)
17299     2    CONTINUE
17300          PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2)
17301          PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2)
17302       ENDIF
17303
17304 * Lorentz-parameter for trafo into rest-system of target
17305       DO 3 K=1,4
17306          BGTA(K) = PTA(K)/PTA(5)
17307     3 CONTINUE
17308 * transformation of projectile into rest-system of target
17309       CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2),
17310      &            PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3),
17311      &            PPR1(4))
17312
17313 * direction cosines of projectile in target rest system
17314       CX = PPR1(1)/PPRTO1
17315       CY = PPR1(2)/PPRTO1
17316       CZ = PPR1(3)/PPRTO1
17317
17318 * sample inelastic interaction
17319       IF (MODE.EQ.1) THEN
17320          CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA)
17321          IF (IRH.EQ.1) GOTO 9998
17322 * sample elastic interaction
17323       ELSEIF (MODE.EQ.2) THEN
17324          CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1)
17325          IF (IREJ1.NE.0) THEN
17326             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN'
17327             GOTO 9999
17328          ENDIF
17329          IF (IRH.EQ.1) GOTO 9998
17330       ELSE
17331          WRITE(LOUT,1001) MODE,INTHAD
17332  1001    FORMAT(1X,'HADRIN:   warning! inconsistent interaction mode',
17333      &          I4,' (INTHAD =',I4,')')
17334          GOTO 9999
17335       ENDIF
17336
17337 * transform final state particles back into Lab.
17338       DO 4 I=1,IRH
17339          NFSP = NFSP+1
17340          PX   = CXRH(I)*PLRH(I)
17341          PY   = CYRH(I)*PLRH(I)
17342          PZ   = CZRH(I)*PLRH(I)
17343          CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3),
17344      &               PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP),
17345      &               PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP))
17346          IDFSP(NFSP) = ITRH(I)
17347          AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2-
17348      &                                            PFSP(3,NFSP)**2
17349          IF (AMFSP2.LT.-TINY3) THEN
17350             WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP),
17351      &                       PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2
17352  1002       FORMAT(1X,'HADRIN:   warning! final state particle (id = ',
17353      &             I2,') with negative mass^2',/,1X,5E12.4)
17354             GOTO 9999
17355          ELSE
17356             PFSP(5,NFSP) = SQRT(ABS(AMFSP2))
17357             IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN
17358                WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
17359      &                          PFSP(5,NFSP)
17360  1003          FORMAT(1X,'HADRIN:   warning! final state particle',
17361      &                ' (id = ',I2,') with inconsistent mass',/,1X,
17362      &                2E12.4)
17363                KCORR         = KCORR+1
17364                IF (KCORR.GT.2) GOTO 9999
17365                IMCORR(KCORR) = NFSP
17366             ENDIF
17367          ENDIF
17368 *   dump final state particles for energy-momentum cons. check
17369          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17370      &                           -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17371     4 CONTINUE
17372
17373 * transform momenta on mass shell in case of inconsistencies in
17374 * HADRIN
17375       IF (KCORR.GT.0) THEN
17376          IF (KCORR.EQ.2) THEN
17377             I1 = IMCORR(1)
17378             I2 = IMCORR(2)
17379          ELSE
17380             IF (IMCORR(1).EQ.1) THEN
17381                I1 = 1
17382                I2 = 2
17383             ELSE
17384                I1 = 1
17385                I2 = IMCORR(1)
17386             ENDIF
17387          ENDIF
17388          IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1),
17389      &                           PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM)
17390          IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2),
17391      &                           PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM)
17392          DO 5 K=1,4
17393             P1IN(K) = PFSP(K,I1)
17394             P2IN(K) = PFSP(K,I2)
17395     5    CONTINUE
17396          XM1 = AAM(IDFSP(I1))
17397          XM2 = AAM(IDFSP(I2))
17398          CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17399          IF (IREJ1.GT.0) THEN
17400             WRITE(LOUT,'(1X,A)') 'HADRIN:   inconsistent mass trsf.'
17401 C           GOTO 9999
17402          ENDIF
17403          DO 6 K=1,4
17404             PFSP(K,I1) = P1OUT(K)
17405             PFSP(K,I2) = P2OUT(K)
17406     6    CONTINUE
17407          PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2
17408      &                    -PFSP(2,I1)**2-PFSP(3,I1)**2)
17409          PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2
17410      &                    -PFSP(2,I2)**2-PFSP(3,I2)**2)
17411 *   dump final state particles for energy-momentum cons. check
17412          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1),
17413      &                           -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM)
17414          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2),
17415      &                           -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM)
17416       ENDIF
17417
17418 * check energy-momentum conservation
17419       IF (LEMCCK) THEN
17420          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
17421          IF (IREJ1.NE.0) GOTO 9999
17422       ENDIF
17423
17424       RETURN
17425
17426  9998 CONTINUE
17427       IREJ = 2
17428       RETURN
17429
17430  9999 CONTINUE
17431       IREJ = 1
17432       RETURN
17433       END
17434
17435 *$ CREATE DT_HADCOL.FOR
17436 *COPY DT_HADCOL
17437 *
17438 *===hadcol=============================================================*
17439 *
17440       SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
17441
17442 ************************************************************************
17443 * Interface to the HADRIN-routines for inelastic and elastic           *
17444 * scattering. This subroutine samples hadron-nucleus interactions      *
17445 * below DPM-threshold.                                                 *
17446 *      IDPROJ        BAMJET-index of projectile hadron                 *
17447 *      PPN           projectile momentum in target rest frame          *
17448 *      IDXTAR        DTEVT1-index of target nucleon undergoing         *
17449 *                    interaction with projectile hadron                *
17450 * This subroutine replaces HADHAD.                                     *
17451 * This version dated 5.5.95 is written by S. Roesler                   *
17452 ************************************************************************
17453
17454       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17455       SAVE
17456       PARAMETER ( LINP = 10 ,
17457      &            LOUT = 6 ,
17458      &            LDAT = 9 )
17459       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0)
17460
17461       LOGICAL LSTART
17462
17463 * event history
17464       PARAMETER (NMXHKK=200000)
17465       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17466      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17467      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17468 * extended event history
17469       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17470      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17471      &                IHIST(2,NMXHKK)
17472 * nuclear potential
17473       LOGICAL LFERMI
17474       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17475      &                EBINDP(2),EBINDN(2),EPOT(2,210),
17476      &                ETACOU(2),ICOUL,LFERMI
17477 * interface HADRIN-DPM
17478       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
17479 * parameter for intranuclear cascade
17480       LOGICAL LPAULI
17481       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
17482 * final state after inc step
17483       PARAMETER (MAXFSP=10)
17484       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17485 * particle properties (BAMJET index convention)
17486       CHARACTER*8  ANAME
17487       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17488      &                IICH(210),IIBAR(210),K1(210),K2(210)
17489
17490       DIMENSION PPROJ(5),PNUC(5)
17491
17492       DATA LSTART /.TRUE./
17493
17494       IREJ   = 0
17495
17496       NPOINT(1) = NHKK+1
17497
17498       TAUSAV = TAUFOR
17499 **sr 6/9/01 commented
17500 C     TAUFOR = TAUFOR/2.0D0
17501 **
17502       IF (LSTART) THEN
17503          WRITE(LOUT,1000)
17504  1000    FORMAT(/,1X,'HADCOL:  Scattering handled by HADRIN')
17505          WRITE(LOUT,1001) TAUFOR
17506  1001    FORMAT(/,1X,'HADCOL:  Formation zone parameter set to ',
17507      &          F5.1,' fm/c')
17508          LSTART = .FALSE.
17509       ENDIF
17510
17511       IDNUC  = IDBAM(IDXTAR)
17512       IDNUC1 = IDT_MCHAD(IDNUC)
17513       IDPRO1 = IDT_MCHAD(IDPROJ)
17514
17515       IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
17516          IPROC = INTHAD
17517       ELSE
17518 **
17519 C        CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
17520 C        CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
17521          DUMZER = ZERO
17522          CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
17523          SIGIN = SIGTOT-SIGEL
17524 C        SIGTOT = SIGIN+SIGEL
17525 **
17526          IPROC  = 1
17527          IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
17528       ENDIF
17529
17530       PPROJ(1) = ZERO
17531       PPROJ(2) = ZERO
17532       PPROJ(3) = PPN
17533       PPROJ(5) = AAM(IDPROJ)
17534       PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
17535       DO 1 K=1,5
17536          PNUC(K)  = PHKK(K,IDXTAR)
17537     1 CONTINUE
17538
17539       ILOOP = 0
17540     2 CONTINUE
17541       ILOOP = ILOOP+1
17542       IF (ILOOP.GT.100) GOTO 9999
17543
17544       CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
17545       IF (IREJ1.EQ.1) GOTO 9999
17546
17547       IF (IREJ1.GT.1) THEN
17548 * no interaction possible
17549 *   require Pauli blocking
17550          IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2
17551          IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2
17552          IF ((IIBAR(IDPROJ).NE.1).AND.
17553      &       (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5)))              GOTO 2
17554 *   store incoming particle as final state particle
17555          CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3)
17556          CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0)
17557          NPOINT(4) = NHKK
17558       ELSE
17559 * require Pauli blocking for final state nucleons
17560          DO 4 I=1,NFSP
17561             IF ((IDFSP(I).EQ.1).AND.
17562      &          (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I))))       GOTO 2
17563             IF ((IDFSP(I).EQ.8).AND.
17564      &          (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I))))       GOTO 2
17565             IF ((IIBAR(IDFSP(I)).NE.1).AND.
17566      &          (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2
17567     4    CONTINUE
17568 * store final state particles
17569          DO 5 I=1,NFSP
17570             IST = 1
17571             IF ((IIBAR(IDFSP(I)).EQ.1).AND.
17572      &          (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16
17573             IDHAD = IDT_IPDGHA(IDFSP(I))
17574             CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3)
17575             CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I),
17576      &                                        PCMS,ECMS,0,0,0)
17577             IF (I.EQ.1) NPOINT(4) = NHKK
17578             VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR))
17579             VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR))
17580             VHKK(3,NHKK) = VHKK(3,IDXTAR)
17581             VHKK(4,NHKK) = VHKK(4,IDXTAR)
17582             WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR))
17583             WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR))
17584             WHKK(3,NHKK) = WHKK(3,1)
17585             WHKK(4,NHKK) = WHKK(4,1)
17586     5    CONTINUE
17587       ENDIF
17588       TAUFOR = TAUSAV
17589       RETURN
17590
17591  9999 CONTINUE
17592       IREJ = 1
17593       TAUFOR = TAUSAV
17594       RETURN
17595       END
17596
17597 *$ CREATE DT_GETEMU.FOR
17598 *COPY DT_GETEMU
17599 *
17600 *===getemu=============================================================*
17601 *
17602       SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
17603
17604 ************************************************************************
17605 * Sampling of emulsion component to be considered as target-nucleus.   *
17606 * This version dated 6.5.95   is written by S. Roesler.                *
17607 ************************************************************************
17608
17609       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17610       SAVE
17611       PARAMETER ( LINP = 10 ,
17612      &            LOUT = 6 ,
17613      &            LDAT = 9 )
17614       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
17615
17616       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
17617 * emulsion treatment
17618       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
17619      &                NCOMPO,IEMUL
17620 * Glauber formalism: flags and parameters for statistics
17621       LOGICAL LPROD
17622       CHARACTER*8 CGLB
17623       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
17624
17625       IF (MODE.EQ.0) THEN
17626          SUMFRA = ZERO
17627          RR = DT_RNDM(SUMFRA)
17628          IT  = 0
17629          ITZ = 0
17630          DO 1 ICOMP=1,NCOMPO
17631             SUMFRA = SUMFRA+EMUFRA(ICOMP)
17632             IF (SUMFRA.GT.RR) THEN
17633                IT    = IEMUMA(ICOMP)
17634                ITZ   = IEMUCH(ICOMP)
17635                KKMAT = ICOMP
17636                GOTO 2
17637             ENDIF
17638     1    CONTINUE
17639     2    CONTINUE
17640          IF (IT.LE.0) THEN
17641             WRITE(LOUT,'(1X,A,E12.3)')
17642      &       'Warning!  norm. failure within emulsion fractions',
17643      &       SUMFRA
17644             STOP
17645          ENDIF
17646       ELSEIF (MODE.EQ.1) THEN
17647          NDIFF = 10000
17648          DO 3 I=1,NCOMPO
17649             IDIFF = ABS(IT-IEMUMA(I))
17650             IF (IDIFF.LT.NDIFF) THEN
17651                KKMAT = I
17652                NDIFF = IDIFF
17653             ENDIF
17654     3    CONTINUE
17655       ELSE
17656          STOP 'DT_GETEMU'
17657       ENDIF
17658
17659 * bypass for variable projectile/target/energy runs: the correct
17660 * Glauber data will be always loaded on kkmat=1
17661       IF (IOGLB.EQ.100) THEN
17662          KKMAT = 1
17663       ENDIF
17664
17665       RETURN
17666       END
17667
17668 *$ CREATE DT_NCLPOT.FOR
17669 *COPY DT_NCLPOT
17670 *
17671 *===nclpot=============================================================*
17672 *
17673       SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
17674
17675 ************************************************************************
17676 * Calculation of Coulomb and nuclear potential for a given configurat. *
17677 *               IPZ, IP       charge/mass number of proj.              *
17678 *               ITZ, IT       charge/mass number of targ.              *
17679 *               AFERP,AFERT   factors modifying proj./target pot.      *
17680 *                             if =0, FERMOD is used                    *
17681 *               MODE = 0      calculation of binding energy            *
17682 *                    = 1      pre-calculated binding energy is used    *
17683 * This version dated 16.11.95  is written by S. Roesler.               *
17684 *                                                                      *
17685 * Last change 28.12.2006 by S. Roesler.                                *
17686 ************************************************************************
17687
17688       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17689       SAVE
17690       PARAMETER ( LINP = 10 ,
17691      &            LOUT = 6 ,
17692      &            LDAT = 9 )
17693       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
17694      &           TINY10=1.0D-10)
17695
17696       LOGICAL LSTART
17697
17698 * particle properties (BAMJET index convention)
17699       CHARACTER*8  ANAME
17700       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17701      &                IICH(210),IIBAR(210),K1(210),K2(210)
17702 * nuclear potential
17703       LOGICAL LFERMI
17704       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17705      &                EBINDP(2),EBINDN(2),EPOT(2,210),
17706      &                ETACOU(2),ICOUL,LFERMI
17707
17708       DIMENSION IDXPOT(14)
17709 *                   ap   an  lam  alam sig- sig+ sig0 tet0 tet- asig-
17710       DATA IDXPOT /   2,   9,  17,  18,  20,  21,  22,  97,  98,  99,
17711 *                 asig0 asig+ atet0 atet+
17712      &              100, 101, 102, 103/
17713
17714       DATA AN     /0.4D0/
17715       DATA LSTART /.TRUE./
17716
17717       IF (MODE.EQ.0) THEN
17718          EBINDP(1) = ZERO
17719          EBINDN(1) = ZERO
17720          EBINDP(2) = ZERO
17721          EBINDN(2) = ZERO
17722       ENDIF
17723       AIP  = DBLE(IP)
17724       AIPZ = DBLE(IPZ)
17725       AIT  = DBLE(IT)
17726       AITZ = DBLE(ITZ)
17727
17728       FERMIP = AFERP
17729       IF (AFERP.LE.ZERO) FERMIP = FERMOD
17730       FERMIT = AFERT
17731       IF (AFERT.LE.ZERO) FERMIT = FERMOD
17732
17733 * Fermi momenta and binding energy for projectile
17734       IF ((IP.GT.1).AND.LFERMI) THEN
17735          IF (MODE.EQ.0) THEN
17736 C           EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
17737 C           EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
17738             BIP  = AIP -ONE
17739             BIPZ = AIPZ-ONE
17740             EBINDP(1) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIP,BIPZ)
17741      &                                            -DT_ENERGY(AIP,AIPZ))
17742             IF (AIP.LE.AIPZ) THEN
17743                EBINDN(1) = EBINDP(1)
17744                WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
17745             ELSE
17746                EBINDN(1) = 1.0D-3*(DT_ENERGY(ONE,ZERO)
17747      &                     +DT_ENERGY(BIP,AIPZ)-DT_ENERGY(AIP,AIPZ))
17748             ENDIF
17749          ENDIF
17750          PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
17751          PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
17752       ELSE
17753          PFERMP(1) = ZERO
17754          PFERMN(1) = ZERO
17755       ENDIF
17756 * effective nuclear potential for projectile
17757 C     EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
17758 C     EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
17759       EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1)
17760       EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1)
17761
17762 * Fermi momenta and binding energy for target
17763       IF ((IT.GT.1).AND.LFERMI) THEN
17764          IF (MODE.EQ.0) THEN
17765 C           EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
17766 C           EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
17767             BIT  = AIT -ONE
17768             BITZ = AITZ-ONE
17769
17770             EBINDP(2) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIT,BITZ)
17771      &                                            -DT_ENERGY(AIT,AITZ))
17772
17773             IF (AIT.LE.AITZ) THEN
17774                EBINDN(2) = EBINDP(2)
17775                WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
17776             ELSE
17777
17778                EBINDN(2) = 1.0D-3*(DT_ENERGY(ONE,ZERO)
17779      &                     +DT_ENERGY(BIT,AITZ)-DT_ENERGY(AIT,AITZ))
17780
17781             ENDIF
17782          ENDIF
17783          PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
17784          PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
17785       ELSE
17786          PFERMP(2) = ZERO
17787          PFERMN(2) = ZERO
17788       ENDIF
17789 * effective nuclear potential for target
17790 C     EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
17791 C     EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
17792       EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2)
17793       EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2)
17794
17795       DO 2 I=1,14
17796          EPOT(1,IDXPOT(I)) = EPOT(1,8)
17797          EPOT(2,IDXPOT(I)) = EPOT(2,8)
17798     2 CONTINUE
17799
17800 * Coulomb energy
17801       ETACOU(1) = ZERO
17802       ETACOU(2) = ZERO
17803       IF (ICOUL.EQ.1) THEN
17804          IF (IP.GT.1)
17805      &   ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
17806          IF (IT.GT.1)
17807      &   ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
17808       ENDIF
17809
17810       IF (LSTART) THEN
17811          WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN,
17812      &                    EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2),
17813      &                    EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2),
17814      &                    FERMOD,ETACOU
17815  1000    FORMAT(/,/,1X,'NCLPOT:    quantities for inclusion of nuclear'
17816      &           ,' effects',/,12X,'---------------------------',
17817      &           '----------------',/,/,38X,'projectile',
17818      &           '      target',/,/,1X,'Mass number / charge',
17819      &           17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy  -',
17820      &           ' proton   (GeV) ',2E14.4,/,17X,'- neutron  (GeV)'
17821      &          ,1X,2E14.4,/,1X,'Fermi-potential - proton   (GeV)',
17822      &           1X,2E14.4,/,17X,'- neutron  (GeV) ',2E14.4,/,/,
17823      &           1X,'Scale factor for Fermi-momentum    ',F4.2,/,
17824      &           /,1X,'Coulomb-energy ',2(E14.4,' GeV  '),/,/)
17825          LSTART = .FALSE.
17826       ENDIF
17827
17828       RETURN
17829       END
17830
17831 *$ CREATE DT_RESNCL.FOR
17832 *COPY DT_RESNCL
17833 *
17834 *===resncl=============================================================*
17835 *
17836       SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
17837
17838 ************************************************************************
17839 * Treatment of residual nuclei and nuclear effects.                    *
17840 *         MODE = 1     initializations                                 *
17841 *              = 2     treatment of final state                        *
17842 * This version dated 16.11.95 is written by S. Roesler.                *
17843 *                                                                      *
17844 * Last change 05.01.2007 by S. Roesler.                                *
17845 ************************************************************************
17846
17847       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17848       SAVE
17849       PARAMETER ( LINP = 10 ,
17850      &            LOUT = 6 ,
17851      &            LDAT = 9 )
17852       PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
17853      &           TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10,
17854      &           ONETHI=ONE/THREE)
17855       PARAMETER (AMUAMU = 0.93149432D0,
17856      &           FM2MM  = 1.0D-12,
17857      &           RNUCLE = 1.12D0)
17858       PARAMETER ( EMVGEV = 1.0                D-03 )
17859       PARAMETER ( AMUGEV = 0.93149432         D+00 )
17860       PARAMETER ( AMPRTN = 0.93827231         D+00 )
17861       PARAMETER ( AMNTRN = 0.93956563         D+00 )
17862       PARAMETER ( AMELCT = 0.51099906         D-03 )
17863       PARAMETER ( HLFHLF = 0.5D+00 )
17864       PARAMETER ( FERTHO = 14.33       D-09 )
17865       PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
17866       PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
17867       PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
17868
17869 * event history
17870       PARAMETER (NMXHKK=200000)
17871       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17872      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17873      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17874 * extended event history
17875       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17876      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17877      &                IHIST(2,NMXHKK)
17878 * particle properties (BAMJET index convention)
17879       CHARACTER*8  ANAME
17880       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17881      &                IICH(210),IIBAR(210),K1(210),K2(210)
17882 * flags for input different options
17883       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17884       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17885      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17886 * nuclear potential
17887       LOGICAL LFERMI
17888       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17889      &                EBINDP(2),EBINDN(2),EPOT(2,210),
17890      &                ETACOU(2),ICOUL,LFERMI
17891 * properties of interacting particles
17892       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
17893 * properties of photon/lepton projectiles
17894       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
17895 * Lorentz-parameters of the current interaction
17896       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
17897      &                UMO,PPCM,EPROJ,PPROJ
17898 * treatment of residual nuclei: wounded nucleons
17899       COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
17900 * treatment of residual nuclei: 4-momenta
17901       LOGICAL LRCLPR,LRCLTA
17902       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
17903      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
17904
17905       DIMENSION PFSP(4),PSEC(4),PSEC0(4)
17906       DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
17907      &          IDXCOR(15000),IDXOTH(NMXHKK)
17908
17909       GOTO (1,2) MODE
17910
17911 *------- initializations
17912     1 CONTINUE
17913
17914 * initialize arrays for residual nuclei
17915       DO 10 K=1,5
17916          IF (K.LE.4) THEN
17917             PFSP(K)     = ZERO
17918          ENDIF
17919          PINIPR(K) = ZERO
17920          PINITA(K) = ZERO
17921          PRCLPR(K) = ZERO
17922          PRCLTA(K) = ZERO
17923          TRCLPR(K) = ZERO
17924          TRCLTA(K) = ZERO
17925    10 CONTINUE
17926       SCPOT = ONE
17927       NLOOP = 0
17928
17929 * correction of projectile 4-momentum for effective target pot.
17930 * and Coulomb-energy (in case of hadron-nucleus interaction only)
17931       IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
17932          EPNI = EPN
17933 *   Coulomb-energy:
17934 *     positively charged hadron - check energy for Coloumb pot.
17935          IF (IICH(IJPROJ).EQ.1) THEN
17936             THRESH = ETACOU(2)+AAM(IJPROJ)
17937             IF (EPNI.LE.THRESH) THEN
17938                WRITE(LOUT,1000)
17939  1000          FORMAT(/,1X,'KKINC:  WARNING!  projectile energy',
17940      &                ' below Coulomb threshold - event rejected',/)
17941                ISTHKK(1) = 1
17942                RETURN
17943             ENDIF
17944 *     negatively charged hadron - increase energy by Coulomb energy
17945          ELSEIF (IICH(IJPROJ).EQ.-1) THEN
17946             EPNI = EPNI+ETACOU(2)
17947          ENDIF
17948          IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN
17949 *   Effective target potential
17950 *sr 6.6. binding energy only (to avoid negative exc. energies)
17951 C           EPNI = EPNI+EPOT(2,IJPROJ)
17952             EBIPOT = EBINDP(2)
17953             IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3))
17954      &         EBIPOT = EBINDN(2)
17955             EPNI = EPNI+ABS(EBIPOT)
17956 * re-initialization of DTLTRA
17957             DUM1 = ZERO
17958             DUM2 = ZERO
17959             CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
17960          ENDIF
17961       ENDIF
17962
17963 * projectile in n-n cms
17964       IF ((IP.LE.1).AND.(IT.GT.1)) THEN
17965          PMASS1 = AAM(IJPROJ)
17966 C* VDM assumption
17967 C         IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
17968          IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
17969          PMASS2 = AAM(1)
17970          PM1 = SIGN(PMASS1**2,PMASS1)
17971          PM2 = SIGN(PMASS2**2,PMASS2)
17972          PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
17973          PINIPR(5) = PMASS1
17974          IF (PMASS1.GT.ZERO) THEN
17975             PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
17976      &                      *(PINIPR(4)+PINIPR(5)))
17977          ELSE
17978             PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
17979          ENDIF
17980          AIT  = DBLE(IT)
17981          AITZ = DBLE(ITZ)
17982          PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ)
17983          CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
17984       ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
17985          PMASS1 = AAM(1)
17986          PMASS2 = AAM(IJTARG)
17987          PM1 = SIGN(PMASS1**2,PMASS1)
17988          PM2 = SIGN(PMASS2**2,PMASS2)
17989          PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO)
17990          PINITA(5) = PMASS2
17991          PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
17992      &                    *(PINITA(4)+PINITA(5)))
17993          AIP  = DBLE(IP)
17994          AIPZ = DBLE(IPZ)
17995          PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ)
17996          CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
17997       ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
17998          AIP  = DBLE(IP)
17999          AIPZ = DBLE(IPZ)
18000          PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ)
18001          CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18002          AIT  = DBLE(IT)
18003          AITZ = DBLE(ITZ)
18004          PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ)
18005          CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18006       ENDIF
18007
18008       RETURN
18009
18010 *------- treatment of final state
18011     2 CONTINUE
18012
18013       NLOOP = NLOOP+1
18014       IF (NLOOP.GT.1) SCPOT = 0.10D0
18015 C     WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
18016
18017       JPW  = NPW
18018       JPCW = NPCW
18019       JTW  = NTW
18020       JTCW = NTCW
18021       DO 40 K=1,4
18022          PFSP(K)   = ZERO
18023    40 CONTINUE
18024
18025       NOB = 0
18026       NOM = 0
18027       DO 900 I=NPOINT(4),NHKK
18028          IDXOTH(I) = -1
18029          IF (ISTHKK(I).EQ.1) THEN
18030             IF (IDBAM(I).EQ.7) GOTO 900
18031             IPOT = 0
18032             IOTHER = 0
18033 * particle moving into forward direction
18034             IF (PHKK(3,I).GE.ZERO) THEN
18035 *   most likely to be effected by projectile potential
18036                IPOT = 1
18037 *     there is no projectile nucleus, try target
18038                IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
18039                   IPOT   = 2
18040                   IF (IP.GT.1) IOTHER = 1
18041 *       there is no target nucleus --> skip
18042                   IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900
18043                ENDIF
18044 * particle moving into backward direction
18045             ELSE
18046 *   most likely to be effected by target potential
18047                IPOT = 2
18048 *     there is no target nucleus, try projectile
18049                IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
18050                   IPOT   = 1
18051                   IF (IT.GT.1) IOTHER = 1
18052 *       there is no projectile nucleus --> skip
18053                   IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900
18054                ENDIF
18055             ENDIF
18056             IFLG = -IPOT
18057 * nobam=3: particle is in overlap-region or neither inside proj. nor target
18058 *      =1: particle is not in overlap-region AND is inside target (2)
18059 *      =2: particle is not in overlap-region AND is inside projectile (1)
18060 * flag particles which are inside the nucleus ipot but not in its
18061 * overlap region
18062             IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT
18063             IF (IDBAM(I).NE.0) THEN
18064 * baryons: keep all nucleons and all others where flag is set
18065                IF (IIBAR(IDBAM(I)).NE.0) THEN
18066                   IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0))
18067      &                                                              THEN
18068                      NOB = NOB+1
18069                      PMOMB(NOB) = PHKK(3,I)
18070                      IDXB(NOB)  = SIGN(10000000*IABS(IFLG)
18071      &                           +1000000*IOTHER+I,IFLG)
18072                   ENDIF
18073 * mesons: keep only those mesons where flag is set
18074                ELSE
18075                   IF (IFLG.GT.0) THEN
18076                      NOM = NOM+1
18077                      PMOMM(NOM) = PHKK(3,I)
18078                      IDXM(NOM)  = 10000000*IFLG+1000000*IOTHER+I
18079                   ENDIF
18080                ENDIF
18081             ENDIF
18082          ENDIF
18083   900 CONTINUE
18084 *
18085 * sort particles in the arrays according to increasing long. momentum
18086       CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1)
18087       CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1)
18088 *
18089 * shuffle indices into one and the same array according to the later
18090 * sequence of correction
18091       NCOR = 0
18092       IF (IT.GT.1) THEN
18093          DO 910 I=1,NOB
18094             IF (PMOMB(I).GT.ZERO) GOTO 911
18095             NCOR = NCOR+1
18096             IDXCOR(NCOR) = IDXB(I)
18097   910    CONTINUE
18098   911    CONTINUE
18099          IF (IP.GT.1) THEN
18100             DO 912 J=1,NOB
18101                I = NOB+1-J
18102                IF (PMOMB(I).LT.ZERO) GOTO 913
18103                NCOR = NCOR+1
18104                IDXCOR(NCOR) = IDXB(I)
18105   912       CONTINUE
18106   913       CONTINUE
18107          ELSE
18108             DO 914 I=1,NOB
18109                IF (PMOMB(I).GT.ZERO) THEN
18110                   NCOR = NCOR+1
18111                   IDXCOR(NCOR) = IDXB(I)
18112                ENDIF
18113   914       CONTINUE
18114          ENDIF
18115       ELSE
18116          DO 915 J=1,NOB
18117             I = NOB+1-J
18118             NCOR = NCOR+1
18119             IDXCOR(NCOR) = IDXB(I)
18120   915    CONTINUE
18121       ENDIF
18122       DO 925 I=1,NOM
18123          IF (PMOMM(I).GT.ZERO) GOTO 926
18124          NCOR = NCOR+1
18125          IDXCOR(NCOR) = IDXM(I)
18126   925 CONTINUE
18127   926 CONTINUE
18128       DO 927 J=1,NOM
18129          I = NOM+1-J
18130          IF (PMOMM(I).LT.ZERO) GOTO 928
18131          NCOR = NCOR+1
18132          IDXCOR(NCOR) = IDXM(I)
18133   927 CONTINUE
18134   928 CONTINUE
18135 *
18136 C      IF (NEVHKK.EQ.484) THEN
18137 C         WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
18138 C 9000    FORMAT(1X,'wounded nucleons (proj.-p,n  targ.-p,n)',/,4I10)
18139 C         WRITE(LOUT,9001) NOB,NOM,NCOR
18140 C 9001    FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
18141 C         WRITE(LOUT,'(/,A)') ' baryons '
18142 C         DO 950 I=1,NOB
18143 CC           J     = IABS(IDXB(I))
18144 CC           INDEX = J-IABS(J/10000000)*10000000
18145 C            IPOT   = IABS(IDXB(I))/10000000
18146 C            IOTHER = IABS(IDXB(I))/1000000-IPOT*10
18147 C            INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000
18148 C            WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
18149 C  950    CONTINUE
18150 C         WRITE(LOUT,'(/,A)') ' mesons '
18151 C         DO 951 I=1,NOM
18152 CC           INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000
18153 C            IPOT   = IABS(IDXM(I))/10000000
18154 C            IOTHER = IABS(IDXM(I))/1000000-IPOT*10
18155 C            INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000
18156 C            WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
18157 C  951    CONTINUE
18158 C 9002    FORMAT(1X,4I14,E14.5)
18159 C         WRITE(LOUT,'(/,A)') ' all '
18160 C         DO 952 I=1,NCOR
18161 CC           J     = IABS(IDXCOR(I))
18162 CC           INDEX = J-IABS(J/10000000)*10000000
18163 CC            IPOT   = IABS(IDXCOR(I))/10000000
18164 C            IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10
18165 C            INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000
18166 C            WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
18167 C  952    CONTINUE
18168 C 9003    FORMAT(1X,4I14)
18169 C      ENDIF
18170 *
18171       DO 20 ICOR=1,NCOR
18172          IPOT   = IABS(IDXCOR(ICOR))/10000000
18173          IOTHER = IABS(IDXCOR(ICOR))/1000000-IPOT*10
18174          I = IABS(IDXCOR(ICOR))-IPOT*10000000-IOTHER*1000000
18175          IDXOTH(I) = 1
18176
18177          IDSEC  = IDBAM(I)
18178
18179 * reduction of particle momentum by corresponding nuclear potential
18180 * (this applies only if Fermi-momenta are requested)
18181
18182          IF (LFERMI) THEN
18183
18184 *   Lorentz-transformation into the rest system of the selected nucleus
18185             IMODE = -IPOT-1
18186             CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18187      &                  PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE)
18188             PSECO  = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2)
18189             AMSEC  = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO)))
18190             JPMOD  = 0
18191
18192             CHKLEV = TINY3
18193             IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1
18194             IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0
18195             IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN
18196                IF (IOULEV(3).GT.0)
18197      &            WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
18198  2000          FORMAT(1X,'RESNCL: inconsistent mass of particle',
18199      &                ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
18200      &                I4,'   AMSEC: ',E12.3,'  AAM(IDSEC): ',E12.3,/)
18201                GOTO 23
18202             ENDIF
18203
18204             DO 21 K=1,4
18205                PSEC0(K) = PSEC(K)
18206    21       CONTINUE
18207
18208 *   the correction for nuclear potential effects is applied to as many
18209 *   p/n as many nucleons were wounded; the momenta of other final state
18210 *   particles are corrected only if they materialize inside the corresp.
18211 *   nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
18212 *   = 3 part. outside proj. and targ., >=10 in overlapping region)
18213             IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN
18214                IF (IPOT.EQ.1) THEN
18215                   IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN
18216 *      this is most likely a wounded nucleon
18217 **test
18218 C                    RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
18219 C    &                           +(VHKK(2,IPW(JPW))/FM2MM)**2
18220 C    &                           +(VHKK(3,IPW(JPW))/FM2MM)**2)
18221 C                    RAD   = RNUCLE*DBLE(IP)**ONETHI
18222 C                    FDEN  = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
18223 C                    PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18224 **
18225                      PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18226                      JPW = JPW-1
18227                      JPMOD = 1
18228                   ELSE
18229 *      correct only if part. was materialized inside nucleus
18230 *      and if it is ouside the overlapping region
18231                      IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN
18232                         PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18233                         JPMOD = 1
18234                      ENDIF
18235                   ENDIF
18236                ELSEIF (IPOT.EQ.2) THEN
18237                   IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
18238 *      this is most likely a wounded nucleon
18239 **test
18240 C                    RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
18241 C    &                           +(VHKK(2,ITW(JTW))/FM2MM)**2
18242 C    &                           +(VHKK(3,ITW(JTW))/FM2MM)**2)
18243 C                    RAD   = RNUCLE*DBLE(IT)**ONETHI
18244 C                    FDEN  = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
18245 C                    PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18246 **
18247                      PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18248                      JTW = JTW-1
18249                      JPMOD = 1
18250                   ELSE
18251 *      correct only if part. was materialized inside nucleus
18252                      IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN
18253                         PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18254                         JPMOD = 1
18255                      ENDIF
18256                   ENDIF
18257                ENDIF
18258             ELSE
18259                IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
18260                   PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18261                   JPMOD = 1
18262                ENDIF
18263             ENDIF
18264
18265             IF (NLOOP.EQ.1) THEN
18266 * Coulomb energy correction:
18267 * the treatment of Coulomb potential correction is similar to the
18268 * one for nuclear potential
18269                IF (IDSEC.EQ.1) THEN
18270                   IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN
18271                      JPCW = JPCW-1
18272                   ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
18273                      JTCW = JTCW-1
18274                   ELSE
18275                      IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18276                   ENDIF
18277                ELSE
18278                   IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18279                ENDIF
18280                IF (IICH(IDSEC).EQ.1) THEN
18281 *    pos. particles: check if they are able to escape Coulomb potential
18282                   IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN
18283                      ISTHKK(I) = 14+IPOT
18284                      IF (ISTHKK(I).EQ.15) THEN
18285                         DO 26 K=1,4
18286                            PHKK(K,I) = PSEC0(K)
18287                            TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18288    26                CONTINUE
18289                         IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18290                         IF (IDSEC.EQ.1) NPCW = NPCW-1
18291                      ELSEIF (ISTHKK(I).EQ.16) THEN
18292                         DO 27 K=1,4
18293                            PHKK(K,I) = PSEC0(K)
18294                            TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18295    27                   CONTINUE
18296                         IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18297                         IF (IDSEC.EQ.1) NTCW = NTCW-1
18298                      ENDIF
18299                      GOTO 20
18300                   ENDIF
18301                ELSEIF (IICH(IDSEC).EQ.-1) THEN
18302 *    neg. particles: decrease energy by Coulomb-potential
18303                   PSEC(4) = PSEC(4)-ETACOU(IPOT)
18304                   JPMOD = 1
18305                ENDIF
18306             ENDIF
18307
18308    25       CONTINUE
18309
18310             IF (PSEC(4).LT.AMSEC) THEN
18311                IF (IOULEV(6).GT.0)
18312      &            WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
18313  2001          FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5,
18314      &                ' is not allowed to escape nucleus',/,
18315      &                8X,'id : ',I3,'   reduced energy: ',E15.4,
18316      &                '   mass: ',E12.3)
18317                ISTHKK(I) = 14+IPOT
18318                IF (ISTHKK(I).EQ.15) THEN
18319                   DO 28 K=1,4
18320                      PHKK(K,I) = PSEC0(K)
18321                      TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18322    28             CONTINUE
18323                   IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18324                   IF (IDSEC.EQ.1) NPCW = NPCW-1
18325                ELSEIF (ISTHKK(I).EQ.16) THEN
18326                   DO 29 K=1,4
18327                      PHKK(K,I) = PSEC0(K)
18328                      TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18329    29             CONTINUE
18330                   IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18331                   IF (IDSEC.EQ.1) NTCW = NTCW-1
18332                ENDIF
18333                GOTO 20
18334             ENDIF
18335
18336             IF (JPMOD.EQ.1) THEN
18337                PSECN  = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
18338 * 4-momentum after correction for nuclear potential
18339                DO 22 K=1,3
18340                   PSEC(K) = PSEC(K)*PSECN/PSECO
18341    22          CONTINUE
18342
18343 * store recoil momentum from particles escaping the nuclear potentials
18344                DO 30 K=1,4
18345                   IF (IPOT.EQ.1) THEN
18346                      TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K)
18347                   ELSEIF (IPOT.EQ.2) THEN
18348                      TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K)
18349                   ENDIF
18350    30          CONTINUE
18351
18352 * transform momentum back into n-n cms
18353                IMODE = IPOT+1
18354                CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4),
18355      &                     PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18356      &                     IDSEC,IMODE)
18357             ENDIF
18358
18359          ENDIF
18360
18361    23    CONTINUE
18362          DO 31 K=1,4
18363             PFSP(K) = PFSP(K)+PHKK(K,I)
18364    31    CONTINUE
18365
18366    20 CONTINUE
18367
18368       DO 33 I=NPOINT(4),NHKK
18369          IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN
18370             PFSP(1) = PFSP(1)+PHKK(1,I)
18371             PFSP(2) = PFSP(2)+PHKK(2,I)
18372             PFSP(3) = PFSP(3)+PHKK(3,I)
18373             PFSP(4) = PFSP(4)+PHKK(4,I)
18374          ENDIF
18375    33 CONTINUE
18376
18377       DO 34 K=1,5
18378          PRCLPR(K) = TRCLPR(K)
18379          PRCLTA(K) = TRCLTA(K)
18380    34 CONTINUE
18381
18382       IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18383 * hadron-nucleus interactions: get residual momentum from energy-
18384 * momentum conservation
18385          DO 32 K=1,4
18386             PRCLPR(K) = ZERO
18387             PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
18388    32    CONTINUE
18389       ELSE
18390 * nucleus-hadron, nucleus-nucleus: get residual momentum from
18391 * accumulated recoil momenta of particles leaving the spectators
18392 *   transform accumulated recoil momenta of residual nuclei into
18393 *   n-n cms
18394          PZI = PRCLPR(3)
18395          PEI = PRCLPR(4)
18396          CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
18397          PZI = PRCLTA(3)
18398          PEI = PRCLTA(4)
18399          CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
18400 C        IF (IP.GT.1) THEN
18401             PRCLPR(3) = PRCLPR(3)+PINIPR(3)
18402             PRCLPR(4) = PRCLPR(4)+PINIPR(4)
18403 C        ENDIF
18404          IF (IT.GT.1) THEN
18405             PRCLTA(3) = PRCLTA(3)+PINITA(3)
18406             PRCLTA(4) = PRCLTA(4)+PINITA(4)
18407          ENDIF
18408       ENDIF
18409
18410 * check momenta of residual nuclei
18411       IF (LEMCCK) THEN
18412          CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
18413      &               1,IDUM,IDUM)
18414          CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
18415      &               2,IDUM,IDUM)
18416          CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
18417      &               2,IDUM,IDUM)
18418          CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
18419      &               2,IDUM,IDUM)
18420          CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM)
18421 **sr 19.12. changed to avoid output when used with phojet
18422 C        CHKLEV = TINY3
18423          CHKLEV = TINY1
18424          CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
18425 C        IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
18426 C    &      CALL DT_EVTOUT(4)
18427          IF (IREJ1.GT.0) RETURN
18428       ENDIF
18429
18430       RETURN
18431       END
18432
18433 *$ CREATE DT_SCN4BA.FOR
18434 *COPY DT_SCN4BA
18435 *
18436 *===scn4ba=============================================================*
18437 *
18438       SUBROUTINE DT_SCN4BA
18439
18440 ************************************************************************
18441 * SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot.    *
18442 * This version dated 12.12.95 is written by S. Roesler.                *
18443 ************************************************************************
18444
18445       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18446       SAVE
18447       PARAMETER ( LINP = 10 ,
18448      &            LOUT = 6 ,
18449      &            LDAT = 9 )
18450       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
18451      &           TINY10=1.0D-10)
18452
18453 * event history
18454       PARAMETER (NMXHKK=200000)
18455       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18456      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18457      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18458 * extended event history
18459       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18460      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18461      &                IHIST(2,NMXHKK)
18462 * particle properties (BAMJET index convention)
18463       CHARACTER*8  ANAME
18464       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18465      &                IICH(210),IIBAR(210),K1(210),K2(210)
18466 * properties of interacting particles
18467       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18468 * nuclear potential
18469       LOGICAL LFERMI
18470       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18471      &                EBINDP(2),EBINDN(2),EPOT(2,210),
18472      &                ETACOU(2),ICOUL,LFERMI
18473 * treatment of residual nuclei: wounded nucleons
18474       COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18475 * treatment of residual nuclei: 4-momenta
18476       LOGICAL LRCLPR,LRCLTA
18477       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18478      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18479
18480       DIMENSION PLAB(2,5),PCMS(4)
18481
18482       IREJ = 0
18483
18484 * get number of wounded nucleons
18485       NPW    = 0
18486       NPW0   = 0
18487       NPCW   = 0
18488       NPSTCK = 0
18489       NTW    = 0
18490       NTW0   = 0
18491       NTCW   = 0
18492       NTSTCK = 0
18493
18494       ISGLPR = 0
18495       ISGLTA = 0
18496       LRCLPR = .FALSE.
18497       LRCLTA = .FALSE.
18498
18499 C     DO 2 I=1,NHKK
18500       DO 2 I=1,NPOINT(1)
18501 * projectile nucleons wounded in primary interaction and in fzc
18502          IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
18503             NPW      = NPW+1
18504             IPW(NPW) = I
18505             NPSTCK   = NPSTCK+1
18506             IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
18507             IF (ISTHKK(I).EQ.11)  NPW0 = NPW0+1
18508 C           IF (IP.GT.1) THEN
18509                DO 5 K=1,4
18510                   TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
18511     5          CONTINUE
18512 C           ENDIF
18513 * target nucleons wounded in primary interaction and in fzc
18514          ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
18515             NTW      = NTW+1
18516             ITW(NTW) = I
18517             NTSTCK   = NTSTCK+1
18518             IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
18519             IF (ISTHKK(I).EQ.12)  NTW0 = NTW0+1
18520             IF (IT.GT.1) THEN
18521                DO 6 K=1,4
18522                   TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
18523     6          CONTINUE
18524             ENDIF
18525          ELSEIF (ISTHKK(I).EQ.13) THEN
18526             ISGLPR = I
18527          ELSEIF (ISTHKK(I).EQ.14) THEN
18528             ISGLTA = I
18529          ENDIF
18530     2 CONTINUE
18531
18532       DO 11 I=NPOINT(4),NHKK
18533 * baryons which are unable to escape the nuclear potential of proj.
18534          IF (ISTHKK(I).EQ.15) THEN
18535             ISGLPR = I
18536             NPSTCK = NPSTCK-1
18537             IF (IIBAR(IDBAM(I)).NE.0) THEN
18538                NPW    = NPW-1
18539                IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
18540             ENDIF
18541             DO 7 K=1,4
18542                TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18543     7       CONTINUE
18544 * baryons which are unable to escape the nuclear potential of targ.
18545          ELSEIF (ISTHKK(I).EQ.16) THEN
18546             ISGLTA = I
18547             NTSTCK = NTSTCK-1
18548             IF (IIBAR(IDBAM(I)).NE.0) THEN
18549                NTW    = NTW-1
18550                IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
18551             ENDIF
18552             DO 8 K=1,4
18553                TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18554     8       CONTINUE
18555          ENDIF
18556    11 CONTINUE
18557
18558 * residual nuclei so far
18559       IRESP = IP-NPSTCK
18560       IREST = IT-NTSTCK
18561
18562 * ckeck for "residual nuclei" consisting of one nucleon only
18563 * treat it as final state particle
18564       IF (IRESP.EQ.1) THEN
18565          ID  = IDBAM(ISGLPR)
18566          IST = ISTHKK(ISGLPR)
18567          CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR),
18568      &               PHKK(3,ISGLPR),PHKK(4,ISGLPR),
18569      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2)
18570          IF (IST.EQ.13) THEN
18571             ISTHKK(ISGLPR) = 11
18572          ELSE
18573             ISTHKK(ISGLPR) = 2
18574          ENDIF
18575          CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0,
18576      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18577      &               IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR))
18578          NOBAM(NHKK)      = NOBAM(ISGLPR)
18579          JDAHKK(1,ISGLPR) = NHKK
18580          DO 21 K=1,4
18581             TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
18582    21    CONTINUE
18583       ENDIF
18584       IF (IREST.EQ.1) THEN
18585          ID  = IDBAM(ISGLTA)
18586          IST = ISTHKK(ISGLTA)
18587          CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA),
18588      &               PHKK(3,ISGLTA),PHKK(4,ISGLTA),
18589      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3)
18590          IF (IST.EQ.14) THEN
18591             ISTHKK(ISGLTA) = 12
18592          ELSE
18593             ISTHKK(ISGLTA) = 2
18594          ENDIF
18595          CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0,
18596      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18597      &               IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA))
18598          NOBAM(NHKK)      = NOBAM(ISGLTA)
18599          JDAHKK(1,ISGLTA) = NHKK
18600          DO 22 K=1,4
18601             TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
18602    22    CONTINUE
18603       ENDIF
18604
18605 * get nuclear potential corresp. to the residual nucleus
18606       IPRCL  = IP -NPW
18607       IPZRCL = IPZ-NPCW
18608       ITRCL  = IT -NTW
18609       ITZRCL = ITZ-NTCW
18610       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
18611
18612 * baryons unable to escape the nuclear potential are treated as
18613 * excited nucleons (ISTHKK=15,16)
18614       DO 3 I=NPOINT(4),NHKK
18615          IF (ISTHKK(I).EQ.1) THEN
18616             ID  = IDBAM(I)
18617             IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN
18618 *   final state n and p not being outside of both nuclei are considered
18619                NPOTP = 1
18620                NPOTT = 1
18621                IF ( (IP.GT.1)      .AND.(IRESP.GT.1).AND.
18622      &              (NOBAM(I).NE.1).AND.(NPW.GT.0)        ) THEN
18623 *     Lorentz-trsf. into proj. rest sys. for those being inside proj.
18624                   CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18625      &                        PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3),
18626      &                        PLAB(1,4),ID,-2)
18627                   PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2)
18628                   PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)*
18629      &                                  (PLAB(1,4)+PLABT) ))
18630                   EKIN = PLAB(1,4)-PLAB(1,5)
18631                   IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15
18632                   IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1
18633                ENDIF
18634                IF ( (IT.GT.1)      .AND.(IREST.GT.1).AND.
18635      &              (NOBAM(I).NE.2).AND.(NTW.GT.0)        ) THEN
18636 *     Lorentz-trsf. into targ. rest sys. for those being inside targ.
18637                   CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18638      &                        PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3),
18639      &                        PLAB(2,4),ID,-3)
18640                   PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2)
18641                   PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)*
18642      &                                  (PLAB(2,4)+PLABT) ))
18643                   EKIN = PLAB(2,4)-PLAB(2,5)
18644                   IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16
18645                   IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1
18646                ENDIF
18647                IF (PHKK(3,I).GE.ZERO) THEN
18648                   ISTHKK(I) = NPOTT
18649                   IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
18650                ELSE
18651                   ISTHKK(I) = NPOTP
18652                   IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
18653                ENDIF
18654                IF (ISTHKK(I).NE.1) THEN
18655                   J = ISTHKK(I)-14
18656                   DO 4 K=1,5
18657                      PHKK(K,I) = PLAB(J,K)
18658     4             CONTINUE
18659                   IF (ISTHKK(I).EQ.15) THEN
18660                      NPW = NPW-1
18661                      IF (ID.EQ.1) NPCW = NPCW-1
18662                      DO 9 K=1,4
18663                         TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18664     9                CONTINUE
18665                   ELSEIF (ISTHKK(I).EQ.16) THEN
18666                      NTW = NTW-1
18667                      IF (ID.EQ.1) NTCW = NTCW-1
18668                      DO 10 K=1,4
18669                         TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18670    10                CONTINUE
18671                   ENDIF
18672                ENDIF
18673             ENDIF
18674          ENDIF
18675     3 CONTINUE
18676
18677 * again: get nuclear potential corresp. to the residual nucleus
18678       IPRCL  = IP -NPW
18679       IPZRCL = IPZ-NPCW
18680       ITRCL  = IT -NTW
18681       ITZRCL = ITZ-NTCW
18682 c      AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
18683 cC     AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
18684 c     &             *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
18685 C     AFERP = 0.0D0
18686 c      AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
18687 cC     AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
18688 c     &             *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
18689 C     AFERT = 0.0D0
18690 C     IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
18691 C     IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
18692 C     IF (AFERP.GT.0.85D0) AFERP = 0.85D0
18693 C     IF (AFERT.GT.0.85D0) AFERT = 0.85D0
18694       AFERP = FERMOD+0.1D0
18695       AFERT = FERMOD+0.1D0
18696
18697       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
18698
18699       RETURN
18700       END
18701
18702 *$ CREATE DT_FICONF.FOR
18703 *COPY DT_FICONF
18704 *
18705 *===ficonf=============================================================*
18706 *
18707       SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
18708
18709 ************************************************************************
18710 * Treatment of FInal CONFiguration including evaporation, fission and  *
18711 * Fermi-break-up (for light nuclei only).                              *
18712 * Adopted from the original routine FINALE and extended to residual    *
18713 * projectile nuclei.                                                   *
18714 * This version dated 12.12.95 is written by S. Roesler.                *
18715 *                                                                      *
18716 * Last change 27.12.2006 by S. Roesler.                                *
18717 ************************************************************************
18718
18719       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18720       SAVE
18721       PARAMETER ( LINP = 10 ,
18722      &            LOUT = 6 ,
18723      &            LDAT = 9 )
18724       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
18725       PARAMETER (ANGLGB=5.0D-16)
18726       PARAMETER (AMUAMU=0.93149432D0,AMELEC=0.51099906D-3)
18727
18728 * event history
18729       PARAMETER (NMXHKK=200000)
18730       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18731      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18732      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18733 * extended event history
18734       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18735      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18736      &                IHIST(2,NMXHKK)
18737 * rejection counter
18738       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
18739      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
18740      &                IREXCI(3),IRDIFF(2),IRINC
18741 * central particle production, impact parameter biasing
18742       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
18743 * particle properties (BAMJET index convention)
18744       CHARACTER*8  ANAME
18745       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18746      &                IICH(210),IIBAR(210),K1(210),K2(210)
18747 * treatment of residual nuclei: 4-momenta
18748       LOGICAL LRCLPR,LRCLTA
18749       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18750      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18751 * treatment of residual nuclei: properties of residual nuclei
18752       COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
18753      &                NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
18754      &                NTOTFI(2),NPROFI(2)
18755 * statistics: residual nuclei
18756       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
18757      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
18758      &                NINCST(2,4),NINCEV(2),
18759      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
18760      &                NRESPB(2),NRESCH(2),NRESEV(4),
18761      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
18762      &                NEVAFI(2,2)
18763 * flags for input different options
18764       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18765       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18766      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18767 * (original name: FINUC)
18768       PARAMETER (MXP=999)
18769       COMMON /FKFINU/ CXR    (MXP), CYR    (MXP), CZR    (MXP),
18770      &                CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
18771      &                TKI    (MXP), PLR    (MXP), WEI    (MXP),
18772      &                TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
18773      &                KPART  (MXP)
18774 * (original name: RESNUC)
18775       LOGICAL LRNFSS, LFRAGM
18776       COMMON /FKRESN/  AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
18777      &                   ANOW,   ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
18778      &                   ERES,  EKRES, AMNRES, AMMRES,  PTRES,  PXRES,
18779      &                  PYRES,  PZRES, PTRES2,  KTARP,  KTARN, IGREYP,
18780      &                 IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
18781      &                  ICRES,  IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
18782      &                 IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
18783      &                  IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
18784      &                 LFRAGM
18785       COMMON /FKNDAT/ AV0WEL,     APFRMX,     AEFRMX,     AEFRMA,
18786      &                RDSNUC,     V0WELL (2), PFRMMX (2), EFRMMX (2),
18787      &                EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
18788      &                VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
18789      &                PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
18790      &                EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
18791      &                ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV    ,
18792      &                AMRCSQ    , ATO1O3    , ZTO1O3    , ELBNDE (0:100)
18793 * (original name: PAREVT)
18794       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
18795      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
18796       PARAMETER ( NALLWP = 39   )
18797       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
18798      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
18799      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
18800      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
18801 * event flag
18802       COMMON /DTEVNO/ NEVENT,ICASCA
18803
18804       DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2),
18805      &          PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4),
18806      &          P1IN(4),P2IN(4),P1OUT(4),P2OUT(4)
18807
18808       DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260)
18809       LOGICAL LLCPOT
18810       DATA EXC,NEXC /520*ZERO,520*0/
18811       DATA EXPNUC /4.0D-3,4.0D-3/
18812
18813       IREJ   = 0
18814       LRCLPR = .FALSE.
18815       LRCLTA = .FALSE.
18816
18817 * skip residual nucleus treatment if not requested or in case
18818 * of central collisions
18819       IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN
18820
18821       DO 1 K=1,2
18822          IDPAR(K) = 0
18823          IDXPAR(K)= 0
18824          NTOT(K)  = 0
18825          NTOTFI(K)= 0
18826          NPRO(K)  = 0
18827          NPROFI(K)= 0
18828          NN(K)    = 0
18829          NH(K)    = 0
18830          NHPOS(K) = 0
18831          NQ(K)    = 0
18832          EEXC(K)  = ZERO
18833          MO1(K)   = 0
18834          MO2(K)   = 0
18835          DO 2 I=1,4
18836             VRCL(K,I) = ZERO
18837             WRCL(K,I) = ZERO
18838     2    CONTINUE
18839     1 CONTINUE
18840       NFSP = 0
18841       INUC(1) = IP
18842       INUC(2) = IT
18843
18844       DO 3 I=1,NHKK
18845
18846 * number of final state particles
18847          IF (ABS(ISTHKK(I)).EQ.1) THEN
18848             NFSP  = NFSP+1
18849             IDFSP = IDBAM(I)
18850          ENDIF
18851
18852 * properties of remaining nucleon configurations
18853          KF = 0
18854          IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1
18855          IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2
18856          IF (KF.GT.0) THEN
18857             IF (MO1(KF).EQ.0) MO1(KF) = I
18858             MO2(KF)  = I
18859 *   position of residual nucleus = average position of nucleons
18860             DO 4 K=1,4
18861                VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
18862                WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
18863     4       CONTINUE
18864 *   total number of particles contributing to each residual nucleus
18865             NTOT(KF)  = NTOT(KF)+1
18866             IDTMP     = IDBAM(I)
18867             IDXTMP    = I
18868 *   total charge of residual nuclei
18869             NQ(KF) = NQ(KF)+IICH(IDTMP)
18870 *   number of protons
18871             IF (IDHKK(I).EQ.2212) THEN
18872                NPRO(KF) = NPRO(KF)+1
18873 *   number of neutrons
18874             ELSEIF (IDHKK(I).EQ.2112) THEN
18875                NN(KF) = NN(KF)+1
18876             ELSE
18877 *   number of baryons other than n, p
18878                IF (IIBAR(IDTMP).EQ.1) THEN
18879                   NH(KF) = NH(KF)+1
18880                   IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
18881                ELSE
18882 *   any other mesons (status set to 1)
18883 C                 WRITE(LOUT,1002) KF,IDTMP
18884 C1002             FORMAT(1X,'FICONF:   residual nucleus ',I2,
18885 C    &                   ' containing meson ',I4,', status set to 1')
18886                   ISTHKK(I) = 1
18887                   IDTMP     = IDPAR(KF)
18888                   IDXTMP    = IDXPAR(KF)
18889                   NTOT(KF)  = NTOT(KF)-1
18890                ENDIF
18891             ENDIF
18892             IDPAR(KF)  = IDTMP
18893             IDXPAR(KF) = IDXTMP
18894          ENDIF
18895     3 CONTINUE
18896
18897 * reject elastic events (def: one final state particle = projectile)
18898       IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN
18899          IREXCI(3) = IREXCI(3)+1
18900          GOTO 9999
18901 C        RETURN
18902       ENDIF
18903
18904 * check if one nucleus disappeared..
18905 C     IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
18906 C        DO 5 K=1,4
18907 C           PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
18908 C           PRCLPR(K) = ZERO
18909 C   5    CONTINUE
18910 C     ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
18911 C        DO 6 K=1,4
18912 C           PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
18913 C           PRCLTA(K) = ZERO
18914 C   6    CONTINUE
18915 C     ENDIF
18916
18917       ICOR   = 0
18918       INORCL = 0
18919       DO 7 I=1,2
18920          DO 8 K=1,4
18921 * get the average of the nucleon positions
18922             VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1)
18923             WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1)
18924             IF (I.EQ.1) PRCL(1,K) = PRCLPR(K)
18925             IF (I.EQ.2) PRCL(2,K) = PRCLTA(K)
18926     8    CONTINUE
18927 * mass number and charge of residual nuclei
18928          AIF(I)  = DBLE(NTOT(I))
18929          AIZF(I) = DBLE(NPRO(I)+NHPOS(I))
18930          IF (NTOT(I).GT.1) THEN
18931 * masses of residual nuclei in ground state
18932             AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*DT_ENERGY(AIF(I),AIZF(I))
18933 * masses of residual nuclei
18934             PTORCL   = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2)
18935             AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL)
18936             IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I))
18937 *
18938 *   M_res^2 < 0 : configuration not allowed
18939 *
18940 *      a) re-calculate E_exc with scaled nuclear potential
18941 *         (conditional jump to label 9998)
18942 *      b) or reject event if N_loop(max) is exceeded
18943 *         (conditional jump to label 9999)
18944 *
18945             IF (AMRCL(I).LE.ZERO) THEN
18946                IF (IOULEV(3).GT.0)
18947      &            WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3),
18948      &                             PRCL(I,4),NTOT
18949  1000          FORMAT(1X,'warning! negative excitation energy',/,
18950      &                I4,4E15.4,2I4)
18951                AMRCL(I) = ZERO
18952                EEXC(I)  = ZERO
18953                IF (NLOOP.LE.500) THEN
18954                   GOTO 9998
18955                ELSE
18956                   IREXCI(2) = IREXCI(2)+1
18957                   GOTO 9999
18958                ENDIF
18959 *
18960 *   0 < M_res < M_res0 : mass below ground-state mass
18961 *
18962 *      a) we had residual nuclei with mass N_tot and reasonable E_exc
18963 *         before- assign average E_exc of those configurations to this
18964 *         one ( Nexc(i,N_tot) > 0 )
18965 *      b) or (and this applies always if run in transport codes) go up
18966 *         one mass number and
18967 *           i) if mass now larger than proj/targ mass or if run in
18968 *              transport codes assign average E_exc per wounded nucleon
18969 *              x number of wounded nucleons (Inuc-Ntot)
18970 *          ii) or assign average E_exc of those configurations to this
18971 *              one ( Nexc(i,m) > 0 )
18972 *
18973             ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
18974      &                                                         THEN
18975                M = MIN(NTOT(I),260)
18976                IF (NEXC(I,M).GT.0) THEN
18977                   AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
18978                ELSE
18979    70             CONTINUE
18980                   M = M+1
18981 **sr corrected 27.12.06
18982 *                 IF (M.GE.INUC(I)) THEN
18983 *                    AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
18984                   IF ((M.GE.INUC(I)).OR.(ICASCA.GT.0)) THEN
18985                      IF ( INUC (I) .GT. NTOT (I) ) THEN
18986                         AMRCL(I) = AMRCL0(I)
18987      &                         + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0))
18988                      ELSE
18989                         AMRCL(I) = AMRCL0(I) + 0.5D+00 * EXPNUC(I)
18990                      END IF
18991 **
18992                   ELSE
18993                      IF (NEXC(I,M).GT.0) THEN
18994                         AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
18995                      ELSE
18996                         GOTO 70
18997                      ENDIF
18998                   ENDIF
18999                ENDIF
19000                EEXC(I)  = AMRCL(I)-AMRCL0(I)
19001                ICOR     = ICOR+I
19002 *
19003 *   M_res > 2.5 x M_res0 : unreasonably(?) high E_exc
19004 *
19005 *      a) re-calculate E_exc with scaled nuclear potential
19006 *         (conditional jump to label 9998)
19007 *      b) or reject event if N_loop(max) is exceeded
19008 *         (conditional jump to label 9999)
19009 *
19010 *
19011             ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN
19012                IF (IOULEV(3).GT.0)
19013      &            WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK
19014  1004          FORMAT(1X,'warning! too high excitation energy',/,
19015      &                I4,1P,2E15.4,3I5)
19016                AMRCL(I) = ZERO
19017                EEXC(I)  = ZERO
19018                IF (NLOOP.LE.500) THEN
19019                   GOTO 9998
19020                ELSE
19021                   IREXCI(2) = IREXCI(2)+1
19022                   GOTO 9999
19023                ENDIF
19024 *
19025 *   Otherwise (reasonable E_exc) :
19026 *      E_exc = M_res - M_res0
19027 *      in addition: calculate and save E_exc per wounded nucleon as
19028 *                   well as E_exc in <E_exc> counter
19029 *
19030             ELSE
19031 * excitation energies of residual nuclei
19032                EEXC(I)   = AMRCL(I)-AMRCL0(I)
19033 **sr 27.12.06 new excitation energy correction by A.F.
19034 *
19035 * all parts with Ilcopt<3 commented since not used
19036 *
19037 * still to be done/decided:
19038 *   Increase Icor and put back both residual nuclei on mass shell
19039 *   with the exciting correction further below.
19040 *   For the moment the modification in the excitation energy is simply
19041 *   corrected by scaling the energy of the residual nucleus.
19042 *
19043                LLCPOT = .TRUE.
19044                ILCOPT = 3
19045                IF ( LLCPOT ) THEN
19046                   NNCHIT = MAX ( INUC (I) - NTOT (I), 0 )
19047                   IF ( ILCOPT .LE. 2 ) THEN
19048 C* Patch for Fermi momentum reduction correlated with impact parameter:
19049 C                     FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE )
19050 C                     DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I)))
19051 C                     AKPRHO = ONE - DLKPRH
19052 C* f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen
19053 C                     FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO  - ONE,
19054 C     &                              0.05D+00 )
19055 C*                    REDORI = 0.75D+00
19056 C*                    REDORI = ONE
19057 C                     REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
19058                   ELSE
19059                      DLKPRH = ZERO
19060                      RDCORE = 1.14D+00 * DBLE(INUC(I))**(ONE/3.D+00)
19061 *  Take out roughly one/half of the skin:
19062                      RDCORE = RDCORE - 0.5D+00
19063                      FRCFLL = RDCORE**3
19064                      PRSKIN = (RDCORE+2.4D+00)**3 - FRCFLL
19065                      PRSKIN = 0.5D+00 * PRSKIN / ( PRSKIN + FRCFLL )
19066                      FRCFLL = ONE - PRSKIN
19067                      FRMRDC = FRCFLL + 0.5D+00 * PRSKIN
19068                      REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
19069                   END IF
19070                   IF ( NNCHIT .GT. 0 ) THEN
19071 C                     IF ( ILCOPT .EQ. 1 ) THEN
19072 C                        SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE)
19073 C                        DO 1220 NCH = 1, 10
19074 C                           ETAETA = ( ONE - SKINRH**INUC(I)
19075 C     &                            - DBLE(INUC(I))* ( ONE - FRCFLL )
19076 C     &                            * ( ONE - SKINRH ) )
19077 C     &                            / ( SKINRH**INUC(I) - DBLE (INUC(I))
19078 C     &                            * ( ONE - FRCFLL) * SKINRH )
19079 C                           SKINRH = SKINRH * ( ONE + ETAETA )
19080 C 1220                   CONTINUE
19081 C                        PRSKIN = SKINRH**(NNCHIT-1)
19082 C                     ELSE IF ( ILCOPT .EQ. 2 ) THEN
19083 C                        PRSKIN = ONE - FRCFLL
19084 C                     END IF
19085                      REDCTN = ZERO
19086                      DO 1230 NCH = 1, NNCHIT
19087                         IF (DT_RNDM(PRFRMI) .LT. PRSKIN) THEN
19088                            PRFRMI = (( ONE - 2.D+00 * DLKPRH )
19089      &                            * DT_RNDM(PRFRMI))**0.333333333333D+00
19090                         ELSE
19091                            PRFRMI = ( ONE - 2.D+00 * DLKPRH
19092      &                            * DT_RNDM(PRFRMI))**0.333333333333D+00
19093                         END IF
19094                         REDCTN = REDCTN + PRFRMI**2
19095  1230                CONTINUE
19096                      REDCTN = REDCTN / DBLE (NNCHIT)
19097                   ELSE
19098                      REDCTN = 0.5D+00
19099                   END IF
19100                   EEXC  (I) = EEXC   (I) * REDCTN / REDORI
19101                   AMRCL (I) = AMRCL0 (I) + EEXC (I)
19102                   PRCL(I,4) = SQRT ( PTORCL**2 + AMRCL(I)**2 )
19103                END IF
19104 **
19105                IF (ICASCA.EQ.0) THEN
19106                   EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I))
19107                   M = MIN(NTOT(I),260)
19108                   EXC(I,M)  = EXC(I,M)+EEXC(I)
19109                   NEXC(I,M) = NEXC(I,M)+1
19110                ENDIF
19111             ENDIF
19112          ELSEIF (NTOT(I).EQ.1) THEN
19113             WRITE(LOUT,1003) I
19114  1003       FORMAT(1X,'FICONF:   warning! NTOT(I)=1? (I=',I3,')')
19115             GOTO 9999
19116          ELSE
19117             AMRCL0(I) = ZERO
19118             AMRCL(I)  = ZERO
19119             EEXC(I)   = ZERO
19120             INORCL    = INORCL+I
19121          ENDIF
19122     7 CONTINUE
19123
19124       PRCLPR(5) = AMRCL(1)
19125       PRCLTA(5) = AMRCL(2)
19126
19127       IF (ICOR.GT.0) THEN
19128          IF (INORCL.EQ.0) THEN
19129 * one or both residual nuclei consist of one nucleon only, transform
19130 * this nucleon on mass shell
19131             DO 9 K=1,4
19132                P1IN(K) = PRCL(1,K)
19133                P2IN(K) = PRCL(2,K)
19134     9       CONTINUE
19135             XM1 = AMRCL(1)
19136             XM2 = AMRCL(2)
19137             CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
19138             IF (IREJ1.GT.0) THEN
19139                WRITE(LOUT,*) 'ficonf-mashel rejection'
19140                GOTO 9999
19141             ENDIF
19142             DO 10 K=1,4
19143                PRCL(1,K) = P1OUT(K)
19144                PRCL(2,K) = P2OUT(K)
19145                PRCLPR(K) = P1OUT(K)
19146                PRCLTA(K) = P2OUT(K)
19147    10       CONTINUE
19148             PRCLPR(5) = AMRCL(1)
19149             PRCLTA(5) = AMRCL(2)
19150          ELSE
19151             IF (IOULEV(3).GT.0)
19152      &      WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)),
19153      &                       INT(AIF(2)),INT(AIZF(2)),AMRCL0(1),
19154      &                       AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2),
19155      &                       AMRCL(2),AMRCL(2)-AMRCL0(2)
19156  1001       FORMAT(1X,'FICONF:   warning! no residual nucleus for',
19157      &             ' correction',/,11X,'at event',I8,
19158      &             ',  nucleon config. 1:',2I4,' 2:',2I4,
19159      &             2(/,11X,3E12.3))
19160             IF (NLOOP.LE.500) THEN
19161                GOTO 9998
19162             ELSE
19163                IREXCI(1) = IREXCI(1)+1
19164             ENDIF
19165          ENDIF
19166       ENDIF
19167
19168 * update counter
19169 C     IF (NRESEV(1).NE.NEVHKK) THEN
19170 C        NRESEV(1) = NEVHKK
19171 C        NRESEV(2) = NRESEV(2)+1
19172 C     ENDIF
19173       NRESEV(2) = NRESEV(2)+1
19174       DO 15 I=1,2
19175          EXCDPM(I)   = EXCDPM(I)+EEXC(I)
19176          EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1))
19177          NRESTO(I) = NRESTO(I)+NTOT(I)
19178          NRESPR(I) = NRESPR(I)+NPRO(I)
19179          NRESNU(I) = NRESNU(I)+NN(I)
19180          NRESBA(I) = NRESBA(I)+NH(I)
19181          NRESPB(I) = NRESPB(I)+NHPOS(I)
19182          NRESCH(I) = NRESCH(I)+NQ(I)
19183    15 CONTINUE
19184
19185 * evaporation
19186       IF (LEVPRT) THEN
19187          DO 13 I=1,2
19188 * initialize evaporation counter
19189             EEXCFI(I) = ZERO
19190             IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
19191      &          (EEXC(I).GT.ZERO)) THEN
19192 * put residual nuclei into DTEVT1
19193                IDRCL = 80000
19194                JMASS = INT( AIF(I))
19195                JCHAR = INT(AIZF(I))
19196 *  the following patch is required to transmit the correct excitation
19197 *   energy to Eventd
19198                IF (ITRSPT.EQ.1) THEN
19199                   IF ((ABS(AMRCL(I)-AMRCL0(I)-EEXC(I)).GT.1.D-04).AND.
19200      &                (IOULEV(3).GT.0))
19201      &               WRITE(LOUT,*)
19202      &                  ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)',
19203      &                              AMRCL(I),AMRCL0(I),EEXC(I)
19204                   PRCL0 = PRCL(I,4)
19205                   PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
19206      &                                                    +PRCL(I,3)**2)
19207                   IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
19208                      WRITE(LOUT,*)
19209      &                  ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
19210                   ENDIF
19211                ENDIF
19212                CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1),
19213      &              PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0)
19214 **sr 22.6.97
19215                NOBAM(NHKK) = I
19216 **
19217                DO 14 J=1,4
19218                   VHKK(J,NHKK) = VRCL(I,J)
19219                   WHKK(J,NHKK) = WRCL(I,J)
19220    14          CONTINUE
19221 *  interface to evaporation module - fill final residual nucleus into
19222 *  common FKRESN
19223 *   fill resnuc only if code is not used as event generator in Fluka
19224                IF (ITRSPT.NE.1) THEN
19225                   PXRES  = PRCL(I,1)
19226                   PYRES  = PRCL(I,2)
19227                   PZRES  = PRCL(I,3)
19228                   IBRES  = NPRO(I)+NN(I)+NH(I)
19229                   ICRES  = NPRO(I)+NHPOS(I)
19230                   ANOW   = DBLE(IBRES)
19231                   ZNOW   = DBLE(ICRES)
19232                   PTRES  = SQRT(PXRES**2+PYRES**2+PZRES**2)
19233 *   ground state mass of the residual nucleus (should be equal to AM0T)
19234                   AMMRES = AMRCL0(I)
19235                   AMNRES = AMMRES-ZNOW*AMELEC+ELBNDE(ICRES)
19236 *  common FKFINU
19237                   TV = ZERO
19238 *   kinetic energy of residual nucleus
19239                   TVRECL = PRCL(I,4)-AMRCL(I)
19240 *   excitation energy of residual nucleus
19241                   TVCMS  = EEXC(I)
19242                   PTOLD  = PTRES
19243                   PTRES  = SQRT(ABS(TVRECL*(TVRECL+
19244      &                          2.0D0*(AMMRES+TVCMS))))
19245                   IF (PTOLD.LT.ANGLGB) THEN
19246                      CALL DT_RACO(PXRES,PYRES,PZRES)
19247                      PTOLD = ONE
19248                   ENDIF
19249                   PXRES = PXRES*PTRES/PTOLD
19250                   PYRES = PYRES*PTRES/PTOLD
19251                   PZRES = PZRES*PTRES/PTOLD
19252 * zero counter of secondaries from evaporation
19253                   NP = 0
19254 * evaporation
19255                   WE = ONE
19256                   CALL DT_EVEVAP(WE)
19257 * put evaporated particles and residual nuclei to DTEVT1
19258                   MO = NHKK
19259                   CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
19260                ENDIF
19261                EEXCFI(I) = EXCITF
19262                EXCEVA(I) = EXCEVA(I)+EXCITF
19263             ENDIF
19264    13    CONTINUE
19265       ENDIF
19266
19267       RETURN
19268
19269 C9998 IREXCI(1) = IREXCI(1)+1
19270  9998 IREJ   = IREJ+1
19271  9999 CONTINUE
19272       LRCLPR = .TRUE.
19273       LRCLTA = .TRUE.
19274       IREJ   = IREJ+1
19275       RETURN
19276       END
19277
19278 *$ CREATE DT_EVA2HE.FOR
19279 *COPY DT_EVA2HE
19280 *                                                                      *
19281 *====eva2he============================================================*
19282 *                                                                      *
19283       SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
19284
19285 ************************************************************************
19286 * Interface between common's of evaporation module (FKFINU,FKFHVY)     *
19287 * and DTEVT1.                                                          *
19288 *    MO    DTEVT1-index of "mother" (residual) nucleus before evap.    *
19289 *    EEXCF exitation energy of residual nucleus after evaporation      *
19290 *    IRCL  = 1 projectile residual nucleus                             *
19291 *          = 2 target     residual nucleus                             *
19292 * This version dated 19.04.95 is written by S. Roesler.                *
19293 *                                                                      *
19294 * Last change 27.12.2006 by S. Roesler.                                *
19295 ************************************************************************
19296
19297       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19298       SAVE
19299       PARAMETER ( LINP = 10 ,
19300      &            LOUT = 6 ,
19301      &            LDAT = 9 )
19302       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3)
19303
19304 * event history
19305       PARAMETER (NMXHKK=200000)
19306       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19307      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19308      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19309 * Note: DTEVT2 - special use for heavy fragments !
19310 *       (IDRES(I) = mass number, IDXRES(I) = charge)
19311 * extended event history
19312       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19313      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19314      &                IHIST(2,NMXHKK)
19315 * particle properties (BAMJET index convention)
19316       CHARACTER*8  ANAME
19317       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19318      &                IICH(210),IIBAR(210),K1(210),K2(210)
19319 * flags for input different options
19320       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
19321       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
19322      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
19323 * statistics: residual nuclei
19324       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
19325      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
19326      &                NINCST(2,4),NINCEV(2),
19327      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
19328      &                NRESPB(2),NRESCH(2),NRESEV(4),
19329      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
19330      &                NEVAFI(2,2)
19331 * treatment of residual nuclei: properties of residual nuclei
19332       COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
19333      &                NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
19334      &                NTOTFI(2),NPROFI(2)
19335 * (original name: FINUC)
19336       PARAMETER (MXP=999)
19337       COMMON /FKFINU/ CXR    (MXP), CYR    (MXP), CZR    (MXP),
19338      &                CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
19339      &                TKI    (MXP), PLR    (MXP), WEI    (MXP),
19340      &                TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
19341      &                KPART  (MXP)
19342 * (original name: FHEAVY,FHEAVC)
19343       PARAMETER ( MXHEAV = 100 )
19344       CHARACTER*8 ANHEAV
19345       COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
19346      &                CZHEAV (MXHEAV), TKHEAV (MXHEAV),
19347      &                PHEAVY (MXHEAV), WHEAVY (MXHEAV),
19348      &                AMHEAV  ( 12 ) , AMNHEA  ( 12 ) ,
19349      &                KHEAVY (MXHEAV), ICHEAV  ( 12 ) ,
19350      &                IBHEAV  ( 12 ) , NPHEAV
19351       COMMON /FKFHVC/ ANHEAV  ( 12 )
19352 * (original name: RESNUC)
19353       LOGICAL LRNFSS, LFRAGM
19354       COMMON /FKRESN/  AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
19355      &                   ANOW,   ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
19356      &                   ERES,  EKRES, AMNRES, AMMRES,  PTRES,  PXRES,
19357      &                  PYRES,  PZRES, PTRES2,  KTARP,  KTARN, IGREYP,
19358      &                 IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
19359      &                  ICRES,  IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
19360      &                 IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
19361      &                  IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
19362      &                 LFRAGM
19363
19364       DIMENSION IPTOKP(39)
19365       DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
19366      & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
19367      & 100, 101, 97, 102, 98, 103, 109, 115 /
19368
19369       IREJ = 0
19370
19371 * skip if evaporation package is not included
19372       IF (.NOT.LEVAPO) RETURN
19373
19374 * update counter
19375       IF (NRESEV(3).NE.NEVHKK) THEN
19376          NRESEV(3) = NEVHKK
19377          NRESEV(4) = NRESEV(4)+1
19378       ENDIF
19379
19380       IF (LEMCCK)
19381      &   CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
19382      &                                                   IDUM,IDUM)
19383 * mass number/charge of residual nucleus before evaporation
19384       IBTOT = IDRES(MO)
19385       IZTOT = IDXRES(MO)
19386
19387 * protons/neutrons/gammas
19388       DO 1 I=1,NP
19389          PX    = CXR(I)*PLR(I)
19390          PY    = CYR(I)*PLR(I)
19391          PZ    = CZR(I)*PLR(I)
19392          ID    = IPTOKP(KPART(I))
19393          IDPDG = IDT_IPDGHA(ID)
19394          AM    = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/
19395      &           (2.0D0*MAX(TKI(I),TINY10))
19396          IF (ABS(AM-AAM(ID)).GT.TINY3) THEN
19397             WRITE(LOUT,1000) ID,AM,AAM(ID)
19398  1000       FORMAT(1X,'EVA2HE:  inconsistent mass of evap. ',
19399      &             'particle',I3,2E10.3)
19400          ENDIF
19401          PE = TKI(I)+AM
19402          CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
19403          NOBAM(NHKK) = IRCL
19404          IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19405          IBTOT = IBTOT-IIBAR(ID)
19406          IZTOT = IZTOT-IICH(ID)
19407     1 CONTINUE
19408
19409 * heavy fragments
19410       DO 2 I=1,NPHEAV
19411          PX     = CXHEAV(I)*PHEAVY(I)
19412          PY     = CYHEAV(I)*PHEAVY(I)
19413          PZ     = CZHEAV(I)*PHEAVY(I)
19414          IDHEAV = 80000
19415          AM     = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
19416      &            (2.0D0*MAX(TKHEAV(I),TINY10))
19417          PE     = TKHEAV(I)+AM
19418          CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
19419      &                  IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
19420          NOBAM(NHKK) = IRCL
19421          IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19422          IBTOT = IBTOT-IBHEAV(KHEAVY(I))
19423          IZTOT = IZTOT-ICHEAV(KHEAVY(I))
19424     2 CONTINUE
19425
19426       IF (IBRES.GT.0) THEN
19427 * residual nucleus after evaporation
19428          IDNUC = 80000
19429          CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
19430      &                                        IBRES,ICRES,0)
19431          NOBAM(NHKK) = IRCL
19432       ENDIF
19433       EEXCF = TVCMS
19434       NTOTFI(IRCL) = IBRES
19435       NPROFI(IRCL) = ICRES
19436       IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM)
19437       IBTOT = IBTOT-IBRES
19438       IZTOT = IZTOT-ICRES
19439
19440 * count events with fission
19441       NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
19442       IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
19443
19444 * energy-momentum conservation check
19445       IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
19446 C     IF (IREJ.GT.0) THEN
19447 C        CALL DT_EVTOUT(4)
19448 C        WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
19449 C     ENDIF
19450 * baryon-number/charge conservation check
19451       IF (IBTOT+IZTOT.NE.0) THEN
19452          WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT
19453  1001    FORMAT(1X,'EVA2HE:   baryon-number/charge conservation ',
19454      &          'failure at event ',I8,' :  IBTOT,IZTOT = ',2I3)
19455       ENDIF
19456
19457       RETURN
19458       END
19459
19460 *$ CREATE DT_EBIND.FOR
19461 *COPY DT_EBIND
19462 *
19463 *===ebind==============================================================*
19464 *
19465       DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
19466
19467 ************************************************************************
19468 * Binding energy for nuclei.                                           *
19469 * (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972)                  *
19470 *                 IA        mass number                                *
19471 *                 IZ        atomic number                              *
19472 * This version dated 5.5.95   is updated by S. Roesler.                *
19473 ************************************************************************
19474
19475       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19476       SAVE
19477       PARAMETER ( LINP = 10 ,
19478      &            LOUT = 6 ,
19479      &            LDAT = 9 )
19480       PARAMETER (ZERO=0.0D0)
19481
19482       DATA       A1,       A2,        A3,        A4,      A5
19483      &     / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
19484
19485       IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN
19486          WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0.  ',IA,IZ
19487          DT_EBIND = ZERO
19488          RETURN
19489       ENDIF
19490       AA = IA
19491       DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0)
19492      &        -A4*(IA-2*IZ)**2/AA
19493       IF (MOD(IA,2).EQ.1) THEN
19494          IA5 = 0
19495       ELSEIF (MOD(IZ,2).EQ.1) THEN
19496          IA5 = 1
19497       ELSE
19498          IA5 = -1
19499       ENDIF
19500       DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
19501
19502       RETURN
19503       END
19504
19505 **sr 30.6. routine replaced completely
19506 *$ CREATE DT_ENERGY.FOR
19507 *COPY DT_ENERGY
19508 *                                                                      *
19509 *=== energy ===========================================================*
19510 *                                                                      *
19511       DOUBLE PRECISION FUNCTION DT_ENERGY( A, Z )
19512
19513 C     INCLUDE '(DBLPRC)'
19514 * DBLPRC.ADD
19515       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19516       SAVE
19517 * (original name: GLOBAL)
19518       PARAMETER ( KALGNM = 2 )
19519       PARAMETER ( ANGLGB = 5.0D-16 )
19520       PARAMETER ( ANGLSQ = 2.5D-31 )
19521       PARAMETER ( AXCSSV = 0.2D+16 )
19522       PARAMETER ( ANDRFL = 1.0D-38 )
19523       PARAMETER ( AVRFLW = 1.0D+38 )
19524       PARAMETER ( AINFNT = 1.0D+30 )
19525       PARAMETER ( AZRZRZ = 1.0D-30 )
19526       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
19527       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
19528       PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
19529       PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
19530       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
19531       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
19532       PARAMETER ( CSNNRM = 2.0D-15 )
19533       PARAMETER ( DMXTRN = 1.0D+08 )
19534       PARAMETER ( ZERZER = 0.D+00 )
19535       PARAMETER ( ONEONE = 1.D+00 )
19536       PARAMETER ( TWOTWO = 2.D+00 )
19537       PARAMETER ( THRTHR = 3.D+00 )
19538       PARAMETER ( FOUFOU = 4.D+00 )
19539       PARAMETER ( FIVFIV = 5.D+00 )
19540       PARAMETER ( SIXSIX = 6.D+00 )
19541       PARAMETER ( SEVSEV = 7.D+00 )
19542       PARAMETER ( EIGEIG = 8.D+00 )
19543       PARAMETER ( ANINEN = 9.D+00 )
19544       PARAMETER ( TENTEN = 10.D+00 )
19545       PARAMETER ( HLFHLF = 0.5D+00 )
19546       PARAMETER ( ONETHI = ONEONE / THRTHR )
19547       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
19548       PARAMETER ( ONEFOU = ONEONE / FOUFOU )
19549       PARAMETER ( THRTWO = THRTHR / TWOTWO )
19550       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
19551       PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
19552       PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
19553       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
19554       PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
19555       PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
19556       PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
19557       PARAMETER ( EULERO = 0.577215664901532860606512      D+00 )
19558       PARAMETER ( EULEXP = 1.781072417990197985236504      D+00 )
19559       PARAMETER ( EULLOG =-0.5495393129816448223376619     D+00 )
19560       PARAMETER ( E1M2EU = 0.8569023337737540831433017     D+00 )
19561       PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
19562       PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
19563       PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
19564       PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
19565       PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
19566       PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
19567       PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
19568       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
19569       PARAMETER ( CLIGHT = 2.99792458         D+10 )
19570       PARAMETER ( AVOGAD = 6.0221367          D+23 )
19571       PARAMETER ( BOLTZM = 1.380658           D-23 )
19572       PARAMETER ( AMELGR = 9.1093897          D-28 )
19573       PARAMETER ( PLCKBR = 1.05457266         D-27 )
19574       PARAMETER ( ELCCGS = 4.8032068          D-10 )
19575       PARAMETER ( ELCMKS = 1.60217733         D-19 )
19576       PARAMETER ( AMUGRM = 1.6605402          D-24 )
19577       PARAMETER ( AMMUMU = 0.113428913        D+00 )
19578       PARAMETER ( AMPRMU = 1.007276470        D+00 )
19579       PARAMETER ( AMNEMU = 1.008664904        D+00 )
19580       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
19581       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
19582       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
19583       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
19584       PARAMETER ( PLABRC = 0.197327053        D+00 )
19585       PARAMETER ( AMELCT = 0.51099906         D-03 )
19586       PARAMETER ( AMUGEV = 0.93149432         D+00 )
19587       PARAMETER ( AMMUON = 0.105658389        D+00 )
19588       PARAMETER ( AMPRTN = 0.93827231         D+00 )
19589       PARAMETER ( AMNTRN = 0.93956563         D+00 )
19590       PARAMETER ( AMDEUT = 1.87561339         D+00 )
19591       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
19592      &                   * 1.D-09 )
19593       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
19594       PARAMETER ( BLTZMN = 8.617385           D-14 )
19595       PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
19596       PARAMETER ( GFOHB3 = 1.16639            D-05 )
19597       PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
19598       PARAMETER ( SIN2TW = 0.2319             D+00 )
19599       PARAMETER ( GEVMEV = 1.0                D+03 )
19600       PARAMETER ( EMVGEV = 1.0                D-03 )
19601       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
19602       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
19603       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
19604       LOGICAL LGBIAS, LGBANA
19605       COMMON /FKGLOB/ LGBIAS, LGBANA
19606 C     INCLUDE '(DIMPAR)'
19607 * DIMPAR.ADD
19608       PARAMETER ( MXXRGN = 5000 )
19609       PARAMETER ( MXXMDF = 82   )
19610       PARAMETER ( MXXMDE = 54   )
19611       PARAMETER ( MFSTCK = 1000 )
19612       PARAMETER ( MESTCK = 100  )
19613       PARAMETER ( NALLWP = 39   )
19614       PARAMETER ( NELEMX = 80   )
19615       PARAMETER ( MPDPDX = 8    )
19616       PARAMETER ( ICOMAX = 180  )
19617       PARAMETER ( NSTBIS = 304  )
19618       PARAMETER ( IDMAXP = 220  )
19619       PARAMETER ( IDMXDC = 640  )
19620       PARAMETER ( MKBMX1 = 1    )
19621       PARAMETER ( MKBMX2 = 1    )
19622 C     INCLUDE '(IOUNIT)'
19623 * IOUNIT.ADD
19624       PARAMETER ( LUNIN  =  5 )
19625       PARAMETER ( LUNOUT =  6 )
19626 **sr 19.5. set error output-unit from 15 to 6
19627       PARAMETER ( LUNERR = 6  )
19628       PARAMETER ( LUNBER = 14 )
19629       PARAMETER ( LUNECH =  8 )
19630       PARAMETER ( LUNFLU = 13 )
19631       PARAMETER ( LUNGEO = 16 )
19632       PARAMETER ( LUNPMF = 12 )
19633       PARAMETER ( LUNRAN =  2 )
19634       PARAMETER ( LUNXSC =  9 )
19635       PARAMETER ( LUNDET = 17 )
19636       PARAMETER ( LUNRAY = 10 )
19637       PARAMETER ( LUNRDB =  1 )
19638       PARAMETER ( LUNPGO =  7 )
19639       PARAMETER ( LUNPGS =  4 )
19640       PARAMETER ( LUNSCR =  3 )
19641 *
19642 *----------------------------------------------------------------------*
19643 *                                                                      *
19644 *     Revised version of the original routine from EVAP:               *
19645 *                                                                      *
19646 *     Created on   15 may 1990     by    Alfredo Ferrari & Paola Sala  *
19647 *                                                   Infn - Milan       *
19648 *                                                                      *
19649 *     Last change on 19-sep-95     by    Alfredo Ferrari               *
19650 *                                                                      *
19651 *     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!     *
19652 *     !!!  It is supposed to be used with the updated atomic   !!!     *
19653 *     !!!                    mass data file                    !!!     *
19654 *     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!     *
19655 *                                                                      *
19656 *----------------------------------------------------------------------*
19657 *
19658 *  Mass number below which "unknown" isotopes out of the Z-interval
19659 *  reported in the mass tabulations are completely unstable and made
19660 *  up by Z proton masses + N neutron masses:
19661       PARAMETER ( KAFREE =  4 )
19662 *  Mass number below which "unknown" isotopes out of the Z-interval
19663 *  reported in the mass tabulations are supposed to be particle unstable
19664       PARAMETER ( KAPUNS = 12 )
19665 *  Minimum energy required for particle unstable isotopes
19666       PARAMETER ( DEPUNS = 0.5D+00 )
19667 *
19668 * (original name: EVA0)
19669       COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
19670      *                FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
19671      *                CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
19672      *                T (4,7), RMASS (297), ALPH (297), BET (297),
19673      *                APRIME (250), IA (6), IZ (6)
19674 * (original name: ISOTOP)
19675       PARAMETER ( NAMSMX = 270 )
19676       PARAMETER ( NZGVAX =  15 )
19677       PARAMETER ( NISMMX = 574 )
19678       COMMON /FKISOT/ WAPS   (NAMSMX,NZGVAX),  T12NUC (NAMSMX,NZGVAX),
19679      &                WAPISM (NISMMX), T12ISM (NISMMX),
19680      &                ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
19681      &                AMSSST (100)  , ISOMNM (NSTBIS), ISONDX (2,100),
19682      &                JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
19683      &                INWAPS (NAMSMX), JSPISM (NISMMX),
19684      &                JPTISM (NISMMX), IZWISM (NISMMX),
19685      &                INWISM (0:NAMSMX)
19686 *
19687 CPH      SAVE KA0, KZ0, IZ0
19688       DATA KA0, KZ0, IZ0 / -1, -1, -1 /
19689 *
19690       IFLAG = 1
19691       GO TO 10
19692 *======================================================================*
19693 *                                                                      *
19694 *     Entry ENergy - KNOWn                                             *
19695 *                                                                      *
19696 *======================================================================*
19697       ENTRY DT_ENKNOW ( A, Z, IZZ0 )
19698       IZZ0  =-1
19699       IFLAG = 2
19700    10 CONTINUE
19701 *
19702       KA0 = NINT ( A )
19703       KZ0 = NINT ( Z )
19704       N   = KA0 - KZ0
19705 *  +-------------------------------------------------------------------*
19706 *  |  Null residual nucleus:
19707       IF ( KA0 .EQ. 0 .AND. KZ0 .LE. 0 ) THEN
19708          IF ( IFLAG .EQ. 1 ) THEN
19709             DT_ENERGY = ZERZER
19710          ELSE
19711             DT_ENKNOW = ZERZER
19712             IZZ0   = -1
19713          END IF
19714          RETURN
19715 *  |
19716 *  +-------------------------------------------------------------------*
19717 *  |  Only protons:
19718       ELSE IF ( N .LE. 0 ) THEN
19719          IF ( N .LT. 0 ) THEN
19720             WRITE ( LUNOUT, * )
19721      &     ' DPMJET stopped in energy: mass number =< atomic number !!',
19722      &       KA0, KZ0
19723             WRITE ( LUNOUT, * )
19724      &     ' DPMJET stopped in energy: mass number =< atomic number !!',
19725      &       KA0, KZ0
19726                WRITE ( 77, * )
19727      &  ' ^^^DPMJET stopped in energy: mass number =< atomic number !!',
19728      &       KA0, KZ0
19729             STOP 'DT_ENERGY:KA0-KZ0'
19730          END IF
19731          IZ0    = -1
19732          IF ( IFLAG .EQ. 1 ) THEN
19733             DT_ENERGY = Z * WAPS ( 1, 2 )
19734          ELSE
19735             DT_ENKNOW = Z * WAPS ( 1, 2 )
19736             IZZ0   = -1
19737          END IF
19738          RETURN
19739 *  |
19740 *  +-------------------------------------------------------------------*
19741 *  |  Only neutrons:
19742       ELSE IF ( KZ0 .LE. 0 ) THEN
19743          IF ( KZ0 .LT. 0 ) THEN
19744             WRITE ( LUNOUT, * )
19745      &   ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19746             WRITE ( LUNOUT, * )
19747      &   ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19748             WRITE ( 77, * )
19749      &' ^^^DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19750             STOP 'DT_ENERGY:KZ0<0'
19751          END IF
19752          IZ0    = -1
19753          IF ( IFLAG .EQ. 1 ) THEN
19754             DT_ENERGY = A * WAPS ( 1, 1 )
19755          ELSE
19756             DT_ENKNOW = A * WAPS ( 1, 1 )
19757             IZZ0   = -1
19758          END IF
19759          RETURN
19760       END IF
19761 *  |
19762 *  +-------------------------------------------------------------------*
19763 *  +-------------------------------------------------------------------*
19764 *  |  No actual nucleus
19765 *  |
19766 *  +-------------------------------------------------------------------*
19767 *  +-------------------------------------------------------------------*
19768 *  |  A larger than maximum allowed:
19769       IF ( KA0 .GT. NAMSMX ) THEN
19770          IZ0    = -1
19771          IF ( IFLAG .EQ. 1 ) THEN
19772             DT_ENERGY = DT_ENRG( A, Z )
19773          ELSE
19774             DT_ENKNOW = DT_ENRG( A, Z )
19775             IZZ0   = -1
19776          END IF
19777          RETURN
19778       END IF
19779 *  |
19780 *  +-------------------------------------------------------------------*
19781       IZZ = INWAPS ( KA0 )
19782 *  +-------------------------------------------------------------------*
19783 *  |  Too much neutron rich with respect to the stability line:
19784       IF ( KZ0 .LT. IZZ ) THEN
19785 *  |  +----------------------------------------------------------------*
19786 *  |  |  Up to A=Kafree all "bound" masses are known, set it unbound:
19787          IF ( KA0 .LE. KAFREE ) THEN
19788             DT_ENERGY = AINFNT
19789 *  |  |
19790 *  |  +----------------------------------------------------------------*
19791 *  |  |  Up to Kapuns: be sure it is particle unstable
19792          ELSE IF ( KA0 .LE. KAPUNS ) THEN
19793 *  |  |  Exp. excess mass for A,IZZ
19794             ENEEXP = WAPS ( KA0, 1 )
19795 *  |  |  Cameron excess mass for A, IZZ
19796             ENECA1 = DT_ENRG( A, DBLE (IZZ) )
19797 *  |  |  Cameron excess mass for A, Z
19798             DT_ENERGY = DT_ENRG( A, Z )
19799 *  |  |  Use just the difference according to Cameron!!!
19800             DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19801             JZZ    = INWAPS ( KA0 - 1 )
19802             LZZ    = INWAPS ( KA0 - 2 )
19803 *  |  |  +-------------------------------------------------------------*
19804 *  |  |  |  Residual mass for n-decay known:
19805             IF ( KZ0 .GE. JZZ .AND. KZ0 .LE. JZZ + NZGVAX - 1 ) THEN
19806                IZ0    = KZ0 - JZZ + 1
19807                DT_ENERGY = MAX(DT_ENERGY,WAPS (KA0-1,IZ0) + WAPS (1,1)
19808      &                      + DEPUNS )
19809 *  |  |  |
19810 *  |  |  +-------------------------------------------------------------*
19811 *  |  |  |  Residual mass for 2n-decay known:
19812             ELSE IF ( KZ0 .GE. LZZ .AND. KZ0 .LE. LZZ + NZGVAX - 1 )THEN
19813                IZ0    = KZ0 - LZZ + 1
19814                DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO *
19815      &                      ( WAPS (1,1) + DEPUNS ) )
19816 *  |  |  |
19817 *  |  |  +-------------------------------------------------------------*
19818 *  |  |  |  Set it unbound:
19819             ELSE
19820                DT_ENERGY = AINFNT
19821             END IF
19822 *  |  |  |
19823 *  |  |  +-------------------------------------------------------------*
19824 *  |  |
19825 *  |  +----------------------------------------------------------------*
19826 *  |  |  Proceed as usual:
19827          ELSE
19828 *  |  |  Exp. excess mass for A,IZZ
19829             ENEEXP = WAPS ( KA0, 1 )
19830 *  |  |  Cameron excess mass for A, IZZ
19831             ENECA1 = DT_ENRG( A, DBLE (IZZ) )
19832 *  |  |  Cameron excess mass for A, Z
19833             DT_ENERGY = DT_ENRG( A, Z )
19834 *  |  |  Use just the difference according to Cameron!!!
19835             DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19836          END IF
19837 *  |  |
19838 *  |  +----------------------------------------------------------------*
19839 *  |  Be sure not to have a positive energy state:
19840          DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) )
19841          IZ0    = -1
19842          IF ( IFLAG .EQ. 2 ) THEN
19843             DT_ENKNOW = DT_ENERGY
19844             IZZ0   = -1
19845          END IF
19846          RETURN
19847 *  |
19848 *  +-------------------------------------------------------------------*
19849 *  |  Too much proton rich with respect to the stability line:
19850       ELSE IF ( KZ0 .GT. IZZ + NZGVAX - 1 ) THEN
19851 *  |  +----------------------------------------------------------------*
19852 *  |  |  Up to A=Kafree all "bound" masses are known, set it unbound:
19853          IF ( KA0 .LE. KAFREE ) THEN
19854             DT_ENERGY = AINFNT
19855 *  |  |
19856 *  |  +----------------------------------------------------------------*
19857 *  |  |  Up to Kapuns: be sure it is particle unstable
19858          ELSE IF ( KA0 .LE. KAPUNS ) THEN
19859 *  |  |  Exp. excess mass for A,IZZ+NZGVAX-1
19860             ENEEXP = WAPS ( KA0, NZGVAX )
19861 *  |  |  Cameron excess mass for A, IZZ+NZGVAX-1
19862             ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) )
19863 *  |  |  Cameron excess mass for A, Z
19864             DT_ENERGY = DT_ENRG( A, Z )
19865 *  |  |  Use just the difference according to Cameron!!!
19866             DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19867             JZZ    = INWAPS ( KA0 - 1 )
19868             LZZ    = INWAPS ( KA0 - 2 )
19869 *  |  |  +-------------------------------------------------------------*
19870 *  |  |  |  Residual mass for p-decay known:
19871             IF ( KZ0-1 .GE. JZZ .AND. KZ0-1 .LE. JZZ + NZGVAX - 1 ) THEN
19872                IZ0    = KZ0 - 1 - JZZ + 1
19873                DT_ENERGY = MAX (DT_ENERGY, WAPS (KA0-1,IZ0) + WAPS (1,2)
19874      &                      + DEPUNS )
19875 *  |  |  |
19876 *  |  |  +-------------------------------------------------------------*
19877 *  |  |  |  Residual mass for 2p-decay known:
19878             ELSE IF ( KZ0-2 .GE. LZZ .AND. KZ0-2 .LE. LZZ + NZGVAX - 1 )
19879      &         THEN
19880                IZ0    = KZ0 - 2 - LZZ + 1
19881                DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO *
19882      &                      ( WAPS (1,2) + DEPUNS ) )
19883 *  |  |  |
19884 *  |  |  +-------------------------------------------------------------*
19885 *  |  |  |  Set it unbound:
19886             ELSE
19887                DT_ENERGY = AINFNT
19888             END IF
19889 *  |  |  |
19890 *  |  |  +-------------------------------------------------------------*
19891 *  |  |
19892 *  |  +----------------------------------------------------------------*
19893 *  |  |  Proceed as usual:
19894          ELSE
19895 *  |  |  Exp. excess mass for A,IZZ+NZGVAX-1
19896             ENEEXP = WAPS ( KA0, NZGVAX )
19897 *  |  |  Cameron excess mass for A, IZZ+NZGVAX-1
19898             ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) )
19899 *  |  |  Cameron excess mass for A, Z
19900             DT_ENERGY = DT_ENRG( A, Z )
19901 *  |  |  Use just the difference according to Cameron!!!
19902             DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19903          END IF
19904 *  |  |
19905 *  |  +----------------------------------------------------------------*
19906 *  |  Be sure not to have a positive energy state:
19907          DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) )
19908          IZ0    = -1
19909          IF ( IFLAG .EQ. 2 ) THEN
19910             DT_ENKNOW = DT_ENERGY
19911             IZZ0   = -1
19912          END IF
19913          RETURN
19914 *  |
19915 *  +-------------------------------------------------------------------*
19916 *  |  Known isotope or anyway isotope "inside" the stability zone
19917       ELSE
19918          IZ0    = KZ0 - IZZ + 1
19919          DT_ENERGY = WAPS ( KA0, IZ0 )
19920          IF ( IFLAG .EQ. 2 ) IZZ0 = IZ0
19921 *  |  +----------------------------------------------------------------*
19922 *  |  |  Mass not known
19923          IF ( ABS (DT_ENERGY) .LT. ANGLGB .AND. (KA0 .NE. 12 .OR. KZ0
19924      &        .NE. 6) ) THEN
19925             IF ( IFLAG .EQ. 2 ) IZZ0 = -1
19926 *  |  |  +-------------------------------------------------------------*
19927 *  |  |  |  Set it unbound:
19928             IF ( KA0 .LE. KAFREE ) THEN
19929                DT_ENERGY = AINFNT
19930 *  |  |  |
19931 *  |  |  +-------------------------------------------------------------*
19932 *  |  |  |  Try to get a reasonable excess mass:
19933             ELSE
19934                JZ0 = -100
19935 *  |  |  |  +----------------------------------------------------------*
19936 *  |  |  |  |  Check the closest one known:
19937                DO 500 JZZ = 1, NZGVAX
19938                   IF ( ABS ( WAPS (KA0,JZZ) ) .GT. ANGLGB .AND.
19939      &                 ABS (JZZ-IZ0) .LT. ABS (JZ0-IZ0) ) JZ0 = JZZ
19940                   IF ( ABS (JZ0-IZ0) .EQ. 1 ) GO TO 550
19941   500          CONTINUE
19942 *  |  |  |  |
19943 *  |  |  |  +----------------------------------------------------------*
19944   550          CONTINUE
19945 *  |  |  |  Exp. excess mass for A,IZZ+JZ0-1
19946                ENEEXP = WAPS ( KA0, JZ0 )
19947 *  |  |  |  Cameron excess mass for A, IZZ+JZ0-1
19948                ENECA1 = DT_ENRG( A, DBLE (IZZ+JZ0-1) )
19949 *  |  |  |  Cameron excess mass for A, Z
19950                DT_ENERGY = DT_ENRG( A, Z )
19951 *  |  |  |  Use just the difference according to Cameron!!!
19952                DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19953                IZ0    = -1
19954             END IF
19955 *  |  |  |
19956 *  |  |  +-------------------------------------------------------------*
19957 *  |  |  Be sure not to have a positive energy state:
19958             DT_ENERGY = MIN(DT_ENERGY,(A-Z)*WAPS(1,1)+Z*WAPS (1,2) )
19959          END IF
19960 *  |  |
19961 *  |  +----------------------------------------------------------------*
19962          IF ( IFLAG .EQ. 2 ) DT_ENKNOW = DT_ENERGY
19963          RETURN
19964       END IF
19965 *  |
19966 *  +-------------------------------------------------------------------*
19967 *=== End of Function Energy ===========================================*
19968 *     RETURN
19969       END
19970 **
19971
19972 *$ CREATE DT_ENRG.FOR
19973 *COPY DT_ENRG
19974 *                                                                      *
19975 *=== enrg =============================================================*
19976 *                                                                      *
19977       DOUBLE PRECISION FUNCTION DT_ENRG(A,Z)
19978
19979       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19980       SAVE
19981
19982       PARAMETER ( ZERZER = 0.D+00 )
19983       PARAMETER ( ONEONE = 1.D+00 )
19984       PARAMETER ( LUNIN  = 5  )
19985       PARAMETER ( LUNOUT = 6  )
19986 *
19987 *----------------------------------------------------------------------*
19988 *                                                                      *
19989 *     Revised version of the original routine from EVAP:               *
19990 *                                                                      *
19991 *     Created on   15 may 1990     by    Alfredo Ferrari & Paola Sala  *
19992 *                                                   Infn - Milan       *
19993 *                                                                      *
19994 *     Last change on 01-oct-94     by    Alfredo Ferrari               *
19995 *                                                                      *
19996 *     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!     *
19997 *     !!!  It is supposed to be used with the updated atomic   !!!     *
19998 *     !!!                    mass data file                    !!!     *
19999 *     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!     *
20000 *                                                                      *
20001 *----------------------------------------------------------------------*
20002 *
20003       PARAMETER ( O16OLD = 931.145  D+00 )
20004       PARAMETER ( O16NEW = 931.19826D+00 )
20005       PARAMETER ( O16RAT = O16NEW / O16OLD )
20006       PARAMETER ( C12NEW = 931.49432D+00 )
20007       PARAMETER ( ADJUST = -8.322737768178909D-02 )
20008       PARAMETER ( AINFNT = 1.0D+30 )
20009 * (original name: EVA0)
20010       COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
20011      *                FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
20012      *                CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
20013      *                T (4,7), RMASS (297), ALPH (297), BET (297),
20014      *                APRIME (250), IA (6), IZ (6)
20015       LOGICAL LFIRST
20016 CPH      SAVE LFIRST, EXHYDR, EXNEUT
20017       DATA LFIRST / .TRUE. /
20018 *
20019       IF ( LFIRST ) THEN
20020          LFIRST = .FALSE.
20021 **sr 30.6.
20022 C        EXHYDR = DT_ENERGY( ONEONE, ONEONE )
20023 C        EXNEUT = DT_ENERGY( ONEONE, ZERZER )
20024          EXHYDR = A
20025          EXNEUT = Z
20026          DT_ENRG   = -AINFNT
20027          RETURN
20028 **
20029       END IF
20030       IZ0 = NINT (Z)
20031       IF ( IZ0 .LE. 0 ) THEN
20032          DT_ENRG = A * EXNEUT
20033          RETURN
20034       END IF
20035       N   = NINT (A-Z)
20036       IF ( N .LE. 0 ) THEN
20037          DT_ENRG = Z * EXHYDR
20038          RETURN
20039       END IF
20040       AM2ZOA= (A-Z-Z)/A
20041       AM2ZOA=AM2ZOA*AM2ZOA
20042       A13 = RMASS(NINT(A))
20043 *     A13 = A**.3333333333333333D+00
20044       AM13 = 1.D+00/A13
20045       EV=-17.0354D+00*(1.D+00 -1.84619 D+00*AM2ZOA)*A
20046       ES= 25.8357D+00*(1.D+00 -1.712185D+00*AM2ZOA)*
20047      &    (1.D+00 -0.62025D+00*AM13*AM13)*
20048      &    (A13*A13 -.62025D+00)
20049       EC= 0.799D+00*Z*(Z-1.D+00)*AM13*(((1.5772D+00*AM13 +1.2273D+00)*
20050      &    AM13-1.5849D+00)*
20051      &    AM13*AM13 +1.D+00)
20052       EEX= -0.4323D+00*AM13*Z**1.3333333D+00*
20053      &   (((0.49597D+00*AM13 -0.14518D+00)*AM13 -0.57811D+00) * AM13
20054      &   + 1.D+00)
20055       DT_ENRG=8.367D+00*A-0.783D+00*Z +EV +ES +EC +EEX+CAM2(IZ0)+CAM3(N)
20056       DT_ENRG=(DT_ENRG + A * O16OLD ) * O16RAT - A * ( C12NEW - ADJUST )
20057       DT_ENRG  = MIN ( DT_ENRG, Z * EXHYDR + ( A - Z ) * EXNEUT )
20058       RETURN
20059 *=== End of function Enrg =============================================*
20060       END
20061
20062 *$ CREATE DT_INCINI.FOR
20063 *COPY DT_INCINI
20064 *                                                                      *
20065 *=== incini ===========================================================*
20066 *                                                                      *
20067       SUBROUTINE DT_INCINI
20068
20069       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20070       SAVE
20071
20072       PARAMETER ( ZERZER = 0.D+00 )
20073       PARAMETER ( ONEONE = 1.D+00 )
20074       PARAMETER ( TWOTWO = 2.D+00 )
20075       PARAMETER ( THRTHR = 3.D+00 )
20076       PARAMETER ( FOUFOU = 4.D+00 )
20077       PARAMETER ( EIGEIG = 8.D+00 )
20078       PARAMETER ( ANINEN = 9.D+00 )
20079       PARAMETER ( HLFHLF = 0.5D+00 )
20080       PARAMETER ( ONETHI = ONEONE / THRTHR )
20081       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20082       PARAMETER ( PLABRC = 0.197327053        D+00 )
20083       PARAMETER ( AMELCT = 0.51099906         D-03 )
20084       PARAMETER ( AMUGEV = 0.93149432         D+00 )
20085       PARAMETER ( AMPRTN = 0.93827231         D+00 )
20086       PARAMETER ( AMNTRN = 0.93956563         D+00 )
20087       PARAMETER ( AMDEUT = 1.87561339         D+00 )
20088       PARAMETER ( EMVGEV = 1.0                D-03 )
20089
20090       PARAMETER ( LUNOUT = 6  )
20091 *
20092 *----------------------------------------------------------------------*
20093 *                                                                      *
20094 *     Created on  10  june  1990   by    Alfredo Ferrari & Paola Sala  *
20095 *                                                   Infn - Milan       *
20096 *                                                                      *
20097 *     Last change on 02-may-95     by    Alfredo Ferrari               *
20098 *                                                                      *
20099 *                                                                      *
20100 *----------------------------------------------------------------------*
20101 *
20102 * (original name: FHEAVY,FHEAVC)
20103       PARAMETER ( MXHEAV = 100 )
20104       CHARACTER*8 ANHEAV
20105       COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
20106      &                CZHEAV (MXHEAV), TKHEAV (MXHEAV),
20107      &                PHEAVY (MXHEAV), WHEAVY (MXHEAV),
20108      &                AMHEAV  ( 12 ) , AMNHEA  ( 12 ) ,
20109      &                KHEAVY (MXHEAV), ICHEAV  ( 12 ) ,
20110      &                IBHEAV  ( 12 ) , NPHEAV
20111       COMMON /FKFHVC/ ANHEAV  ( 12 )
20112 * (original name: INPFLG)
20113       COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
20114 * (original name: FRBKCM)
20115       PARAMETER ( MXFFBK =     6 )
20116       PARAMETER ( MXZFBK =     9 )
20117       PARAMETER ( MXNFBK =    10 )
20118       PARAMETER ( MXAFBK =    16 )
20119       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
20120       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
20121       PARAMETER ( NXAFBK = MXAFBK + 1 )
20122       PARAMETER ( MXPSST =   300 )
20123       PARAMETER ( MXPSFB = 41000 )
20124       LOGICAL LFRMBK, LNCMSS
20125       COMMON /FKFRBK/  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
20126      &          EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
20127      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
20128      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
20129      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
20130      &          IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
20131      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
20132      &          IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
20133      &          IFBFRB, NBUFBK, LFRMBK, LNCMSS
20134 * (original name: NUCDAT)
20135       PARAMETER ( AMUAMU = AMUGEV )
20136       PARAMETER ( AMPROT = AMPRTN )
20137       PARAMETER ( AMNEUT = AMNTRN )
20138       PARAMETER ( AMELEC = AMELCT )
20139       PARAMETER ( R0NUCL = 1.12        D+00 )
20140       PARAMETER ( RCCOUL = 1.7         D+00 )
20141       PARAMETER ( FERTHO = 14.33       D-09 )
20142       PARAMETER ( EXPEBN = 2.39        D+00 )
20143       PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
20144       PARAMETER ( AMUC12 = AMUGEV - HLFHLF * AMELCT + BEXC12 / 12.D+00 )
20145       PARAMETER ( AMHYDR = AMPRTN + AMELCT  )
20146       PARAMETER ( AMHTON = AMHYDR - AMNTRN  )
20147       PARAMETER ( AMNTOU = AMNTRN - AMUC12  )
20148       PARAMETER ( AMUCSQ = AMUC12 * AMUC12 )
20149       PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 )
20150       PARAMETER ( GAMMIN = 1.0D-06 )
20151       PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN )
20152       PARAMETER ( TVEPSI = GAMMIN / 100.D+00 )
20153       COMMON /FKNDAT/ AV0WEL,     APFRMX,     AEFRMX,     AEFRMA,
20154      &                RDSNUC,     V0WELL (2), PFRMMX (2), EFRMMX (2),
20155      &                EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
20156      &                VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
20157      &                PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
20158      &                EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
20159      &                ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV    ,
20160      &                AMRCSQ    , ATO1O3    , ZTO1O3    , ELBNDE (0:100)
20161 * (original name: PAREVT)
20162       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
20163      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
20164       PARAMETER ( NALLWP = 39   )
20165       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
20166      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
20167      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
20168      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
20169 * (original name: NUCOLD)
20170       COMMON /FKNOLD/ HELP (2), HHLP (2), FTVTH (2), FINCX (2),
20171      &                EKPOLD (2), BBOLD, ZZOLD, SQROLD, ASEASQ,
20172      &                FSPRED, FEX0RD
20173 *
20174       BBOLD  = - 1.D+10
20175       ZZOLD  = - 1.D+10
20176       SQROLD = - 1.D+10
20177       APFRMX = PLABRC * ( ANINEN * PIPIPI / EIGEIG )**ONETHI / R0NUCL
20178       AMNUCL (1) = AMPROT
20179       AMNUCL (2) = AMNEUT
20180       AMNUSQ (1) = AMPROT * AMPROT
20181       AMNUSQ (2) = AMNEUT * AMNEUT
20182       AMNHLP = HLFHLF * ( AMNUCL (1) + AMNUCL (2) )
20183       ASQHLP = AMNHLP**2
20184 *     ASQHLP = HLFHLF * ( AMNUSQ (1) + AMNUSQ (2) )
20185       AEFRMX = SQRT ( ASQHLP + APFRMX**2 ) - AMNHLP
20186       AEFRMA = 0.3D+00 * APFRMX**2 / AMNHLP * ( ONEONE - APFRMX**2 /
20187      &         ( 5.6D+00 * ASQHLP ) )
20188       AV0WEL = AEFRMX + EBNDAV
20189       EBNDNG (1) = EBNDAV
20190       EBNDNG (2) = EBNDAV
20191       AEXC12 = EMVGEV * DT_ENERGY( 12.D+00, 6.D+00 )
20192       CEXC12 = EMVGEV * DT_ENRG( 12.D+00, 6.D+00 )
20193       AMMC12 = 12.D+00 * AMUGEV + AEXC12
20194       AMNC12 = AMMC12 - 6.D+00 * AMELCT + FERTHO * 6.D+00**EXPEBN
20195       AEXO16 = EMVGEV * DT_ENERGY( 16.D+00, 8.D+00 )
20196       CEXO16 = EMVGEV * DT_ENRG( 16.D+00, 8.D+00 )
20197       AMMO16 = 16.D+00 * AMUGEV + AEXO16
20198       AMNO16 = AMMO16 - 8.D+00 * AMELCT + FERTHO * 8.D+00**EXPEBN
20199       AEXS28 = EMVGEV * DT_ENERGY( 28.D+00, 14.D+00 )
20200       CEXS28 = EMVGEV * DT_ENRG( 28.D+00, 14.D+00 )
20201       AMMS28 = 28.D+00 * AMUGEV + AEXS28
20202       AMNS28 = AMMS28 - 14.D+00 * AMELCT + FERTHO * 14.D+00**EXPEBN
20203       AEXC40 = EMVGEV * DT_ENERGY( 40.D+00, 20.D+00 )
20204       CEXC40 = EMVGEV * DT_ENRG( 40.D+00, 20.D+00 )
20205       AMMC40 = 40.D+00 * AMUGEV + AEXC40
20206       AMNC40 = AMMC40 - 20.D+00 * AMELCT + FERTHO * 20.D+00**EXPEBN
20207       AEXF56 = EMVGEV * DT_ENERGY( 56.D+00, 26.D+00 )
20208       CEXF56 = EMVGEV * DT_ENRG( 56.D+00, 26.D+00 )
20209       AMMF56 = 56.D+00 * AMUGEV + AEXF56
20210       AMNF56 = AMMF56 - 26.D+00 * AMELCT + FERTHO * 26.D+00**EXPEBN
20211       AEX107 = EMVGEV * DT_ENERGY( 107.D+00, 47.D+00 )
20212       CEX107 = EMVGEV * DT_ENRG( 107.D+00, 47.D+00 )
20213       AMM107 = 107.D+00 * AMUGEV + AEX107
20214       AMN107 = AMM107 - 47.D+00 * AMELCT + FERTHO * 47.D+00**EXPEBN
20215       AEX132 = EMVGEV * DT_ENERGY( 132.D+00, 54.D+00 )
20216       CEX132 = EMVGEV * DT_ENRG( 132.D+00, 54.D+00 )
20217       AMM132 = 132.D+00 * AMUGEV + AEX132
20218       AMN132 = AMM132 - 54.D+00 * AMELCT + FERTHO * 54.D+00**EXPEBN
20219       AEX181 = EMVGEV * DT_ENERGY( 181.D+00, 73.D+00 )
20220       CEX181 = EMVGEV * DT_ENRG( 181.D+00, 73.D+00 )
20221       AMM181 = 181.D+00 * AMUGEV + AEX181
20222       AMN181 = AMM181 - 73.D+00 * AMELCT + FERTHO * 73.D+00**EXPEBN
20223       AEX208 = EMVGEV * DT_ENERGY( 208.D+00, 82.D+00 )
20224       CEX208 = EMVGEV * DT_ENRG( 208.D+00, 82.D+00 )
20225       AMM208 = 208.D+00 * AMUGEV + AEX208
20226       AMN208 = AMM208 - 82.D+00 * AMELCT + FERTHO * 82.D+00**EXPEBN
20227       AEX238 = EMVGEV * DT_ENERGY( 238.D+00, 92.D+00 )
20228       CEX238 = EMVGEV * DT_ENRG( 238.D+00, 92.D+00 )
20229       AMM238 = 238.D+00 * AMUGEV + AEX238
20230       AMN238 = AMM238 - 92.D+00 * AMELCT + FERTHO * 92.D+00**EXPEBN
20231
20232       AMHEAV (1) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ZERZER )
20233       AMHEAV (2) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ONEONE )
20234       AMHEAV (3) = TWOTWO * AMUGEV
20235      &             + EMVGEV * DT_ENERGY( TWOTWO, ONEONE )
20236       AMHEAV (4) = THRTHR * AMUGEV
20237      &             + EMVGEV * DT_ENERGY( THRTHR, ONEONE )
20238       AMHEAV (5) = THRTHR * AMUGEV
20239      &             + EMVGEV * DT_ENERGY( THRTHR, TWOTWO )
20240       AMHEAV (6) = FOUFOU * AMUGEV
20241      &             + EMVGEV * DT_ENERGY( FOUFOU, TWOTWO )
20242       ELBNDE (0) = ZERZER
20243       ELBNDE (1) = 13.6D-09
20244       DO 2000 IZ = 2, 100
20245          ELBNDE ( IZ ) = FERTHO * DBLE ( IZ )**EXPEBN
20246 2000  CONTINUE
20247       AMNHEA (1) = AMHEAV (1) + ELBNDE (0)
20248       AMNHEA (2) = AMHEAV (2) - AMELCT + ELBNDE (1)
20249       AMNHEA (3) = AMHEAV (3) - AMELCT + ELBNDE (1)
20250       AMNHEA (4) = AMHEAV (4) - AMELCT + ELBNDE (1)
20251       AMNHEA (5) = AMHEAV (5) - TWOTWO * AMELCT + ELBNDE (2)
20252       AMNHEA (6) = AMHEAV (6) - TWOTWO * AMELCT + ELBNDE (2)
20253       IF ( LEVPRT ) THEN
20254          WRITE ( LUNOUT, * )' **** Evaporation from residual nucleus',
20255      &                      ' activated **** '
20256          IF ( LDEEXG ) WRITE ( LUNOUT, * )' **** Deexcitation gamma',
20257      &                      ' production activated **** '
20258 **sr 18.5.95
20259 * commented, since obsolete
20260 C        IF ( LHEAVY ) WRITE ( LUNOUT, * )' **** Evaporated "heavies"',
20261 C    &                      ' transport activated **** '
20262          IF ( IFISS .GT. 0 )
20263      &                 WRITE ( LUNOUT, * )' **** High Energy fission ',
20264      &                      ' requested & activated **** '
20265          IF ( LFRMBK )
20266      &                 WRITE ( LUNOUT, * )' **** Fermi Break Up ',
20267      &                      ' requested & activated **** '
20268          IF ( LFRMBK ) CALL DT_FRBKIN(.FALSE.,.FALSE.)
20269       ELSE
20270          LDEEXG = .FALSE.
20271          LHEAVY = .FALSE.
20272          LFRMBK = .FALSE.
20273          IFISS  = 0
20274       END IF
20275       RETURN
20276 *=== End of subroutine incini =========================================*
20277       END
20278
20279 *$ CREATE DT_STALIN.FOR
20280 *COPY DT_STALIN
20281 *                                                                      *
20282 *=== stalin ===========================================================*
20283 *                                                                      *
20284       SUBROUTINE DT_STALIN
20285
20286       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20287       SAVE
20288       PARAMETER ( ANGLGB = 5.0D-16 )
20289       PARAMETER ( ZERZER = 0.D+00 )
20290       PARAMETER ( ONEONE = 1.D+00 )
20291       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20292       PARAMETER ( AMUGEV = 0.93149432         D+00 )
20293       PARAMETER ( EMVGEV = 1.0                D-03 )
20294       PARAMETER ( NSTBIS = 304  )
20295       PARAMETER ( LUNIN  = 5  )
20296       PARAMETER ( LUNOUT = 6  )
20297 *
20298 *----------------------------------------------------------------------*
20299 *                                                                      *
20300 *     STAbility LINe calculation:                                      *
20301 *                                                                      *
20302 *     Created on 04 december 1992  by    Alfredo Ferrari & Paola Sala  *
20303 *                                                   Infn - Milan       *
20304 *                                                                      *
20305 *     Last change on 04-dec-92     by    Alfredo Ferrari               *
20306 *                                                                      *
20307 *                                                                      *
20308 *----------------------------------------------------------------------*
20309 *
20310 * (original name: ISOTOP)
20311       PARAMETER ( NAMSMX = 270 )
20312       PARAMETER ( NZGVAX =  15 )
20313       PARAMETER ( NISMMX = 574 )
20314       COMMON /FKISOT/ WAPS   (NAMSMX,NZGVAX),  T12NUC (NAMSMX,NZGVAX),
20315      &                WAPISM (NISMMX), T12ISM (NISMMX),
20316      &                ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
20317      &                AMSSST (100)  , ISOMNM (NSTBIS), ISONDX (2,100),
20318      &                JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
20319      &                INWAPS (NAMSMX), JSPISM (NISMMX),
20320      &                JPTISM (NISMMX), IZWISM (NISMMX),
20321      &                INWISM (0:NAMSMX)
20322 *
20323       DIMENSION ZNORM (260)
20324 *  +-------------------------------------------------------------------*
20325 *  |
20326       DO 1000 IZ=1,100
20327          DO 500 J=1,2
20328             ASTLIN (J,IZ) = ZERZER
20329   500    CONTINUE
20330  1000 CONTINUE
20331 *  |
20332 *  +-------------------------------------------------------------------*
20333 *  +-------------------------------------------------------------------*
20334 *  |
20335       DO 2000 IA=1,260
20336          ZNORM (IA) = ZERZER
20337          DO 1500 J=1,2
20338             ZSTLIN (J,IA) = ZERZER
20339  1500    CONTINUE
20340  2000 CONTINUE
20341 *  |
20342 *  +-------------------------------------------------------------------*
20343 *  +-------------------------------------------------------------------*
20344 *  |  Loop on the Atomic Number
20345       DO 3000 IZ=1,100
20346          AMSSST (IZ) = ZERZER
20347          ANORM       = ONEONE
20348          ZTAR        = IZ
20349 *  |  +----------------------------------------------------------------*
20350 *  |  |    Loop on the stable isotopes
20351          DO 2500 IS = ISONDX (1,IZ), ISONDX (2,IZ)
20352             IA = ISOMNM (IS)
20353             ASTLIN (1,IZ) = ASTLIN (1,IZ) + ABUISO (IS) * IA
20354             ASTLIN (2,IZ) = ASTLIN (2,IZ) + ABUISO (IS) * IA**2
20355             ZNORM    (IA) = ZNORM (IA) + ABUISO (IS)
20356             ZSTLIN (1,IA) = ZSTLIN (1,IA) + ABUISO (IS) * IZ
20357             ZSTLIN (2,IA) = ZSTLIN (2,IA) + ABUISO (IS) * IZ**2
20358             AHELP  = IA
20359             IF ( AHELP .LE. 1.00001D+00 ) THEN
20360                ANORM = ONEONE / ( ONEONE - ABUISO (IS) )
20361                GO TO 2500
20362             END IF
20363             AMSSST (IZ) = ABUISO (IS) * ( AHELP * AMUGEV
20364      &                  + EMVGEV * DT_ENERGY(AHELP,ZTAR) ) + AMSSST (IZ)
20365  2500    CONTINUE
20366 *  |  |
20367 *  |  +----------------------------------------------------------------*
20368          AMSSST (IZ) = ANORM * AMSSST (IZ) / AMUGEV
20369 *  |  Normalize and print A_stab versus Z data:
20370          ASTLIN (2,IZ) = MAX ( SQRT (ASTLIN(2,IZ)-ASTLIN(1,IZ)**2),
20371      &                         0.5D+00 )
20372 *        WRITE (LUNOUT,*)'  Z:',IZ,' A_stab:',SNGL(ASTLIN(1,IZ)),
20373 *    &                   '  Sigma_st',SNGL(ASTLIN(2,IZ))
20374  3000 CONTINUE
20375 *  |
20376 *  +-------------------------------------------------------------------*
20377 *  +-------------------------------------------------------------------*
20378 *  |  Normalize and print Z_stab versus A data:
20379       DO 4000 IA=1,260
20380          ZSTLIN (1,IA) = ZSTLIN (1,IA) / MAX ( ZNORM (IA), 1.D-10 )
20381          ZSTLIN (2,IA) = ZSTLIN (2,IA) / MAX ( ZNORM (IA), 1.D-10 )
20382          ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ZSTLIN (1,IA)**2 )
20383          IF ( ZNORM (IA) .GT. ANGLGB )
20384 **sr 2.11. avoid underflows at Pentium
20385      &      ZSTLIN (2,IA) =
20386      &               MAX ( SQRT ( ABS(ZSTLIN(2,IA)-ZSTLIN(1,IA)**2) ),
20387 C    &      ZSTLIN (2,IA) = MAX ( SQRT (ZSTLIN(2,IA)-ZSTLIN(1,IA)**2),
20388      &                            0.3D+00 )
20389  4000 CONTINUE
20390 *  |
20391 *  +-------------------------------------------------------------------*
20392 *  +-------------------------------------------------------------------*
20393 *  |  Normalize and print Z_stab versus A data:
20394       DO 5000 IA=1,260
20395          IF ( ZNORM (IA) .LE. ANGLGB ) THEN
20396             DO 4200 JA = IA-1,1,-1
20397                IF ( ZNORM (JA) .GT. ANGLGB ) THEN
20398                   IA1 = JA
20399                   GO TO 4300
20400                END IF
20401  4200       CONTINUE
20402  4300       CONTINUE
20403             DO 4400 JA = IA+1,260
20404                IF ( ZNORM (JA) .GT. ANGLGB ) THEN
20405                   IA2 = JA
20406                   GO TO 4500
20407                END IF
20408  4400       CONTINUE
20409             IA2 = IA1
20410             IA1 = IA1 - 1
20411  4500       CONTINUE
20412             ZSTLIN (1,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1)
20413      &                    * ( ZSTLIN (1,IA2) - ZSTLIN (1,IA1) )
20414      &                    + ZSTLIN (1,IA1)
20415             ZSTLIN (2,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1)
20416      &                    * ( ZSTLIN (2,IA2) - ZSTLIN (2,IA1) )
20417      &                    + ZSTLIN (2,IA1)
20418          END IF
20419          IZ = MIN ( 100, NINT (ZSTLIN(1,IA)) )
20420          ATOZ = IZ / ASTLIN (1,IZ)
20421          ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ATOZ * ASTLIN (2,IZ) )
20422 *        WRITE (LUNOUT,*)'  A:',IA,' Z_stab:',SNGL(ZSTLIN(1,IA)),
20423 *    &                   '  Sigma_st',SNGL(ZSTLIN(2,IA))
20424  5000 CONTINUE
20425 *  |
20426 *  +-------------------------------------------------------------------*
20427       RETURN
20428       END
20429
20430 *$ CREATE DT_BERTTP.FOR
20431 *COPY DT_BERTTP
20432 *
20433 *=== berttp ===========================================================*
20434 *                                                                      *
20435       SUBROUTINE DT_BERTTP
20436
20437       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20438       SAVE
20439
20440       PARAMETER ( CSNNRM = 2.0D-15 )
20441       PARAMETER ( ZERZER = 0.D+00 )
20442       PARAMETER ( ONEONE = 1.D+00 )
20443       PARAMETER ( THRTHR = 3.D+00 )
20444       PARAMETER ( SIXSIX = 6.D+00 )
20445       PARAMETER ( ONETHI = ONEONE / THRTHR )
20446       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20447       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
20448       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
20449       PARAMETER ( EMVGEV = 1.0                D-03 )
20450
20451       PARAMETER ( NSTBIS = 304  )
20452
20453       PARAMETER ( LUNIN  = 5  )
20454       PARAMETER ( LUNOUT = 6  )
20455 **sr 19.5. set error output-unit from 15 to 6
20456       PARAMETER ( LUNERR = 6  )
20457 C---------------------------------------------------------------------
20458 C SUBNAME = DT_BERTTP --- READ BERTINI DATA
20459 C---------------------------------------------------------------------
20460 C     ---------------------------------- I-N-C DATA
20461 C     COMMON R8(2127),R4(64),CRSC(600,4),R8B(336),CS(29849)
20462 C     REAL*8 R8,R8B,CRSC,CS
20463 C     REAL*4 R4
20464 C     --------------------------------- EVAPORATION DATA
20465 * (original name: COOKCM)
20466       PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 )
20467       LOGICAL LDEFOZ, LDEFON
20468       PARAMETER ( INCOOK = 150, IZCOOK = 98 )
20469       COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN,
20470      &                SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK),
20471      &                PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK)
20472 * (original name: EVA0)
20473       COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
20474      *                FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
20475      *                CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
20476      *                T (4,7), RMASS (297), ALPH (297), BET (297),
20477      *                APRIME (250), IA (6), IZ (6)
20478 * (original name: FRBKCM)
20479       PARAMETER ( MXFFBK =     6 )
20480       PARAMETER ( MXZFBK =     9 )
20481       PARAMETER ( MXNFBK =    10 )
20482       PARAMETER ( MXAFBK =    16 )
20483       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
20484       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
20485       PARAMETER ( NXAFBK = MXAFBK + 1 )
20486       PARAMETER ( MXPSST =   300 )
20487       PARAMETER ( MXPSFB = 41000 )
20488       LOGICAL LFRMBK, LNCMSS
20489       COMMON /FKFRBK/  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
20490      &          EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
20491      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
20492      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
20493      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
20494      &          IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
20495      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
20496      &          IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
20497      &          IFBFRB, NBUFBK, LFRMBK, LNCMSS
20498 * (original name: HETTP)
20499       COMMON /FKHETP/  NHSTP,NBERTP,IOSUB,INSRS
20500 * (original name: INPFLG)
20501       COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
20502 * (original name: ISOTOP)
20503       PARAMETER ( NAMSMX = 270 )
20504       PARAMETER ( NZGVAX =  15 )
20505       PARAMETER ( NISMMX = 574 )
20506       COMMON /FKISOT/ WAPS   (NAMSMX,NZGVAX),  T12NUC (NAMSMX,NZGVAX),
20507      &                WAPISM (NISMMX), T12ISM (NISMMX),
20508      &                ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
20509      &                AMSSST (100)  , ISOMNM (NSTBIS), ISONDX (2,100),
20510      &                JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
20511      &                INWAPS (NAMSMX), JSPISM (NISMMX),
20512      &                JPTISM (NISMMX), IZWISM (NISMMX),
20513      &                INWISM (0:NAMSMX)
20514 * (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII)
20515       PARAMETER ( PI     = PIPIPI )
20516       PARAMETER ( PISQ   = PIPISQ )
20517       PARAMETER ( SKTOHL = 0.5456645846610345D+00 )
20518       PARAMETER ( RZNUCL = 1.12        D+00 )
20519       PARAMETER ( RMSPRO = 0.8         D+00 )
20520       PARAMETER ( R0PROT = RMSPRO / SQRT12  )
20521       PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT
20522      &          / R0PROT )
20523       PARAMETER ( RLLE04 = RZNUCL )
20524       PARAMETER ( RLLE16 = RZNUCL )
20525       PARAMETER ( RLGT16 = RZNUCL )
20526       PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 )
20527       PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 )
20528       PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 )
20529       PARAMETER ( SKLE04 = 1.4D+00 )
20530       PARAMETER ( SKLE16 = 1.9D+00 )
20531       PARAMETER ( SKGT16 = 2.4D+00 )
20532       PARAMETER ( HLLE04 = SKTOHL * SKLE04 )
20533       PARAMETER ( HLLE16 = SKTOHL * SKLE16 )
20534       PARAMETER ( HLGT16 = SKTOHL * SKGT16 )
20535       PARAMETER ( ALPHA0 = 0.1D+00 )
20536       PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 )
20537       PARAMETER ( GAMSK0 = 0.9D+00 )
20538       PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 )
20539       PARAMETER ( POTME0 = 0.6666666666666667D+00 )
20540       PARAMETER ( POTBA0 = 1.D+00 )
20541       PARAMETER ( PNFRAT = 1.533D+00 )
20542       PARAMETER ( RADPIM = 0.035D+00 )
20543       PARAMETER ( RDPMHL = 14.D+00   )
20544       PARAMETER ( APMRST = 4.D+00 / 44.D+00 )
20545       PARAMETER ( APMPRO = 1.D+00 / 6.D+00 )
20546       PARAMETER ( APPPRO = 5.D+00 / 6.D+00 )
20547       PARAMETER ( AP0PFS = 0.5D+00 )
20548       PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 )
20549       PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 )
20550       PARAMETER ( XPAUCO = 1.88495407241652 D+00 )
20551       PARAMETER ( MXSCIN = 50     )
20552       LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY,
20553      &        LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC
20554       COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260),
20555      &                RADTAB (2:260), SKITAB (2:260), HALTAB (2:260),
20556      &                SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260),
20557      &                CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260),
20558      &                PFRTAB (2:260)
20559       COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP,
20560      &                ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO,
20561      &                RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR,
20562      &                YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN,
20563      &                RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM,
20564      &                PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2,
20565      &                PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT,
20566      &                BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2,
20567      &                YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3,
20568      &                XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC,
20569      &                SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ,
20570      &                R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE,
20571      &                PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY,
20572      &                EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ,
20573      &                PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM,
20574      &                EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3,
20575      &                PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM,
20576      &                BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN
20577       COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2),
20578      &                RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN,
20579      &                EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF,
20580      &                BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC,
20581      &                WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES,
20582      &                POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND,
20583      &                BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4),
20584      &                SIGPAB (3), SIGNAB (3), HHLP   (2), FORTOT (2),
20585      &                FPNBLC, DPNBLC, FFTFLG, IFTFLG,
20586      &                IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2,
20587      &                KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3,
20588      &                NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM,
20589      &                IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ,
20590      &                LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC
20591       COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT
20592       COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN),
20593      &                YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN),
20594      &                AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX,
20595      &                NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN),
20596      &                NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN),
20597      &                ISCTYP (0:MXSCIN), NUSCIN, NEXPEM,
20598      &                LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH,
20599      &                LNCDCY, LNUSCT
20600       DIMENSION AWSTAB (2:260), SIGMAB (3)
20601       EQUIVALENCE ( DEFPRO, DEFNUC (1) )
20602       EQUIVALENCE ( DEFNEU, DEFNUC (2) )
20603       EQUIVALENCE ( RHOIPP, RHONCP (1) )
20604       EQUIVALENCE ( RHOINP, RHONCP (2) )
20605       EQUIVALENCE ( RHOIP2, RHONC2 (1) )
20606       EQUIVALENCE ( RHOIN2, RHONC2 (2) )
20607       EQUIVALENCE ( RHOIP3, RHONC3 (1) )
20608       EQUIVALENCE ( RHOIN3, RHONC3 (2) )
20609       EQUIVALENCE ( RHOIPT, RHONCT (1) )
20610       EQUIVALENCE ( RHOINT, RHONCT (2) )
20611       EQUIVALENCE ( OMALHL, SK3PAR )
20612       EQUIVALENCE ( ALPHAL, HABPAR )
20613       EQUIVALENCE ( ALPTAB (2), AWSTAB (2) )
20614       EQUIVALENCE ( SIGMPE, SIGMPR (1) )
20615       EQUIVALENCE ( SIGMPC, SIGMPR (2) )
20616       EQUIVALENCE ( SIGMPI, SIGMPR (3) )
20617       EQUIVALENCE ( SIGMPA, SIGMPR (4) )
20618       EQUIVALENCE ( SIGMNE, SIGMNU (1) )
20619       EQUIVALENCE ( SIGMNC, SIGMNU (2) )
20620       EQUIVALENCE ( SIGMNI, SIGMNU (3) )
20621       EQUIVALENCE ( SIGMNA, SIGMNU (4) )
20622       EQUIVALENCE ( SIGMA2, SIGPAB (1) )
20623       EQUIVALENCE ( SIGMA3, SIGPAB (2) )
20624       EQUIVALENCE ( SIGMAS, SIGPAB (3) )
20625       EQUIVALENCE ( SIGPAB (1), SIGMAB (1) )
20626 * (original name: NUCLEV)
20627       LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL
20628       COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2),
20629      &                DEFMAG (2), ENNCLV (160,2), RANCLV (160,2),
20630      &                CUMRAD (0:160,2), RUSNUC (2),
20631      &                ENPLVL (114), ENNLVL(164), JUSNUC (160,2),
20632      &                NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2),
20633      &                NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2),
20634      &                JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8),
20635      &                MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2),
20636      &                NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL,
20637      &                LFLVSL, LRLVSL, LEQSBL
20638       DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8),
20639      &          MGSSPR (19) , MGSSNE (25)
20640       EQUIVALENCE ( RUSNUC (1), RUSPRO )
20641       EQUIVALENCE ( RUSNUC (2), RUSNEU )
20642       EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) )
20643       EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) )
20644       EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) )
20645       EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) )
20646       EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) )
20647       EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) )
20648       EQUIVALENCE ( NTANUC (1), NTAPRO )
20649       EQUIVALENCE ( NTANUC (2), NTANEU )
20650       EQUIVALENCE ( NAVNUC (1), NAVPRO )
20651       EQUIVALENCE ( NAVNUC (2), NAVNEU )
20652       EQUIVALENCE ( NLSNUC (1), NLSPRO )
20653       EQUIVALENCE ( NLSNUC (2), NLSNEU )
20654       EQUIVALENCE ( NCONUC (1), NCOPRO )
20655       EQUIVALENCE ( NCONUC (2), NCONEU )
20656       EQUIVALENCE ( NSKNUC (1), NSKPRO )
20657       EQUIVALENCE ( NSKNUC (2), NSKNEU )
20658       EQUIVALENCE ( NHANUC (1), NHAPRO )
20659       EQUIVALENCE ( NHANUC (2), NHANEU )
20660       EQUIVALENCE ( NUSNUC (1), NUSPRO )
20661       EQUIVALENCE ( NUSNUC (2), NUSNEU )
20662       EQUIVALENCE ( NACNUC (1), NACPRO )
20663       EQUIVALENCE ( NACNUC (2), NACNEU )
20664       EQUIVALENCE ( JMXNUC (1), JMXPRO )
20665       EQUIVALENCE ( JMXNUC (2), JMXNEU )
20666       EQUIVALENCE ( MAGNUC (1), MAGPRO )
20667       EQUIVALENCE ( MAGNUC (2), MAGNEU )
20668 * (original name: PAREVT)
20669       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
20670      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
20671       PARAMETER ( NALLWP = 39   )
20672       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
20673      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
20674      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
20675      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
20676 * (original name: XSEPAR)
20677       COMMON /FKXSEP/ AANXSE (100), BBNXSE (100), CCNXSE (100),
20678      &                DDNXSE (100), EENXSE (100), ZZNXSE (100),
20679      &                EMNXSE (100), XMNXSE (100),
20680      &                AAPXSE (100), BBPXSE (100), CCPXSE (100),
20681      &                DDPXSE (100), EEPXSE (100), FFPXSE (100),
20682      &                ZZPXSE (100), EMPXSE (100), XMPXSE (100)
20683
20684 C---------------------------------------------------------------------
20685 **sr 17.5.95
20686 * modified for use in DPMJET
20687 C     WRITE( LUNOUT,'(A,I2)')
20688 C    & ' *** Reading evaporation and nuclear data from unit: ', NBERTP
20689 C     REWIND NBERTP
20690       IF (LEVPRT) WRITE(LUNOUT,1000)
20691  1000 FORMAT(/,1X,'BERTTP:',4X,'Initialization of evaporation module',
20692      &       /,12X,'------------------------------------',/)
20693       NBERNW = 23
20694 CPH      OPEN (UNIT=NBERNW,FILE='dpmjet.dat',STATUS='UNKNOWN')
20695
20696 **sr 17.5.
20697 *!!!! changed to be able to read the ASCII !!!!
20698 **
20699 C A. Ferrari: first of all read isotopic data
20700       READ (NBERNW,*) ISONDX
20701       READ (NBERNW,*) ISOMNM
20702       READ (NBERNW,*) ABUISO
20703 C     READ (NBERTP) ISONDX
20704 C     READ (NBERTP) ISOMNM
20705 C     READ (NBERTP) ABUISO
20706       DO 1 I=1,4
20707 C        READ  (NBERTP) (CRSC(J,I),J=1,600)
20708 C A. Ferrari: commented also the dummy read to save disk space
20709 C        READ  (NBERTP)
20710     1 CONTINUE
20711 C     READ  (NBERTP) CS
20712 C A. Ferrari: commented also the dummy read to save disk space
20713 C     READ  (NBERTP)
20714 C---------------------------------------------------------------------
20715       READ (NBERNW,*) (P0(I),P1(I),P2(I),I=1,1001)
20716       READ (NBERNW,*) IA,IZ
20717       DO 2 I=1,6
20718          FLA(I)=IA(I)
20719          FLZ(I)=IZ(I)
20720     2 CONTINUE
20721       READ (NBERNW,*) RHO,OMEGA
20722       READ (NBERNW,*) EXMASS
20723       READ (NBERNW,*) CAM2
20724       READ (NBERNW,*) CAM3
20725       READ (NBERNW,*) CAM4
20726       READ (NBERNW,*) CAM5
20727       READ (NBERNW,*) ((T(I,J),J=1,7),I=1,3)
20728       DO 3 I=1,7
20729          T(4,I) = ZERZER
20730     3 CONTINUE
20731       READ (NBERNW,*) RMASS
20732       READ (NBERNW,*) ALPH
20733       READ (NBERNW,*) BET
20734       READ (NBERNW,*) INWAPS
20735       READ (NBERNW,*) WAPS
20736       READ (NBERNW,*) T12NUC
20737       READ (NBERNW,*) JSPNUC
20738       READ (NBERNW,*) JPTNUC
20739       READ (NBERNW,*) INWISM
20740       READ (NBERNW,*) IZWISM
20741       READ (NBERNW,*) WAPISM
20742       READ (NBERNW,*) T12ISM
20743       READ (NBERNW,*) JSPISM
20744       READ (NBERNW,*) JPTISM
20745       READ (NBERNW,*) APRIME
20746       IF (LEVPRT)
20747      &WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***'
20748       READ (NBERNW,*) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP
20749       IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR.
20750      &     ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN
20751          WRITE (LUNOUT,*)
20752      &         ' *** Inconsistent Nuclear Geometry data on file ***'
20753          STOP
20754       END IF
20755       READ (NBERNW,*) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB,
20756      &              EKATAB, PFATAB, PFRTAB
20757       READ (NBERNW,*) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE,
20758      &              EMNXSE, XMNXSE
20759       READ (NBERNW,*) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE,
20760      &              ZZPXSE, EMPXSE, XMPXSE
20761 *  Data about Fermi-breakup:
20762       READ (NBERNW,*) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF
20763       IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE.
20764      &     MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN
20765          WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data',
20766      &                   ' in the Nuclear Data file ***'
20767          STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA'
20768       END IF
20769       READ (NBERNW,*) IFRBKN
20770       READ (NBERNW,*) IFRBKZ
20771       READ (NBERNW,*) IFBKSP
20772       READ (NBERNW,*) IFBKST
20773       READ (NBERNW,*) EEXFBK
20774
20775       CLOSE (UNIT=NBERNW)
20776
20777 C     READ (NBERTP) (P0(I),P1(I),P2(I),I=1,1001)
20778 C     READ (NBERTP) IA,IZ
20779 C     DO 2 I=1,6
20780 C        FLA(I)=IA(I)
20781 C        FLZ(I)=IZ(I)
20782 C   2 CONTINUE
20783 C     READ (NBERTP) RHO,OMEGA
20784 C     READ (NBERTP) EXMASS
20785 C     READ (NBERTP) CAM2
20786 C     READ (NBERTP) CAM3
20787 C     READ (NBERTP) CAM4
20788 C     READ (NBERTP) CAM5
20789 C     READ (NBERTP) ((T(I,J),J=1,7),I=1,3)
20790 C     DO 3 I=1,7
20791 C        T(4,I) = ZERZER
20792 C   3 CONTINUE
20793 C     READ (NBERTP) RMASS
20794 C     READ (NBERTP) ALPH
20795 C     READ (NBERTP) BET
20796 C     READ (NBERTP) INWAPS
20797 C     READ (NBERTP) WAPS
20798 C     READ (NBERTP) T12NUC
20799 C     READ (NBERTP) JSPNUC
20800 C     READ (NBERTP) JPTNUC
20801 C     READ (NBERTP) INWISM
20802 C     READ (NBERTP) IZWISM
20803 C     READ (NBERTP) WAPISM
20804 C     READ (NBERTP) T12ISM
20805 C     READ (NBERTP) JSPISM
20806 C     READ (NBERTP) JPTISM
20807 C     READ (NBERTP) APRIME
20808 C     WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***'
20809 C     READ (NBERTP) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP
20810 C     IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR.
20811 C    &     ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN
20812 C        WRITE (LUNOUT,*)
20813 C    &         ' *** Inconsistent Nuclear Geometry data on file ***'
20814 C        STOP
20815 C     END IF
20816 C     READ (NBERTP) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB,
20817 C    &              EKATAB, PFATAB, PFRTAB
20818 C     READ (NBERTP) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE,
20819 C    &              EMNXSE, XMNXSE
20820 C     READ (NBERTP) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE,
20821 C    &              ZZPXSE, EMPXSE, XMPXSE
20822 *  Data about Fermi-breakup:
20823 C     READ (NBERTP) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF
20824 C     IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE.
20825 C    &     MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN
20826 C        WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data',
20827 C    &                   ' in the Nuclear Data file ***'
20828 C        STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA'
20829 C     END IF
20830 C     READ (NBERTP) IFRBKN
20831 C     READ (NBERTP) IFRBKZ
20832 C     READ (NBERTP) IFBKSP
20833 C     READ (NBERTP) IFBKST
20834 C     READ (NBERTP) EEXFBK
20835 C     CLOSE (UNIT=NBERTP)
20836       DO 100 JZ = 1, 130
20837          SHENUC ( JZ, 1 ) = EMVGEV * ( CAM2 (JZ) + CAM4 (JZ) )
20838   100 CONTINUE
20839       DO 200 JA = 1, 200
20840          SHENUC ( JA, 2 ) = EMVGEV * ( CAM3 (JA) + CAM5 (JA) )
20841   200 CONTINUE
20842       CALL DT_STALIN
20843       IF ( ILVMOD .LE. 0 ) THEN
20844          ILVMOD = IB0
20845       ELSE
20846          IB0 = ILVMOD
20847       END IF
20848       IF ( LLVMOD ) THEN
20849          DO 300 JZ = 1, IZCOOK
20850             CAM4 (JZ) = PZCOOK (JZ)
20851   300    CONTINUE
20852          DO 400 JN = 1, INCOOK
20853             CAM5 (JN) = PNCOOK (JZ)
20854   400    CONTINUE
20855       END IF
20856 **sr
20857       IF (LEVPRT) THEN
20858          WRITE (LUNOUT,*)
20859          IF ( ILVMOD .EQ. 1 ) THEN
20860             WRITE (LUNOUT,*)
20861      &   ' **** Standard EVAP T=0 level density used ****'
20862          ELSE IF ( ILVMOD .EQ. 2 ) THEN
20863             WRITE (LUNOUT,*)
20864      &   ' **** Gilbert & Cameron T=0 N,Z-dep. level density used ****'
20865          ELSE IF ( ILVMOD .EQ. 3 ) THEN
20866             WRITE (LUNOUT,*)
20867      &      ' **** Julich A-dependent level density used ****'
20868          ELSE IF ( ILVMOD .EQ. 4 ) THEN
20869             WRITE (LUNOUT,*)
20870      &   ' **** Brancazio & Cameron T=0 N,Z-dep. level density used',
20871      &                                                          ' ****'
20872          ELSE
20873             WRITE (LUNOUT,*)
20874      &   ' **** Unknown T=0 level density option requested ****'
20875             STOP 'BERTTP-ILVMOD'
20876          END IF
20877          IF ( JLVMOD .LE. 0 ) THEN
20878             GAMIGN = ZERZER
20879             WRITE (LUNOUT,*)
20880      &   ' **** No Excitation en. dependence for level densities ****'
20881          ELSE IF ( JLVMOD .EQ. 1 ) THEN
20882             WRITE (LUNOUT,*)
20883      &   ' **** Ignyatuk (1975, 1st) level density en. dep. used ****'
20884             WRITE (LUNOUT,*)
20885      &   ' **** with Ignyatuk (1975, 1st) set of parameters for T=oo',
20886      &                                                        ' ****'
20887             GAMIGN = 0.054D+00
20888             BETIGN = -6.3 D-05
20889             ALPIGN = 0.154D+00
20890             POWIGN = ZERZER
20891          ELSE IF ( JLVMOD .EQ. 2 ) THEN
20892             WRITE (LUNOUT,*)
20893      &   ' ****   Ignyatuk (1975, 1st) level density en. dep. used ****'
20894             WRITE (LUNOUT,*)
20895      &   ' **** with UNKNOWN set of parameters for T=oo ****'
20896             STOP 'BERTTP-JLVMOD'
20897          ELSE IF ( JLVMOD .EQ. 3 ) THEN
20898             WRITE (LUNOUT,*)
20899      &   ' ****   Ignyatuk (1975, 1st) level density en. dep. used ****'
20900             WRITE (LUNOUT,*)
20901      &   ' **** with UNKNOWN set of parameters for T=oo ****'
20902             STOP 'BERTTP-JLVMOD'
20903          ELSE IF ( JLVMOD .EQ. 4 ) THEN
20904             WRITE (LUNOUT,*)
20905      &   ' ****   Ignyatuk (1975, 2nd) level density en. dep. used ****'
20906             WRITE (LUNOUT,*)
20907      &   ' **** with Ignyatuk (1975, 2nd) set of parameters for T=oo',
20908      &                                                        ' ****'
20909             GAMIGN = 0.054D+00
20910             BETIGN = 0.162D+00
20911             ALPIGN = 0.114D+00
20912             POWIGN = -ONETHI
20913          ELSE IF ( JLVMOD .EQ. 5 ) THEN
20914             WRITE (LUNOUT,*)
20915      &   ' ****  Ignyatuk (1975, 2nd) level density en. dep. used  ****'
20916             WRITE (LUNOUT,*)
20917      &   ' **** with Iljinov & Mebel 1st set of parameters for T=oo****'
20918             GAMIGN = 0.051D+00
20919             BETIGN = 0.098D+00
20920             ALPIGN = 0.114D+00
20921             POWIGN = -ONETHI
20922          ELSE IF ( JLVMOD .EQ. 6 ) THEN
20923             WRITE (LUNOUT,*)
20924      &   ' ****   Ignyatuk (1975, 2nd) level density en. dep. used ****'
20925             WRITE (LUNOUT,*)
20926      &   ' **** with Iljinov & Mebel 2nd set of parameters for T=oo****'
20927             GAMIGN = -0.46D+00
20928             BETIGN = 0.107D+00
20929             ALPIGN = 0.111D+00
20930             POWIGN = -ONETHI
20931          ELSE IF ( JLVMOD .EQ. 7 ) THEN
20932             WRITE (LUNOUT,*)
20933      &   ' ****   Ignyatuk (1975, 2nd) level density en. dep. used ****'
20934             WRITE (LUNOUT,*)
20935      &   ' **** with Iljinov & Mebel 3rd set of parameters for T=oo****'
20936             GAMIGN = 0.059D+00
20937             BETIGN = 0.257D+00
20938             ALPIGN = 0.072D+00
20939             POWIGN = -ONETHI
20940          ELSE IF ( JLVMOD .EQ. 8 ) THEN
20941             WRITE (LUNOUT,*)
20942      &   ' ****   Ignyatuk (1975, 2nd) level density en. dep. used ****'
20943             WRITE (LUNOUT,*)
20944      &   ' **** with Iljinov & Mebel 4th set of parameters for T=oo****'
20945             GAMIGN = -0.37D+00
20946             BETIGN = 0.229D+00
20947             ALPIGN = 0.077D+00
20948             POWIGN = -ONETHI
20949          ELSE
20950             WRITE (LUNOUT,*)
20951      &   ' **** Unknown T=oo level density option requested ****'
20952             STOP 'BERTTP-JLVMOD'
20953          END IF
20954          IF ( LLVMOD ) THEN
20955             WRITE (LUNOUT,*)
20956      &      ' **** Cook''s modified pairing energy used ****'
20957          ELSE
20958             WRITE (LUNOUT,*)
20959      &      ' **** Original Gilbert/Cameron pairing energy used ****'
20960          END IF
20961       ENDIF
20962 **
20963
20964       ILVMOD = IB0
20965       DO 500 JZ = 1, 130
20966          PAENUC ( JZ, 1 ) = EMVGEV * CAM4 (JZ)
20967   500 CONTINUE
20968       DO 600 JA = 1, 200
20969          PAENUC ( JA, 2 ) = EMVGEV * CAM5 (JA)
20970   600 CONTINUE
20971       RETURN
20972       END
20973
20974 *$ CREATE DT_EVEVAP.FOR
20975 *COPY DT_EVEVAP
20976 *
20977 *====evevap============================================================*
20978 *
20979       SUBROUTINE DT_EVEVAP(WE)
20980
20981       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20982       SAVE
20983       PARAMETER ( LINP = 10 ,
20984      &            LOUT = 6 ,
20985      &            LDAT = 9 )
20986
20987 * flags for input different options
20988       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
20989       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
20990      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
20991
20992       LEVAPO = .FALSE.
20993
20994       RETURN
20995       END
20996
20997 *$ CREATE DT_FRBKIN.FOR
20998 *COPY DT_FRBKIN
20999 *
21000 *====frbkin============================================================*
21001 *
21002       SUBROUTINE DT_FRBKIN(LDUM1,LDUM2)
21003
21004       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21005       SAVE
21006       PARAMETER ( LINP = 10 ,
21007      &            LOUT = 6 ,
21008      &            LDAT = 9 )
21009
21010       LOGICAL LDUM1,LDUM2
21011
21012       RETURN
21013       END
21014
21015 *$ CREATE DT_EXPLOD.FOR
21016 *COPY DT_EXPLOD
21017 *
21018 *=== explod ===========================================================*
21019 *
21020       SUBROUTINE DT_EXPLOD( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
21021      &                    PYEXPL, PZEXPL )
21022
21023       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21024       SAVE
21025
21026       DIMENSION PXEXPL (NPEXPL), PYEXPL (NPEXPL), PZEXPL (NPEXPL),
21027      &          ETEXPL (NPEXPL), AMEXPL (NPEXPL)
21028
21029       RETURN
21030       END
21031
21032 ************************************************************************
21033 *                                                                      *
21034 *  DPMJET 3.0:   cross section routines                                *
21035 *                                                                      *
21036 ************************************************************************
21037 *
21038 *
21039 *     SUBROUTINE DT_SHNDIF
21040 *         diffractive cross sections (all energies)
21041 *     SUBROUTINE DT_PHOXS
21042 *         total and inel. cross sections from PHOJET interpol. tables
21043 *     SUBROUTINE DT_XSHN
21044 *         total and el. cross sections for all energies
21045 *     SUBROUTINE DT_SIHNAB
21046 *         pion 2-nucleon absorption cross sections
21047 *     SUBROUTINE DT_SIGEMU
21048 *         cross section for target "compounds"
21049 *     SUBROUTINE DT_SIGGA
21050 *         photon nucleus cross sections
21051 *     SUBROUTINE DT_SIGGAT
21052 *         photon nucleus cross sections from tables
21053 *     SUBROUTINE DT_SANO
21054 *         anomalous hard photon-nucleon cross sections from tables
21055 *     SUBROUTINE DT_SIGGP
21056 *         photon nucleon cross sections
21057 *     SUBROUTINE DT_SIGVEL
21058 *         quasi-elastic vector meson prod. cross sections
21059 *     DOUBLE PRECISION FUNCTION DT_SIGVP
21060 *         sigma_VN(tilde)
21061 *     DOUBLE PRECISION FUNCTION DT_RRM2
21062 *     DOUBLE PRECISION FUNCTION DT_RM2
21063 *     DOUBLE PRECISION FUNCTION DT_SAM2
21064 *     SUBROUTINE DT_CKMT
21065 *     SUBROUTINE DT_CKMTX
21066 *     SUBROUTINE DT_PDF0
21067 *     SUBROUTINE DT_CKMTQ0
21068 *     SUBROUTINE DT_CKMTDE
21069 *     SUBROUTINE DT_CKMTPR
21070 *     FUNCTION DT_CKMTFF
21071 *
21072 *     SUBROUTINE DT_FLUINI
21073 *         total nucleon cross section fluctuation treatment
21074 *
21075 *     SUBROUTINE DT_SIGTBL
21076 *         pre-tabulation of low-energy elastic x-sec. using SIHNEL
21077 *     SUBROUTINE DT_XSTABL
21078 *         service routines
21079 *
21080 *
21081 *$ CREATE DT_SHNDIF.FOR
21082 *COPY DT_SHNDIF
21083 *
21084 *===shndif===============================================================*
21085 *
21086       SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
21087
21088 **********************************************************************
21089 *   Single diffractive hadron-nucleon cross sections                 *
21090 *                                              S.Roesler 14/1/93     *
21091 *                                                                    *
21092 *   The cross sections are calculated from extrapolated single       *
21093 *   diffractive antiproton-proton cross sections (DTUJET92) using    *
21094 *   scaling relations between total and single diffractive cross     *
21095 *   sections.                                                        *
21096 **********************************************************************
21097
21098       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21099       SAVE
21100       PARAMETER (ZERO=0.0D0)
21101
21102 * particle properties (BAMJET index convention)
21103       CHARACTER*8  ANAME
21104       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21105      &                IICH(210),IIBAR(210),K1(210),K2(210)
21106 *
21107       CSD1   =   4.201483727D0
21108       CSD4   = -0.4763103556D-02
21109       CSD5   =  0.4324148297D0
21110 *
21111       CHMSD1 =  0.8519297242D0
21112       CHMSD4 = -0.1443076599D-01
21113       CHMSD5 =  0.4014954567D0
21114 *
21115       EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
21116       PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
21117 *
21118       SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
21119       SHMSD  = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
21120       FRAC   = SHMSD/SDIAPP
21121 *
21122       GOTO( 10, 20,999,999,999,999,999, 10, 20,999,
21123      &     999, 20, 20, 20, 20, 20, 10, 20, 20, 10,
21124      &      10, 10, 20, 20, 20) KPROJ
21125 *
21126    10 CONTINUE
21127 *---------------------------- p - p , n - p , sigma0+- - p ,
21128 *                             Lambda - p
21129       CSD1   =  6.004476070D0
21130       CSD4   = -0.1257784606D-03
21131       CSD5   =  0.2447335720D0
21132       SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
21133       SIGDIH = FRAC*SIGDIF
21134       RETURN
21135 *
21136    20 CONTINUE
21137 *
21138       KPSCAL = 2
21139       KTSCAL = 1
21140 C     F      = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
21141       DUMZER = ZERO
21142       CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
21143       F      = SDIAPP/SIGTO
21144       KT     = 1
21145 C     SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
21146       CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
21147       SIGDIF = SIGTO*F
21148       SIGDIH = FRAC*SIGDIF
21149       RETURN
21150 *
21151   999 CONTINUE
21152 *-------------------------- leptons..
21153       SIGDIF = 1.D-10
21154       SIGDIH = 1.D-10
21155       RETURN
21156       END
21157
21158 *$ CREATE DT_PHOXS.FOR
21159 *COPY DT_PHOXS
21160 *
21161 *===phoxs================================================================*
21162 *
21163       SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
21164
21165 ************************************************************************
21166 * Total/inelastic proton-nucleon cross sections taken from PHOJET-     *
21167 * interpolation tables.                                                *
21168 * This version dated 05.11.97 is written by S. Roesler                 *
21169 ************************************************************************
21170
21171       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21172       SAVE
21173
21174       PARAMETER ( LINP = 10 ,
21175      &            LOUT = 6 ,
21176      &            LDAT = 9 )
21177       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21178       PARAMETER (TWOPI  = 6.283185307179586454D+00,
21179      &           PI     = TWOPI/TWO,
21180      &           GEV2MB = 0.38938D0)
21181
21182       LOGICAL LFIRST
21183       DATA LFIRST /.TRUE./
21184
21185 * nucleon-nucleon event-generator
21186       CHARACTER*8 CMODEL
21187       LOGICAL LPHOIN
21188       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21189 * particle properties (BAMJET index convention)
21190       CHARACTER*8  ANAME
21191       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21192      &                IICH(210),IIBAR(210),K1(210),K2(210)
21193
21194 **PHOJET105a
21195 C     PARAMETER (IEETAB=10)
21196 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21197 **PHOJET110
21198 C  energy-interpolation table
21199       INTEGER IEETA2
21200       PARAMETER ( IEETA2 = 20 )
21201       INTEGER ISIMAX
21202       DOUBLE PRECISION SIGTAB,SIGECM
21203       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21204 **
21205
21206       IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
21207          WRITE(LOUT,*) MCGENE
21208  1000    FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
21209          STOP
21210       ENDIF
21211
21212       IF (ECM.LE.ZERO) THEN
21213          EPN = SQRT(AAM(KPROJ)**2+PLAB**2)
21214          ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG))
21215       ENDIF
21216
21217       IF (MODE.EQ.1) THEN
21218 * DL
21219          DELDL = 0.0808D0
21220          EPSDL = -0.4525D0
21221          S     = ECM*ECM
21222          STOT  = 21.7D0*S**DELDL+56.08D0*S**EPSDL
21223          ALPHAP= 0.25D0
21224          BEL   = 8.5D0+2.D0*ALPHAP*LOG(S)
21225          SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
21226          SINE  = STOT-SIGEL
21227          SDIF1 = ZERO
21228       ELSE
21229 * Phojet
21230          IP = 1
21231          IF(ECM.LE.SIGECM(IP,1)) THEN
21232            I1 = 1
21233            I2 = 1
21234          ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
21235            DO 1 I=2,ISIMAX
21236               IF (ECM.LE.SIGECM(IP,I)) GOTO 2
21237     1      CONTINUE
21238     2      CONTINUE
21239            I1 = I-1
21240            I2 = I
21241          ELSE
21242            IF (LFIRST) THEN
21243               WRITE(LOUT,'(/1X,A,2E12.3)')
21244      &          'PHOXS: warning! energy above initialization limit (',
21245      &          ECM,SIGECM(IP,ISIMAX)
21246              LFIRST = .FALSE.
21247            ENDIF
21248            I1 = ISIMAX
21249            I2 = ISIMAX
21250          ENDIF
21251          FAC2 = ZERO
21252          IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
21253      &                       /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
21254          FAC1  = ONE-FAC2
21255          STOT  = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
21256          SINE  = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
21257          SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+
21258      &           FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1))
21259          BEL   = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
21260       ENDIF
21261
21262       RETURN
21263       END
21264
21265 *$ CREATE DT_XSHN.FOR
21266 *COPY DT_XSHN
21267 *
21268 *===xshn===============================================================*
21269 *
21270       SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
21271
21272 ************************************************************************
21273 * Total and elastic hadron-nucleon cross section.                      *
21274 * Below 500GeV cross sections are based on the '98 data compilation    *
21275 * of the PDG. At higher energies PHOJET results are used (patched to   *
21276 * the low energy data at 500GeV).                                      *
21277 *     IP      projectile index (BAMJET numbering scheme)               *
21278 *             (should be in the range 1..25)                           *
21279 *     IT      target index (BAMJET numbering scheme)                   *
21280 *             (1 = proton, 8 = neutron)                                *
21281 *     PL      laboratory momentum                                      *
21282 *     ECM     cm. energy (ignored if PL>0)                             *
21283 *     STOT    total cross section                                      *
21284 *     SELA    elastic cross section                                    *
21285 * Last change: 24.4.99 by S. Roesler                                   *
21286 ************************************************************************
21287
21288       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21289       SAVE
21290
21291       PARAMETER ( LINP = 10 ,
21292      &            LOUT = 6 ,
21293      &            LDAT = 9 )
21294       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
21295
21296       PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
21297      &           PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
21298       PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
21299
21300       LOGICAL LFIRST
21301 * particle properties (BAMJET index convention)
21302       CHARACTER*8  ANAME
21303       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21304      &                IICH(210),IIBAR(210),K1(210),K2(210)
21305 * nucleon-nucleon event-generator
21306       CHARACTER*8 CMODEL
21307       LOGICAL LPHOIN
21308       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21309 **PHOJET105a
21310 C     PARAMETER (IEETAB=10)
21311 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21312 **PHOJET110
21313 C  energy-interpolation table
21314       INTEGER IEETA2
21315       PARAMETER ( IEETA2 = 20 )
21316       INTEGER ISIMAX
21317       DOUBLE PRECISION SIGTAB,SIGECM
21318       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21319
21320       DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
21321       DIMENSION IDXDAT(25,2)
21322 *
21323       DATA APL /
21324      &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748,
21325      &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465,
21326      &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182,
21327      &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101,
21328      & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384,
21329      & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668,
21330      & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/
21331 *
21332 * total cross sections:
21333 * p p
21334       DATA (ASIGTO(1,K),K=1,NPOINT) /
21335      & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21336      & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21337      & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352,
21338      & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596,
21339      & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664,
21340      & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617,
21341      & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/
21342 * pbar p
21343       DATA (ASIGTO(2,K),K=1,NPOINT) /
21344      & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598,
21345      & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329,
21346      & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151,
21347      & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024,
21348      & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921,
21349      & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802,
21350      & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/
21351 * n p
21352       DATA (ASIGTO(3,K),K=1,NPOINT) /
21353      & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21354      & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21355      & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21356      & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566,
21357      & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21358      & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21359      & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21360 * pi+ p
21361       DATA (ASIGTO(4,K),K=1,NPOINT) /
21362      & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21363      & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21364      & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195,
21365      & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473,
21366      & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492,
21367      & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428,
21368      & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/
21369 * pi- p
21370       DATA (ASIGTO(5,K),K=1,NPOINT) /
21371      & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226,
21372      & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679,
21373      & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547,
21374      & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543,
21375      & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535,
21376      & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468,
21377      & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/
21378 * K+ p
21379       DATA (ASIGTO(6,K),K=1,NPOINT) /
21380      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21381      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21382      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095,
21383      & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268,
21384      & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244,
21385      & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236,
21386      & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/
21387 * K- p
21388       DATA (ASIGTO(7,K),K=1,NPOINT) /
21389      & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997,
21390      & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847,
21391      & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543,
21392      & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508,
21393      & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463,
21394      & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396,
21395      & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/
21396 * K+ n
21397       DATA (ASIGTO(8,K),K=1,NPOINT) /
21398      & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21399      & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21400      & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147,
21401      & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301,
21402      & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261,
21403      & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240,
21404      & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/
21405 * K- n
21406       DATA (ASIGTO(9,K),K=1,NPOINT) /
21407      & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778,
21408      & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773,
21409      & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437,
21410      & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454,
21411      & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343,
21412      & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330,
21413      & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/
21414 * Lambda p
21415       DATA (ASIGTO(10,K),K=1,NPOINT) /
21416      & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21417      & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629,
21418      & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499,
21419      & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567,
21420      & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21421      & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21422      & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21423 *
21424 * elastic cross sections:
21425 * p p
21426       DATA (ASIGEL(1,K),K=1,NPOINT) /
21427      & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21428      & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21429      & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350,
21430      & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397,
21431      & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275,
21432      & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115,
21433      & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/
21434 * pbar p
21435       DATA (ASIGEL(2,K),K=1,NPOINT) /
21436      & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963,
21437      & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875,
21438      & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720,
21439      & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636,
21440      & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457,
21441      & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228,
21442      & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/
21443 * n p
21444       DATA (ASIGEL(3,K),K=1,NPOINT) /
21445      & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21446      & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21447      & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21448      & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454,
21449      & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21450      & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21451      & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21452 * pi+ p
21453       DATA (ASIGEL(4,K),K=1,NPOINT) /
21454      & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21455      & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21456      & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166,
21457      & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235,
21458      & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904,
21459      & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776,
21460      & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/
21461 * pi- p
21462       DATA (ASIGEL(5,K),K=1,NPOINT) /
21463      & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727,
21464      & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217,
21465      & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209,
21466      & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140,
21467      & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895,
21468      & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800,
21469      & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/
21470 * K+ p
21471       DATA (ASIGEL(6,K),K=1,NPOINT) /
21472      & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066,
21473      & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070,
21474      & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093,
21475      & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012,
21476      & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759,
21477      & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584,
21478      & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/
21479 * K- p
21480       DATA (ASIGEL(7,K),K=1,NPOINT) /
21481      & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878,
21482      & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561,
21483      & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188,
21484      & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077,
21485      & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800,
21486      & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618,
21487      & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/
21488 * K+ n
21489       DATA (ASIGEL(8,K),K=1,NPOINT) /
21490      & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21491      & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21492      & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148,
21493      & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111,
21494      & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785,
21495      & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635,
21496      & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/
21497 * K- n
21498       DATA (ASIGEL(9,K),K=1,NPOINT) /
21499      & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613,
21500      & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606,
21501      & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914,
21502      & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979,
21503      & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559,
21504      & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489,
21505      & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/
21506 * Lambda p
21507       DATA (ASIGEL(10,K),K=1,NPOINT) /
21508      & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21509      & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630,
21510      & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502,
21511      & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454,
21512      & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21513      & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21514      & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21515
21516       DATA (IDXDAT(K,1),K=1,25) /
21517      &  1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3,
21518      &  1, 3,45, 8, 9/
21519       DATA (IDXDAT(K,2),K=1,25) /
21520      &  3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1,
21521      &  3, 1,45, 6, 7/
21522
21523       DATA LFIRST /.TRUE./
21524
21525       IF (LFIRST) THEN
21526          APLABL = LOG10(PLABLO)
21527          APLABH = LOG10(PLABHI)
21528          APTHRE = LOG10(PTHRE)
21529          ADP1   = (APTHRE-APLABL)/DBLE(NPOIN1)
21530          ADP2   = (APLABH-APTHRE)/DBLE(NPOIN2)
21531          DUM0   = ZERO
21532          PHOPLA = PLABHI
21533          PHOELA = SQRT(AAM(1)**2+PHOPLA**2)
21534          ECMS   = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA)
21535          IF (MCGENE.EQ.2) THEN
21536             IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN
21537                CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0)
21538             ELSE
21539                CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21540             ENDIF
21541          ELSE
21542             CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21543          ENDIF
21544          PHOSEL = PHOSTO-PHOSIN
21545          APHOST = LOG10(PHOSTO)
21546          APHOSE = LOG10(PHOSEL)
21547          LFIRST = .FALSE.
21548       ENDIF
21549       STOT = ZERO
21550       SELA = ZERO
21551       PLAB = PL
21552       ECMS = ECM
21553       IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN
21554          WRITE(LOUT,1000) IP,IT
21555  1000    FORMAT(1X,'DT_XSHN: cross sections not implemented for ',
21556      &          'proj/target',2I4)
21557          STOP
21558       ENDIF
21559
21560       IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN
21561          ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT))
21562          PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP)))
21563       ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN
21564          WRITE(LOUT,1001) PLAB,ECMS
21565  1001    FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5)
21566          STOP
21567       ENDIF
21568
21569 * index of spectrum
21570       IDXP = IP
21571       IF (IP.GT.25) THEN
21572          IF (AAM(IP).GT.ZERO) THEN
21573             IF (ABS(IIBAR(IP)).GT.0) THEN
21574                IDXP = 1
21575             ELSE
21576                IDXP = 13
21577             ENDIF
21578          ELSE
21579             IDXP = 7
21580          ENDIF
21581       ENDIF
21582       IDXT = 1
21583       IF (IT.EQ.8) IDXT = 2
21584       IDXS = IDXDAT(IDXP,IDXT)
21585       IF (IDXS.EQ.0) RETURN
21586
21587 * compute momentum bin indices
21588       IF (PLAB.LT.PLABLO) THEN
21589          IDX0 = 1
21590          IDX1 = 1
21591       ELSEIF (PLAB.GE.PLABHI) THEN
21592          IDX0 = NPOINT
21593          IDX1 = NPOINT
21594       ELSE
21595          APLAB = LOG10(PLAB)
21596          IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN
21597             IDX0 = INT((APLAB-APLABL)/ADP1)+1
21598          ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN
21599             IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1
21600          ENDIF
21601          IDX1 = IDX0+1
21602       ENDIF
21603
21604 * interpolate cross section
21605       IF (IDXS.GT.10) THEN
21606          IDXS1 = IDXS/10
21607          IDXS2 = IDXS-10*IDXS1
21608          IF (IDX0.EQ.IDX1) THEN
21609             IF (IDX0.EQ.1) THEN
21610                ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0))
21611                ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0))
21612             ELSE
21613                DUM0   = ZERO
21614                CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21615                PHOSEL = PHOSTO-PHOSIN
21616                ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO)
21617                ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL)
21618                ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO)
21619                ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL)
21620                ASTOT  = 0.5D0*(ASTOT1+ASTOT2)
21621                ASELA  = 0.5D0*(ASELA1+ASELA2)
21622             ENDIF
21623          ELSE
21624             FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21625             ASTOT1 = ASIGTO(IDXS1,IDX0)+
21626      &               FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0))
21627             ASTOT2 = ASIGTO(IDXS2,IDX0)+
21628      &               FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0))
21629             ASTOT  = 0.5D0*(ASTOT1+ASTOT2)
21630             ASELA1 = ASIGEL(IDXS1,IDX0)+
21631      &               FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0))
21632             ASELA2 = ASIGEL(IDXS2,IDX0)+
21633      &               FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0))
21634             ASELA  = 0.5D0*(ASELA1+ASELA2)
21635          ENDIF
21636       ELSE
21637          IF (IDX0.EQ.IDX1) THEN
21638             IF (IDX0.EQ.1) THEN
21639                ASTOT = ASIGTO(IDXS,IDX0)
21640                ASELA = ASIGEL(IDXS,IDX0)
21641             ELSE
21642                DUM0   = ZERO
21643                CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21644                PHOSEL = PHOSTO-PHOSIN
21645                ASTOT  = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO)
21646                ASELA  = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL)
21647             ENDIF
21648          ELSE
21649             FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21650             ASTOT = ASIGTO(IDXS,IDX0)+
21651      &              FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0))
21652             ASELA = ASIGEL(IDXS,IDX0)+
21653      &              FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0))
21654          ENDIF
21655       ENDIF
21656       STOT = 10.0D0**ASTOT
21657       SELA = 10.0D0**ASELA
21658
21659       RETURN
21660       END
21661
21662 *$ CREATE DT_SIHNAB.FOR
21663 *COPY DT_SIHNAB
21664 *
21665 *===sihnab===============================================================*
21666 *
21667       SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
21668
21669 **********************************************************************
21670 * Pion 2-nucleon absorption cross sections.                          *
21671 * (sigma_tot for pi+ d --> p p, pi- d --> n n                        *
21672 *  taken from Ritchie PRC 28 (1983) 926 )                            *
21673 * This version dated 18.05.96 is written by S. Roesler               *
21674 **********************************************************************
21675
21676       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21677       SAVE
21678       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
21679       PARAMETER (AMPR = 938.0D0,
21680      &           AMPI = 140.0D0,
21681      &           AMDE = TWO*AMPR,
21682      &           A    = -1.2D0,
21683      &           B    = 3.5D0,
21684      &           C    = 7.4D0,
21685      &           D    = 5600.0D0,
21686      &           ER   = 2136.0D0)
21687
21688       SIGABS = ZERO
21689       IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
21690      &                   .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
21691       PTOT = PLAB*1.0D3
21692       EKIN = SQRT(AMPI**2+PTOT**2)-AMPI
21693       IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN
21694       ECM  = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE )
21695       SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D)
21696 * approximate 3N-abs., I=1-abs. etc.
21697       SIGABS = SIGABS/0.40D0
21698 * pi0-absorption (rough approximation!!)
21699       IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS
21700
21701       RETURN
21702       END
21703
21704 *$ CREATE DT_SIGEMU.FOR
21705 *COPY DT_SIGEMU
21706 *
21707 *===sigemu=============================================================*
21708 *
21709       SUBROUTINE DT_SIGEMU
21710
21711 ************************************************************************
21712 * Combined cross section for target compounds.                         *
21713 * This version dated 6.4.98   is written by S. Roesler                 *
21714 ************************************************************************
21715
21716       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21717       SAVE
21718       PARAMETER ( LINP = 10 ,
21719      &            LOUT = 6 ,
21720      &            LDAT = 9 )
21721       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21722      &           OHALF=0.5D0,ONE=1.0D0)
21723
21724       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21725 * Glauber formalism: cross sections
21726       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21727      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21728      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21729      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21730      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21731      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21732      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21733      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21734      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21735      &                BSLOPE,NEBINI,NQBINI
21736 * emulsion treatment
21737       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
21738      &                NCOMPO,IEMUL
21739 * nucleon-nucleon event-generator
21740       CHARACTER*8 CMODEL
21741       LOGICAL LPHOIN
21742       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21743
21744       IF (MCGENE.NE.4) THEN
21745          WRITE(LOUT,'(A)') ' DT_SIGEMU:    Combined cross sections'
21746          WRITE(LOUT,'(15X,A)') '-----------------------'
21747       ENDIF
21748       DO 1 IE=1,NEBINI
21749          DO 2 IQ=1,NQBINI
21750             SIGTOT = ZERO
21751             SIGELA = ZERO
21752             SIGQEP = ZERO
21753             SIGQET = ZERO
21754             SIGQE2 = ZERO
21755             SIGPRO = ZERO
21756             SIGDEL = ZERO
21757             SIGDQE = ZERO
21758             ERRTOT = ZERO
21759             ERRELA = ZERO
21760             ERRQEP = ZERO
21761             ERRQET = ZERO
21762             ERRQE2 = ZERO
21763             ERRPRO = ZERO
21764             ERRDEL = ZERO
21765             ERRDQE = ZERO
21766             IF (NCOMPO.GT.0) THEN
21767                DO 3 IC=1,NCOMPO
21768                   SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC)
21769                   SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC)
21770                   SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC)
21771                   SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC)
21772                   SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC)
21773                   SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC)
21774                   SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC)
21775                   SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC)
21776                   ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2
21777                   ERRELA = ERRELA+XEELA(IE,IQ,IC)**2
21778                   ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2
21779                   ERRQET = ERRQET+XEQET(IE,IQ,IC)**2
21780                   ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2
21781                   ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2
21782                   ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2
21783                   ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2
21784     3          CONTINUE
21785                ERRTOT = SQRT(ERRTOT)
21786                ERRELA = SQRT(ERRELA)
21787                ERRQEP = SQRT(ERRQEP)
21788                ERRQET = SQRT(ERRQET)
21789                ERRQE2 = SQRT(ERRQE2)
21790                ERRPRO = SQRT(ERRPRO)
21791                ERRDEL = SQRT(ERRDEL)
21792                ERRDQE = SQRT(ERRDQE)
21793             ELSE
21794                SIGTOT = XSTOT(IE,IQ,1)
21795                SIGELA = XSELA(IE,IQ,1)
21796                SIGQEP = XSQEP(IE,IQ,1)
21797                SIGQET = XSQET(IE,IQ,1)
21798                SIGQE2 = XSQE2(IE,IQ,1)
21799                SIGPRO = XSPRO(IE,IQ,1)
21800                SIGDEL = XSDEL(IE,IQ,1)
21801                SIGDQE = XSDQE(IE,IQ,1)
21802                ERRTOT = XETOT(IE,IQ,1)
21803                ERRELA = XEELA(IE,IQ,1)
21804                ERRQEP = XEQEP(IE,IQ,1)
21805                ERRQET = XEQET(IE,IQ,1)
21806                ERRQE2 = XEQE2(IE,IQ,1)
21807                ERRPRO = XEPRO(IE,IQ,1)
21808                ERRDEL = XEDEL(IE,IQ,1)
21809                ERRDQE = XEDQE(IE,IQ,1)
21810             ENDIF
21811             IF (MCGENE.NE.4) THEN
21812                WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ)
21813  1000         FORMAT(/,1X,'E_cm =',F9.1,' GeV  Q^2 =',F6.1,' GeV^2 :',/)
21814                WRITE(LOUT,1001) SIGTOT,ERRTOT
21815  1001          FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb')
21816                WRITE(LOUT,1002) SIGELA,ERRELA
21817  1002          FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb')
21818                WRITE(LOUT,1003) SIGQEP,ERRQEP
21819  1003          FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-',
21820      &                F11.5,' mb')
21821                WRITE(LOUT,1004) SIGQET,ERRQET
21822  1004          FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
21823      &                F11.5,' mb')
21824                WRITE(LOUT,1005) SIGQE2,ERRQE2
21825  1005          FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4,
21826      &                ' +-',F11.5,' mb')
21827                WRITE(LOUT,1006) SIGPRO,ERRPRO
21828  1006          FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb')
21829                WRITE(LOUT,1007) SIGDEL,ERRDEL
21830  1007          FORMAT(1X,'diff-el   ',27X,F10.4,' +-',F11.5,' mb')
21831                WRITE(LOUT,1008) SIGDQE,ERRDQE
21832  1008          FORMAT(1X,'diff-qel  ',27X,F10.4,' +-',F11.5,' mb')
21833             ENDIF
21834
21835     2    CONTINUE
21836     1 CONTINUE
21837
21838       RETURN
21839       END
21840
21841 *$ CREATE DT_SIGGA.FOR
21842 *COPY DT_SIGGA
21843 *
21844 *===sigga==============================================================*
21845 *
21846       SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
21847
21848 ************************************************************************
21849 * Total/inelastic photon-nucleus cross sections.                       *
21850 *     !!!! Overwrites SHMAKI-initialization. Do not use it during      *
21851 *          production runs !!!!                                        *
21852 * This version dated 27.03.96 is written by S. Roesler                 *
21853 ************************************************************************
21854
21855       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21856       SAVE
21857       PARAMETER ( LINP = 10 ,
21858      &            LOUT = 6 ,
21859      &            LDAT = 9 )
21860       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21861      &           OHALF=0.5D0,ONE=1.0D0)
21862       PARAMETER (AMPROT = 0.938D0)
21863
21864       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21865 * Glauber formalism: cross sections
21866       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21867      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21868      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21869      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21870      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21871      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21872      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21873      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21874      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21875      &                BSLOPE,NEBINI,NQBINI
21876
21877       NT  = NTI
21878       X   = XI
21879       Q2  = Q2I
21880       ECM = ECMI
21881       XNU = XNUI
21882       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21883      &   ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT)
21884       CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1)
21885       STOT  = XSTOT(1,1,1)
21886       ETOT  = XETOT(1,1,1)
21887       SIN   = XSPRO(1,1,1)
21888       EIN   = XEPRO(1,1,1)
21889
21890       RETURN
21891       END
21892
21893 *$ CREATE DT_SIGGAT.FOR
21894 *COPY DT_SIGGAT
21895 *
21896 *===siggat=============================================================*
21897 *
21898       SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
21899
21900 ************************************************************************
21901 * Total/inelastic photon-nucleus cross sections.                       *
21902 * Uses pre-tabulated cross section.                                    *
21903 * This version dated 29.07.96 is written by S. Roesler                 *
21904 ************************************************************************
21905
21906       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21907       SAVE
21908       PARAMETER ( LINP = 10 ,
21909      &            LOUT = 6 ,
21910      &            LDAT = 9 )
21911       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21912      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21913
21914       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21915 * Glauber formalism: cross sections
21916       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21917      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21918      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21919      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21920      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21921      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21922      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21923      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21924      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21925      &                BSLOPE,NEBINI,NQBINI
21926
21927       NTARG = ABS(NT)
21928       I1   = 1
21929       I2   = 1
21930       RATE = ONE
21931       IF (NEBINI.GT.1) THEN
21932          IF (ECMI.GE.ECMNN(NEBINI)) THEN
21933             I1   = NEBINI
21934             I2   = NEBINI
21935             RATE = ONE
21936          ELSEIF (ECMI.GT.ECMNN(1)) THEN
21937             DO 1 I=2,NEBINI
21938                IF (ECMI.LT.ECMNN(I)) THEN
21939                   I1   = I-1
21940                   I2   = I
21941                   RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
21942                   GOTO 2
21943                ENDIF
21944     1       CONTINUE
21945     2       CONTINUE
21946          ENDIF
21947       ENDIF
21948       J1   = 1
21949       J2   = 1
21950       RATQ = ONE
21951       IF (NQBINI.GT.1) THEN
21952          IF (Q2I.GE.Q2G(NQBINI)) THEN
21953             J1   = NQBINI
21954             J2   = NQBINI
21955             RATQ = ONE
21956          ELSEIF (Q2I.GT.Q2G(1)) THEN
21957             DO 3 I=2,NQBINI
21958                IF (Q2I.LT.Q2G(I)) THEN
21959                   J1   = I-1
21960                   J2   = I
21961                   RATQ = LOG10(    Q2I/MAX(Q2G(J1),TINY14))/
21962      &                   LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
21963 C                 RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
21964                   GOTO 4
21965                ENDIF
21966     3       CONTINUE
21967     4       CONTINUE
21968          ENDIF
21969       ENDIF
21970
21971       STOT = XSTOT(I1,J1,NTARG)+
21972      &   RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+
21973      &   RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+
21974      &   RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+
21975      &              XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG))
21976
21977       RETURN
21978       END
21979
21980 *$ CREATE DT_SANO.FOR
21981 *COPY DT_SANO
21982 *
21983 *===sigano=============================================================*
21984 *
21985       DOUBLE PRECISION FUNCTION DT_SANO(ECM)
21986
21987 ************************************************************************
21988 * This version dated 31.07.96 is written by S. Roesler                 *
21989 ************************************************************************
21990
21991       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21992       SAVE
21993       PARAMETER ( LINP = 10 ,
21994      &            LOUT = 6 ,
21995      &            LDAT = 9 )
21996       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21997      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21998       PARAMETER (NE = 8)
21999
22000 * VDM parameter for photon-nucleus interactions
22001       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22002 * properties of interacting particles
22003       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
22004
22005       DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
22006       DATA ECMANO /
22007      &             0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03,
22008      &             0.100D+04,0.200D+04,0.500D+04
22009      &            /
22010 * fixed cut (3 GeV/c)
22011       DATA FRAANO /
22012      &             0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00,
22013      &             0.062D+00,0.054D+00,0.042D+00
22014      &            /
22015       DATA SIGHRD /
22016      &           4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01,
22017      &           3.3086D-01,7.6255D-01,2.1319D+00
22018      &            /
22019 * running cut (based on obsolete Phojet-caluclations, bugs..)
22020 C     DATA FRAANO /
22021 C    &             0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
22022 C    &             0.167E+00,0.150E+00,0.131E+00
22023 C    &            /
22024 C     DATA SIGHRD /
22025 C    &           6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
22026 C    &           2.5736E-01,4.5593E-01,8.2550E-01
22027 C    &            /
22028
22029       DT_SANO = ZERO
22030       IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
22031       J1   = 0
22032       J2   = 0
22033       RATE = ONE
22034       IF (ECM.GE.ECMANO(NE)) THEN
22035          J1 = NE
22036          J2 = NE
22037       ELSEIF (ECM.GT.ECMANO(1)) THEN
22038          DO 1 IE=2,NE
22039             IF (ECM.LT.ECMANO(IE)) THEN
22040                J1   = IE-1
22041                J2   = IE
22042                RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
22043                GOTO 2
22044             ENDIF
22045     1    CONTINUE
22046     2    CONTINUE
22047       ENDIF
22048       IF ((J1.GT.0).AND.(J2.GT.0)) THEN
22049          AFRA1  = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14))
22050          AFRA2  = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14))
22051          DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1))
22052       ENDIF
22053
22054       RETURN
22055       END
22056
22057 *$ CREATE DT_SIGGP.FOR
22058 *COPY DT_SIGGP
22059 *
22060 *===siggp==============================================================*
22061 *
22062       SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
22063
22064 ************************************************************************
22065 * Total/inelastic photon-nucleon cross sections.                       *
22066 * This version dated 30.04.96 is written by S. Roesler                 *
22067 ************************************************************************
22068
22069       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22070       SAVE
22071       PARAMETER ( LINP = 10 ,
22072      &            LOUT = 6 ,
22073      &            LDAT = 9 )
22074       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22075       PARAMETER (TWOPI  = 6.283185307179586476925286766559D+00,
22076      &           PI     = TWOPI/TWO,
22077      &           GEV2MB = 0.38938D0,
22078      &           ALPHEM = ONE/137.0D0)
22079
22080 * particle properties (BAMJET index convention)
22081       CHARACTER*8  ANAME
22082       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22083      &                IICH(210),IIBAR(210),K1(210),K2(210)
22084 * VDM parameter for photon-nucleus interactions
22085       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22086
22087 **PHOJET105a
22088 C     CHARACTER*8 MDLNA
22089 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
22090 C     PARAMETER (IEETAB=10)
22091 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
22092 **PHOJET110
22093 C  model switches and parameters
22094       CHARACTER*8 MDLNA
22095       INTEGER ISWMDL,IPAMDL
22096       DOUBLE PRECISION PARMDL
22097       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
22098 C  energy-interpolation table
22099       INTEGER IEETA2
22100       PARAMETER ( IEETA2 = 20 )
22101       INTEGER ISIMAX
22102       DOUBLE PRECISION SIGTAB,SIGECM
22103       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
22104 **
22105
22106 C     PARAMETER (NPOINT=80)
22107       PARAMETER (NPOINT=16)
22108       DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22109
22110       STOT = ZERO
22111       SINE = ZERO
22112       SDIR = ZERO
22113
22114       W2 = ECMI**2
22115       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
22116      &   W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
22117       Q2 = Q2I
22118       X  = XI
22119 * photoprod.
22120       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22121          Q2 = 0.0001D0
22122          X  = Q2/(W2+Q2-AAM(1)**2)
22123 * DIS
22124       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
22125          X  = Q2/(W2+Q2-AAM(1)**2)
22126       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22127          Q2 = (W2-AAM(1)**2)*X/(ONE-X)
22128       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
22129          W2 = Q2*(ONE-X)/X+AAM(1)**2
22130       ELSE
22131          WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
22132          STOP
22133       ENDIF
22134       ECM = SQRT(W2)
22135
22136       IF (MODEGA.EQ.1) THEN
22137          SCALE = SQRT(Q2)
22138          CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
22139      &                                                       IDPDF)
22140 C        W = SQRT(W2)
22141 C        ALLMF2 = PHO_ALLM97(Q2,W)
22142 C        write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22143          STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22144          SINE = ZERO
22145          SDIR = ZERO
22146       ELSEIF (MODEGA.EQ.2) THEN
22147          IF (INTRGE(1).EQ.1) THEN
22148             AMLO2 = (3.0D0*AAM(13))**2
22149          ELSEIF (INTRGE(1).EQ.2) THEN
22150             AMLO2 = AAM(33)**2
22151          ELSE
22152             AMLO2 = AAM(96)**2
22153          ENDIF
22154          IF (INTRGE(2).EQ.1) THEN
22155             AMHI2 = W2/TWO
22156          ELSEIF (INTRGE(2).EQ.2) THEN
22157             AMHI2 = W2/4.0D0
22158          ELSE
22159             AMHI2 = W2
22160          ENDIF
22161          AMHI20 = (ECM-AAM(1))**2
22162          IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22163          XAMLO  = LOG( AMLO2+Q2 )
22164          XAMHI  = LOG( AMHI2+Q2 )
22165 **PHOJET105a
22166 C        CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
22167 **PHOJET112
22168          CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
22169 **
22170          SUM  = ZERO
22171          DO 1 J=1,NPOINT
22172             AM2 = EXP(ABSZX(J))-Q2
22173             IF (AM2.LT.16.0D0) THEN
22174                R = TWO
22175             ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
22176                R = 10.0D0/3.0D0
22177             ELSE
22178                R = 11.0D0/3.0D0
22179             ENDIF
22180 C           FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
22181             FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
22182      &            * (ONE+EPSPOL*Q2/AM2)
22183             SUM = SUM+WEIGHT(J)*FAC
22184     1    CONTINUE
22185          SINE = SUM
22186          SDIR = DT_SIGVP(X,Q2)
22187          STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
22188          SDIR = SDIR/(0.588D0+RL2+Q2)
22189 C        STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2)
22190       ELSEIF (MODEGA.EQ.3) THEN
22191          CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM)
22192       ELSEIF (MODEGA.EQ.4) THEN
22193 *  load cross sections from PHOJET interpolation table
22194          IP = 1
22195          IF(ECM.LE.SIGECM(IP,1)) THEN
22196            I1 = 1
22197            I2 = 1
22198          ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
22199            DO 2 I=2,ISIMAX
22200               IF (ECM.LE.SIGECM(IP,I)) GOTO 3
22201     2      CONTINUE
22202     3      CONTINUE
22203            I1 = I-1
22204            I2 = I
22205          ELSE
22206            WRITE(LOUT,'(/1X,A,2E12.3)')
22207      &       'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
22208            I1 = ISIMAX
22209            I2 = ISIMAX
22210          ENDIF
22211          FAC2 = ZERO
22212          IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
22213      &                       /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
22214          FAC1 = ONE-FAC2
22215 *  cross section dependence on photon virtuality
22216          FSUP1 = ZERO
22217          DO 4 I=1,3
22218             FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
22219      &                                /(1.D0+Q2/PARMDL(30+I))**2
22220     4    CONTINUE
22221          FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
22222          FAC1  = FAC1*FSUP1
22223          FAC2  = FAC2*FSUP1
22224          FSUP2 = 1.0D0
22225          STOT  = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
22226          SINE  = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
22227          SDIR  = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
22228 **re:
22229          STOT  = STOT-SDIR
22230 **
22231          SDIR  = SDIR/(FSUP1*FSUP2)
22232 **re:
22233          STOT  = STOT+SDIR
22234 **
22235       ENDIF
22236
22237       RETURN
22238       END
22239
22240 *$ CREATE DT_SIGVEL.FOR
22241 *COPY DT_SIGVEL
22242 *
22243 *===sigvel=============================================================*
22244 *
22245       SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
22246
22247 ************************************************************************
22248 * Cross section for elastic vector meson production                    *
22249 * This version dated 10.05.96 is written by S. Roesler                 *
22250 ************************************************************************
22251
22252       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22253       SAVE
22254       PARAMETER ( LINP = 10 ,
22255      &            LOUT = 6 ,
22256      &            LDAT = 9 )
22257       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22258       PARAMETER (TWOPI  = 6.283185307179586476925286766559D+00,
22259      &           PI     = TWOPI/TWO,
22260      &           GEV2MB = 0.38938D0,
22261      &           ALPHEM = ONE/137.0D0)
22262
22263 * particle properties (BAMJET index convention)
22264       CHARACTER*8  ANAME
22265       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22266      &                IICH(210),IIBAR(210),K1(210),K2(210)
22267 * VDM parameter for photon-nucleus interactions
22268       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22269
22270       W2 = ECMI**2
22271       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
22272      &   W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
22273       Q2 = Q2I
22274       X  = XI
22275 * photoprod.
22276       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22277          Q2 = 0.0001D0
22278          X  = Q2/(W2+Q2-AAM(1)**2)
22279 * DIS
22280       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
22281          X  = Q2/(W2+Q2-AAM(1)**2)
22282       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22283          Q2 = (W2-AAM(1)**2)*X/(ONE-X)
22284       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
22285          W2 = Q2*(ONE-X)/X+AAM(1)**2
22286       ELSE
22287          WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
22288          STOP
22289       ENDIF
22290       ECM = SQRT(W2)
22291
22292       AMV  = AAM(IDXV)
22293       AMV2 = AMV**2
22294
22295       BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
22296      &        +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
22297       ROSH   = 0.1D0
22298       STOVP  = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
22299       SELVP  = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
22300
22301       IF (IDXV.EQ.33) THEN
22302          COUPL = 0.00365D0
22303       ELSE
22304          STOP
22305       ENDIF
22306       SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
22307       SIG2 = SELVP
22308       SVEL  = COUPL * (AMV2/(AMV2+Q2))**2
22309      &              * (ONE+EPSPOL*Q2/AMV2) * SELVP
22310
22311       RETURN
22312       END
22313
22314 *$ CREATE DT_SIGVP.FOR
22315 *COPY DT_SIGVP
22316 *
22317 *===sigvp==============================================================*
22318 *
22319       DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
22320
22321 ************************************************************************
22322 * sigma_Vp                                                             *
22323 ************************************************************************
22324
22325       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22326       SAVE
22327
22328       PARAMETER ( LINP = 10 ,
22329      &            LOUT = 6 ,
22330      &            LDAT = 9 )
22331       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22332       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22333      &           PI    = TWOPI/TWO,
22334      &           GEV2MB = 0.38938D0,
22335      &           AMPROT = 0.938D0,
22336      &           ALPHEM = ONE/137.0D0)
22337 * VDM parameter for photon-nucleus interactions
22338       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22339
22340       X  = XI
22341       Q2 = Q2I
22342       IF (XI.LE.ZERO)  X  = 0.0001D0
22343       IF (Q2I.LE.ZERO) Q2 = 0.0001D0
22344
22345       ECM    = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
22346
22347       SCALE = SQRT(Q2)
22348       IF (MODEGA.EQ.1) THEN
22349          CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
22350      &                                                       IDPDF)
22351 C        W = ECM
22352 C        ALLMF2 = PHO_ALLM97(Q2,W)
22353 C        write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22354 C        STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22355 C        DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
22356          DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB
22357       ELSEIF (MODEGA.EQ.4) THEN
22358          CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3)
22359 C        F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
22360          DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
22361       ELSE
22362          STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
22363       ENDIF
22364
22365       RETURN
22366
22367       END
22368
22369 *$ CREATE DT_RRM2.FOR
22370 *COPY DT_RRM2
22371 *
22372 *===RRM2===============================================================*
22373 *
22374       DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
22375
22376       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22377       SAVE
22378       PARAMETER ( LINP = 10 ,
22379      &            LOUT = 6 ,
22380      &            LDAT = 9 )
22381       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22382       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22383      &           PI    = TWOPI/TWO,
22384      &           GEV2MB = 0.38938D0)
22385
22386 * particle properties (BAMJET index convention)
22387       CHARACTER*8  ANAME
22388       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22389      &                IICH(210),IIBAR(210),K1(210),K2(210)
22390 * VDM parameter for photon-nucleus interactions
22391       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22392
22393       S   = Q2*(ONE-X)/X+AAM(1)**2
22394       ECM = SQRT(S)
22395
22396       IF (INTRGE(1).EQ.1) THEN
22397          AMLO2 = (3.0D0*AAM(13))**2
22398       ELSEIF (INTRGE(1).EQ.2) THEN
22399          AMLO2 = AAM(33)**2
22400       ELSE
22401          AMLO2 = AAM(96)**2
22402       ENDIF
22403       IF (INTRGE(2).EQ.1) THEN
22404          AMHI2 = S/TWO
22405       ELSEIF (INTRGE(2).EQ.2) THEN
22406          AMHI2 = S/4.0D0
22407       ELSE
22408          AMHI2 = S
22409       ENDIF
22410       AMHI20 = (ECM-AAM(1))**2
22411       IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22412
22413       AM1C2 = 16.0D0
22414       AM2C2 = 121.0D0
22415       IF (AMHI2.LE.AM1C2) THEN
22416          DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2)
22417       ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22418          DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22419      &          10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2)
22420       ELSE
22421          DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22422      &          10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+
22423      &          11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2)
22424       ENDIF
22425
22426       RETURN
22427       END
22428
22429 *$ CREATE DT_RM2.FOR
22430 *COPY DT_RM2
22431 *
22432 *===RM2================================================================*
22433 *
22434       DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
22435
22436       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22437       SAVE
22438       PARAMETER ( LINP = 10 ,
22439      &            LOUT = 6 ,
22440      &            LDAT = 9 )
22441       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22442       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22443      &           PI    = TWOPI/TWO,
22444      &           GEV2MB = 0.38938D0)
22445 * VDM parameter for photon-nucleus interactions
22446       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22447
22448       IF (RL2.LE.ZERO) THEN
22449          DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) -
22450      &        (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2))
22451      &         +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2))
22452       ELSE
22453          TMPMLO = LOG(ONE+RL2/(AMLO2+Q2))
22454          TMPMHI = LOG(ONE+RL2/(AMHI2+Q2))
22455          DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI
22456      &       -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO)
22457      &       +EPSPOL*(
22458      &         -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
22459      &       -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
22460       ENDIF
22461
22462       RETURN
22463       END
22464
22465 *$ CREATE DT_SAM2.FOR
22466 *COPY DT_SAM2
22467 *
22468 *===SAM2===============================================================*
22469 *
22470       DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
22471
22472       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22473       SAVE
22474       PARAMETER ( LINP = 10 ,
22475      &            LOUT = 6 ,
22476      &            LDAT = 9 )
22477       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
22478      &           TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0)
22479       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22480      &           PI    = TWOPI/TWO,
22481      &           GEV2MB = 0.38938D0)
22482
22483 * particle properties (BAMJET index convention)
22484       CHARACTER*8  ANAME
22485       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22486      &                IICH(210),IIBAR(210),K1(210),K2(210)
22487 * VDM parameter for photon-nucleus interactions
22488       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22489
22490       S = ECM**2
22491       IF (INTRGE(1).EQ.1) THEN
22492          AMLO2 = (3.0D0*AAM(13))**2
22493       ELSEIF (INTRGE(1).EQ.2) THEN
22494          AMLO2 = AAM(33)**2
22495       ELSE
22496          AMLO2 = AAM(96)**2
22497       ENDIF
22498       IF (INTRGE(2).EQ.1) THEN
22499          AMHI2 = S/TWO
22500       ELSEIF (INTRGE(2).EQ.2) THEN
22501          AMHI2 = S/4.0D0
22502       ELSE
22503          AMHI2 = S
22504       ENDIF
22505       AMHI20 = (ECM-AAM(1))**2
22506       IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22507
22508       AM1C2 = 16.0D0
22509       AM2C2 = 121.0D0
22510       YLO   = LOG(AMLO2+Q2)
22511       YC1   = LOG(AM1C2+Q2)
22512       YC2   = LOG(AM2C2+Q2)
22513       YHI   = LOG(AMHI2+Q2)
22514       IF (AMHI2.LE.AM1C2) THEN
22515          FACHI = TWO
22516       ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22517          FACHI = TENTRD
22518       ELSE
22519          FACHI = ELVTRD
22520       ENDIF
22521
22522     1 CONTINUE
22523       YSAM2  = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
22524       IF (YSAM2.LE.YC1) THEN
22525          FAC = TWO
22526       ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
22527          FAC = TENTRD
22528       ELSE
22529          FAC = ELVTRD
22530       ENDIF
22531       WEIGMX = FACHI*(ONE-Q2*EXP(  -YHI))
22532       XSAM2  = FAC  *(ONE-Q2*EXP(-YSAM2))
22533       IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
22534
22535       DT_SAM2   = EXP(YSAM2)-Q2
22536
22537       RETURN
22538       END
22539
22540 *$ CREATE DT_CKMT.FOR
22541 *COPY DT_CKMT
22542 *
22543 *===ckmt===============================================================*
22544 *
22545       SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
22546      &                F2,IPAR)
22547
22548 ************************************************************************
22549 * This version dated 31.01.96 is written by S. Roesler                 *
22550 ************************************************************************
22551
22552       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22553       SAVE
22554       PARAMETER ( LINP = 10 ,
22555      &            LOUT = 6 ,
22556      &            LDAT = 9 )
22557       PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
22558
22559       PARAMETER (Q02 = 2.0D0,
22560      &           DQ2 = 10.05D0,
22561      &           Q12 = Q02+DQ2)
22562
22563       DIMENSION PD(-6:6),SEA(3),VAL(2)
22564
22565       CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR)
22566       CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR)
22567       ADQ2 = LOG10(Q12)-LOG10(Q02)
22568       F2P  = (F2Q1-F2Q0)/ADQ2
22569       CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0)
22570       CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1)
22571       F2PP = (F2PQ1-F2PQ0)/ADQ2
22572       FX   = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02
22573
22574       Q2     = MAX(SCALE**2.0D0,TINY10)
22575       SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2
22576       IF (Q2.LT.Q02) THEN
22577          CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22578          UPV  = VAL(1)
22579          DNV  = VAL(2)
22580          USEA = SEA(1)
22581          DSEA = SEA(2)
22582          STR  = SEA(3)
22583          CHM  = 0.0D0
22584          BOT  = 0.0D0
22585          TOP  = 0.0D0
22586          GL   = GLU
22587       ELSE
22588          CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
22589          F2 = F2*SMOOTH
22590          UPV  = PD(2)-PD(3)
22591          DNV  = PD(1)-PD(3)
22592          USEA = PD(3)
22593          DSEA = PD(3)
22594          STR  = PD(3)
22595          CHM  = PD(4)
22596          BOT  = PD(5)
22597          TOP  = PD(6)
22598          GL   = PD(0)
22599 C        UPV  = UPV*SMOOTH
22600 C        DNV  = DNV*SMOOTH
22601 C        USEA = USEA*SMOOTH
22602 C        DSEA = DSEA*SMOOTH
22603 C        STR  = STR*SMOOTH
22604 C        CHM  = CHM*SMOOTH
22605 C        GL   = GL*SMOOTH
22606       ENDIF
22607
22608       RETURN
22609       END
22610 C
22611
22612 *$ CREATE DT_CKMTX.FOR
22613 *COPY DT_CKMTX
22614       SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
22615 C**********************************************************************
22616 C
22617 C     PDF based on Regge theory, evolved with .... by ....
22618 C
22619 C     input: IPAR     2212   proton (not installed)
22620 C                       45   Pomeron
22621 C                      100   Deuteron
22622 C
22623 C     output: PD(-6:6) x*f(x)  parton distribution functions
22624 C            (PDFLIB convention: d = PD(1), u = PD(2) )
22625 C
22626 C**********************************************************************
22627
22628       SAVE
22629       DOUBLE PRECISION  X,SCALE2,PD(-6:6),CDN,CUP,F2
22630       PARAMETER ( LINP = 10 ,
22631      &            LOUT = 6 ,
22632      &            LDAT = 9 )
22633       DIMENSION QQ(7)
22634 C
22635       Q2=SNGL(SCALE2)
22636       Q1S=Q2
22637       XX=SNGL(X)
22638 C  QCD lambda for evolution
22639       OWLAM = 0.23D0
22640       OWLAM2=OWLAM**2
22641 C  Q0**2 for evolution
22642       Q02 = 2.D0
22643 C
22644 C
22645 C  the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
22646 C                        q(6)=x*charm, q(7)=x*gluon
22647 C
22648       SB=0.
22649       IF(Q2-Q02) 1,1,2
22650     2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
22651     1 CONTINUE
22652       IF(IPAR.EQ.2212) THEN
22653         CALL DT_CKMTPR(1,0,XX,SB,QQ(1))
22654         CALL DT_CKMTPR(2,0,XX,SB,QQ(2))
22655         CALL DT_CKMTPR(3,0,XX,SB,QQ(3))
22656         CALL DT_CKMTPR(4,0,XX,SB,QQ(4))
22657         CALL DT_CKMTPR(5,0,XX,SB,QQ(5))
22658         CALL DT_CKMTPR(8,0,XX,SB,QQ(6))
22659         CALL DT_CKMTPR(7,0,XX,SB,QQ(7))
22660 C     ELSEIF (IPAR.EQ.45) THEN
22661 C       CALL CKMTPO(1,0,XX,SB,QQ(1))
22662 C       CALL CKMTPO(2,0,XX,SB,QQ(2))
22663 C       CALL CKMTPO(3,0,XX,SB,QQ(3))
22664 C       CALL CKMTPO(4,0,XX,SB,QQ(4))
22665 C       CALL CKMTPO(5,0,XX,SB,QQ(5))
22666 C       CALL CKMTPO(8,0,XX,SB,QQ(6))
22667 C       CALL CKMTPO(7,0,XX,SB,QQ(7))
22668       ELSEIF (IPAR.EQ.100) THEN
22669         CALL DT_CKMTDE(1,0,XX,SB,QQ(1))
22670         CALL DT_CKMTDE(2,0,XX,SB,QQ(2))
22671         CALL DT_CKMTDE(3,0,XX,SB,QQ(3))
22672         CALL DT_CKMTDE(4,0,XX,SB,QQ(4))
22673         CALL DT_CKMTDE(5,0,XX,SB,QQ(5))
22674         CALL DT_CKMTDE(8,0,XX,SB,QQ(6))
22675         CALL DT_CKMTDE(7,0,XX,SB,QQ(7))
22676       ELSE
22677         WRITE(LOUT,'(1X,A,I4,A)')
22678      &     'CKMTX:   IPAR =',IPAR,' not implemented!'
22679         STOP
22680       ENDIF
22681 C
22682       PD(-6) = 0.D0
22683       PD(-5) = 0.D0
22684       PD(-4) = DBLE(QQ(6))
22685       PD(-3) = DBLE(QQ(3))
22686       PD(-2) = DBLE(QQ(4))
22687       PD(-1) = DBLE(QQ(5))
22688       PD(0)  = DBLE(QQ(7))
22689       PD(1)  = DBLE(QQ(2))
22690       PD(2)  = DBLE(QQ(1))
22691       PD(3)  = DBLE(QQ(3))
22692       PD(4)  = DBLE(QQ(6))
22693       PD(5)  = 0.D0
22694       PD(6)  = 0.D0
22695       IF(IPAR.EQ.45) THEN
22696         CDN = (PD(1)-PD(-1))/2.D0
22697         CUP = (PD(2)-PD(-2))/2.D0
22698         PD(-1) = PD(-1) + CDN
22699         PD(-2) = PD(-2) + CUP
22700         PD(1) = PD(-1)
22701         PD(2) = PD(-2)
22702       ENDIF
22703       F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+
22704      &     1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+
22705      &     1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4))
22706       END
22707 C
22708
22709 *$ CREATE DT_PDF0.FOR
22710 *COPY DT_PDF0
22711 *
22712 *===pdf0===============================================================*
22713 *
22714       SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22715
22716 ************************************************************************
22717 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2       *
22718 * an F_2-ansatz given in Capella et al. PLB 337(1994)358.              *
22719 *                   IPAR  = 2212   proton                              *
22720 *                         =  100   deuteron                            *
22721 * This version dated 31.01.96 is written by S. Roesler                 *
22722 ************************************************************************
22723
22724       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22725       SAVE
22726       PARAMETER ( LINP = 10 ,
22727      &            LOUT = 6 ,
22728      &            LDAT = 9 )
22729       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22730
22731       PARAMETER (
22732      &              AA     = 0.1502D0,
22733      &              BBDEU  = 1.2D0,
22734      &              BUD    = 0.754D0,
22735      &              BDD    = 0.4495D0,
22736      &              BUP    = 1.2064D0,
22737      &              BDP    = 0.1798D0,
22738      &              DELTA0 = 0.07684D0,
22739      &              D      = 1.117D0,
22740      &              C      = 3.5489D0,
22741      &              A      = 0.2631D0,
22742      &              B      = 0.6452D0,
22743      &              ALPHAR = 0.415D0,
22744      &              E      = 0.1D0
22745      &          )
22746
22747       PARAMETER (NPOINT=16)
22748 C     DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22749       DIMENSION SEA(3),VAL(2)
22750
22751       DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22752       AN    = 1.5D0*(1.0D0+Q2/(Q2+C))
22753 * proton, deuteron
22754       IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22755          CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22756          SEA(1) = 0.75D0*SEA0
22757          SEA(2) = SEA(1)
22758          SEA(3) = SEA(1)
22759          VAL(1) = 9.0D0/4.0D0*VALU0
22760          VAL(2) = 9.0D0*VALD0
22761          GLU0   = SEA(1)/(1.0D0-X)
22762          F2     = SEA0+VALU0+VALD0
22763          F2PDF  = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+
22764      &            1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+
22765      &            1.0D0/9.0D0*(2.0D0*SEA(3))
22766          IF (ABS(F2-F2PDF).GT.TINY9) THEN
22767             WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF
22768             STOP
22769          ENDIF
22770 **PHOJET105a
22771 C        CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22772 **PHOJET112
22773 C        CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22774 **
22775 C        SUMQ = ZERO
22776 C        SUMG = ZERO
22777 C        DO 1 J=1,NPOINT
22778 C           CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
22779 C           VALU0 = 9.0D0/4.0D0*VALU0
22780 C           VALD0 = 9.0D0*VALD0
22781 C           SEA0  = 0.75D0*SEA0
22782 C           SUMQ  = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
22783 C           SUMG  = SUMG+ (SEA0/(1.0D0-ABSZX(J)))  *WEIGHT(J)
22784 C   1    CONTINUE
22785 C        GLU = GLU0*(1.0D0-SUMQ)/SUMG
22786       ELSE
22787          WRITE(LOUT,'(1X,A,I4,A)')
22788      &      'PDF0:   IPAR =',IPAR,' not implemented!'
22789          STOP
22790       ENDIF
22791
22792       RETURN
22793       END
22794
22795 *$ CREATE DT_CKMTQ0.FOR
22796 *COPY DT_CKMTQ0
22797 *
22798 *===ckmtq0=============================================================*
22799 *
22800       SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22801
22802 ************************************************************************
22803 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2       *
22804 * an F_2-ansatz given in Capella et al. PLB 337(1994)358.              *
22805 *                   IPAR  = 2212   proton                              *
22806 *                         =  100   deuteron                            *
22807 * This version dated 31.01.96 is written by S. Roesler                 *
22808 ************************************************************************
22809
22810       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22811       SAVE
22812       PARAMETER ( LINP = 10 ,
22813      &            LOUT = 6 ,
22814      &            LDAT = 9 )
22815       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22816
22817       PARAMETER (
22818      &              AA     = 0.1502D0,
22819      &              BBDEU  = 1.2D0,
22820      &              BUD    = 0.754D0,
22821      &              BDD    = 0.4495D0,
22822      &              BUP    = 1.2064D0,
22823      &              BDP    = 0.1798D0,
22824      &              DELTA0 = 0.07684D0,
22825      &              D      = 1.117D0,
22826      &              C      = 3.5489D0,
22827      &              A      = 0.2631D0,
22828      &              B      = 0.6452D0,
22829      &              ALPHAR = 0.415D0,
22830      &              E      = 0.1D0
22831      &          )
22832
22833       DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22834       AN    = 1.5D0*(1.0D0+Q2/(Q2+C))
22835 * proton, deuteron
22836       IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22837          IF (IPAR.EQ.2212) THEN
22838             BU = BUP
22839             BD = BDP
22840          ELSE
22841             BU = BUD
22842             BD = BDD
22843          ENDIF
22844          SEA0  = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)*
22845      &          (Q2/(Q2+A))**(1.0D0+DELTA)
22846          VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN*
22847      &           (Q2/(Q2+B))**(ALPHAR)
22848          VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)*
22849      &           (Q2/(Q2+B))**(ALPHAR)
22850       ELSE
22851          WRITE(LOUT,'(1X,A,I4,A)')
22852      &      'CKMTQ0: IPAR =',IPAR,' not implemented!'
22853          STOP
22854       ENDIF
22855       RETURN
22856       END
22857 C
22858 C
22859
22860 *$ CREATE DT_CKMTDE.FOR
22861 *COPY DT_CKMTDE
22862       SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
22863 C
22864 C**********************************************************************
22865 C    Deuteron - PDFs
22866 C    I   = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
22867 C    ANS = PDF(I)
22868 C    This version by S. Roesler, 30.01.96
22869 C**********************************************************************
22870
22871       SAVE
22872       DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
22873       EQUIVALENCE (GF(1,1,1),DL(1))
22874       DATA DELTA/.13/
22875 C
22876       DATA (DL(K),K=    1,   85) /
22877      &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00,
22878      &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00,
22879      &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01,
22880      &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00,
22881      &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00,
22882      &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00,
22883      &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00,
22884      &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00,
22885      &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00,
22886      &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00,
22887      &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02,
22888      &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01,
22889      &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01,
22890      &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01,
22891      &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01,
22892      &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01,
22893      &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/
22894       DATA (DL(K),K=   86,  170) /
22895      &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01,
22896      &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02,
22897      &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01,
22898      &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01,
22899      &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01,
22900      &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01,
22901      &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01,
22902      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22903      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22904      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22905      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22906      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22907      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22908      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22909      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22910      &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00,
22911      &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/
22912       DATA (DL(K),K=  171,  255) /
22913      &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01,
22914      &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00,
22915      &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00,
22916      &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00,
22917      &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00,
22918      &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00,
22919      &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00,
22920      &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00,
22921      &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02,
22922      &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00,
22923      &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00,
22924      &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00,
22925      &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00,
22926      &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00,
22927      &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01,
22928      &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01,
22929      &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/
22930       DATA (DL(K),K=  256,  340) /
22931      &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01,
22932      &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01,
22933      &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01,
22934      &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01,
22935      &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01,
22936      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22937      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22938      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22939      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22940      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22941      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22942      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22943      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22944      &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00,
22945      &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00,
22946      &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01,
22947      &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/
22948       DATA (DL(K),K=  341,  425) /
22949      &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00,
22950      &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00,
22951      &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00,
22952      &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00,
22953      &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00,
22954      &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00,
22955      &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02,
22956      &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00,
22957      &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00,
22958      &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00,
22959      &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00,
22960      &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00,
22961      &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00,
22962      &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01,
22963      &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02,
22964      &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00,
22965      &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/
22966       DATA (DL(K),K=  426,  510) /
22967      &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00,
22968      &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01,
22969      &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00,
22970      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22971      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22972      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22973      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22974      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22975      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22976      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22977      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22978      &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00,
22979      &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00,
22980      &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01,
22981      &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00,
22982      &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00,
22983      &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/
22984       DATA (DL(K),K=  511,  595) /
22985      &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00,
22986      &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00,
22987      &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00,
22988      &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00,
22989      &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01,
22990      &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00,
22991      &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00,
22992      &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00,
22993      &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00,
22994      &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00,
22995      &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00,
22996      &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00,
22997      &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01,
22998      &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00,
22999      &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00,
23000      &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00,
23001      &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/
23002       DATA (DL(K),K=  596,  680) /
23003      &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00,
23004      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23005      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23006      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23007      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23008      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23009      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23010      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23011      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23012      &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23013      &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00,
23014      &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01,
23015      &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00,
23016      &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00,
23017      &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00,
23018      &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00,
23019      &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/
23020       DATA (DL(K),K=  681,  765) /
23021      &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00,
23022      &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00,
23023      &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01,
23024      &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00,
23025      &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00,
23026      &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00,
23027      &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00,
23028      &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00,
23029      &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00,
23030      &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00,
23031      &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01,
23032      &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00,
23033      &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00,
23034      &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00,
23035      &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00,
23036      &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00,
23037      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23038       DATA (DL(K),K=  766,  850) /
23039      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23040      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23041      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23042      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23043      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23044      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23045      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23046      &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23047      &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00,
23048      &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01,
23049      &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00,
23050      &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00,
23051      &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00,
23052      &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00,
23053      &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01,
23054      &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00,
23055      &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/
23056       DATA (DL(K),K=  851,  935) /
23057      &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01,
23058      &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00,
23059      &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00,
23060      &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00,
23061      &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00,
23062      &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00,
23063      &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00,
23064      &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00,
23065      &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01,
23066      &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00,
23067      &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00,
23068      &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00,
23069      &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00,
23070      &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00,
23071      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23072      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23073      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23074       DATA (DL(K),K=  936, 1020) /
23075      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23076      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23077      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23078      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23079      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23080      &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23081      &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00,
23082      &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01,
23083      &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00,
23084      &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00,
23085      &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00,
23086      &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00,
23087      &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01,
23088      &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00,
23089      &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00,
23090      &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01,
23091      &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/
23092       DATA (DL(K),K= 1021, 1105) /
23093      &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00,
23094      &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00,
23095      &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00,
23096      &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01,
23097      &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00,
23098      &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00,
23099      &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01,
23100      &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00,
23101      &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00,
23102      &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00,
23103      &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00,
23104      &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01,
23105      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23106      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23107      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23108      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23109      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23110       DATA (DL(K),K= 1106, 1190) /
23111      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23112      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23113      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23114      &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01,
23115      &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00,
23116      &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01,
23117      &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01,
23118      &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00,
23119      &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01,
23120      &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01,
23121      &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01,
23122      &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01,
23123      &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00,
23124      &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01,
23125      &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01,
23126      &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00,
23127      &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/
23128       DATA (DL(K),K= 1191, 1275) /
23129      &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01,
23130      &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01,
23131      &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01,
23132      &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00,
23133      &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00,
23134      &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01,
23135      &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00,
23136      &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01,
23137      &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01,
23138      &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01,
23139      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23140      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23141      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23142      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23143      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23144      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23145      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23146       DATA (DL(K),K= 1276, 1360) /
23147      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23148      &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01,
23149      &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00,
23150      &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00,
23151      &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01,
23152      &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00,
23153      &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01,
23154      &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01,
23155      &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02,
23156      &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01,
23157      &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00,
23158      &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00,
23159      &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01,
23160      &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00,
23161      &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01,
23162      &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01,
23163      &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/
23164       DATA (DL(K),K= 1361, 1445) /
23165      &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01,
23166      &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00,
23167      &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00,
23168      &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01,
23169      &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00,
23170      &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01,
23171      &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01,
23172      &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01,
23173      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23174      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23175      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23176      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23177      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23178      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23179      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23180      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23181      &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/
23182       DATA (DL(K),K= 1446, 1530) /
23183      &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00,
23184      &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00,
23185      &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01,
23186      &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00,
23187      &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01,
23188      &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01,
23189      &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02,
23190      &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01,
23191      &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00,
23192      &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00,
23193      &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01,
23194      &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00,
23195      &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01,
23196      &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01,
23197      &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02,
23198      &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01,
23199      &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/
23200       DATA (DL(K),K= 1531, 1615) /
23201      &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00,
23202      &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01,
23203      &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00,
23204      &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01,
23205      &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01,
23206      &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02,
23207      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23208      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23209      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23210      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23211      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23212      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23213      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23214      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23215      &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01,
23216      &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00,
23217      &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/
23218       DATA (DL(K),K= 1616, 1700) /
23219      &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01,
23220      &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00,
23221      &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01,
23222      &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01,
23223      &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02,
23224      &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01,
23225      &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00,
23226      &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00,
23227      &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01,
23228      &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00,
23229      &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01,
23230      &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01,
23231      &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02,
23232      &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01,
23233      &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00,
23234      &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00,
23235      &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/
23236       DATA (DL(K),K= 1701, 1785) /
23237      &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00,
23238      &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02,
23239      &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02,
23240      &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02,
23241      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23242      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23243      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23244      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23245      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23246      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23247      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23248      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23249      &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01,
23250      &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00,
23251      &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00,
23252      &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01,
23253      &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/
23254       DATA (DL(K),K= 1786, 1870) /
23255      &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01,
23256      &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01,
23257      &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02,
23258      &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02,
23259      &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00,
23260      &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00,
23261      &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02,
23262      &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00,
23263      &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02,
23264      &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02,
23265      &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02,
23266      &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02,
23267      &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00,
23268      &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01,
23269      &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02,
23270      &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00,
23271      &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/
23272       DATA (DL(K),K= 1871, 1955) /
23273      &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02,
23274      &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02,
23275      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23276      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23277      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23278      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23279      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23280      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23281      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23282      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23283      &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02,
23284      &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00,
23285      &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00,
23286      &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02,
23287      &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00,
23288      &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02,
23289      &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/
23290       DATA (DL(K),K= 1956, 2040) /
23291      &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03,
23292      &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02,
23293      &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00,
23294      &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01,
23295      &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02,
23296      &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00,
23297      &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02,
23298      &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02,
23299      &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03,
23300      &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02,
23301      &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00,
23302      &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01,
23303      &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02,
23304      &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00,
23305      &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02,
23306      &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02,
23307      &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/
23308       DATA (DL(K),K= 2041, 2125) /
23309      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23310      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23311      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23312      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23313      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23314      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23315      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23316      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23317      &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02,
23318      &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00,
23319      &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00,
23320      &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02,
23321      &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00,
23322      &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02,
23323      &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02,
23324      &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03,
23325      &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/
23326       DATA (DL(K),K= 2126, 2210) /
23327      &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00,
23328      &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01,
23329      &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02,
23330      &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00,
23331      &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02,
23332      &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02,
23333      &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03,
23334      &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02,
23335      &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00,
23336      &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01,
23337      &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02,
23338      &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00,
23339      &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02,
23340      &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02,
23341      &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03,
23342      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23343      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23344       DATA (DL(K),K= 2211, 2295) /
23345      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23346      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23347      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23348      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23349      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23350      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23351      &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23352      &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00,
23353      &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01,
23354      &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02,
23355      &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00,
23356      &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02,
23357      &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02,
23358      &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03,
23359      &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02,
23360      &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00,
23361      &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/
23362       DATA (DL(K),K= 2296, 2380) /
23363      &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02,
23364      &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00,
23365      &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02,
23366      &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02,
23367      &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03,
23368      &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03,
23369      &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00,
23370      &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01,
23371      &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03,
23372      &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01,
23373      &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03,
23374      &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03,
23375      &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03,
23376      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23377      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23378      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23379      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23380       DATA (DL(K),K= 2381, 2465) /
23381      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23382      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23383      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23384      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23385      &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23386      &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00,
23387      &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01,
23388      &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02,
23389      &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00,
23390      &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02,
23391      &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02,
23392      &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04,
23393      &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03,
23394      &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00,
23395      &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01,
23396      &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03,
23397      &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/
23398       DATA (DL(K),K= 2466, 2550) /
23399      &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03,
23400      &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03,
23401      &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03,
23402      &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03,
23403      &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01,
23404      &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02,
23405      &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03,
23406      &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01,
23407      &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03,
23408      &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03,
23409      &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04,
23410      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23411      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23412      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23413      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23414      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23415      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23416       DATA (DL(K),K= 2551, 2635) /
23417      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23418      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23419      &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03,
23420      &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00,
23421      &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01,
23422      &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03,
23423      &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00,
23424      &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03,
23425      &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03,
23426      &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04,
23427      &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03,
23428      &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00,
23429      &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01,
23430      &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03,
23431      &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01,
23432      &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03,
23433      &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/
23434       DATA (DL(K),K= 2636, 2720) /
23435      &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04,
23436      &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03,
23437      &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01,
23438      &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02,
23439      &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03,
23440      &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01,
23441      &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03,
23442      &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03,
23443      &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04,
23444      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23445      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23446      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23447      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23448      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23449      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23450      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23451      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23452       DATA (DL(K),K= 2721, 2805) /
23453      &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03,
23454      &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00,
23455      &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01,
23456      &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03,
23457      &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00,
23458      &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03,
23459      &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03,
23460      &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04,
23461      &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03,
23462      &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01,
23463      &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02,
23464      &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03,
23465      &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01,
23466      &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03,
23467      &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03,
23468      &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04,
23469      &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/
23470       DATA (DL(K),K= 2806, 2890) /
23471      &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01,
23472      &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02,
23473      &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04,
23474      &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01,
23475      &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04,
23476      &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04,
23477      &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04,
23478      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23479      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23480      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23481      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23482      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23483      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23484      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23485      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23486      &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03,
23487      &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/
23488       DATA (DL(K),K= 2891, 2975) /
23489      &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02,
23490      &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03,
23491      &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01,
23492      &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03,
23493      &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04,
23494      &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05,
23495      &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04,
23496      &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01,
23497      &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02,
23498      &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04,
23499      &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01,
23500      &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04,
23501      &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04,
23502      &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05,
23503      &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04,
23504      &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01,
23505      &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/
23506       DATA (DL(K),K= 2976, 3060) /
23507      &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04,
23508      &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01,
23509      &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04,
23510      &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04,
23511      &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05,
23512      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23513      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23514      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23515      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23516      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23517      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23518      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23519      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23520      &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04,
23521      &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01,
23522      &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02,
23523      &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/
23524       DATA (DL(K),K= 3061, 3145) /
23525      &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01,
23526      &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04,
23527      &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04,
23528      &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06,
23529      &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04,
23530      &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01,
23531      &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02,
23532      &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04,
23533      &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01,
23534      &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04,
23535      &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04,
23536      &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05,
23537      &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04,
23538      &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01,
23539      &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03,
23540      &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04,
23541      &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/
23542       DATA (DL(K),K= 3146, 3230) /
23543      &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05,
23544      &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05,
23545      &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05,
23546      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23547      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23548      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23549      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23550      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23551      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23552      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23553      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23554      &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04,
23555      &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01,
23556      &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02,
23557      &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04,
23558      &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01,
23559      &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/
23560       DATA (DL(K),K= 3231, 3315) /
23561      &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05,
23562      &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06,
23563      &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05,
23564      &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01,
23565      &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03,
23566      &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05,
23567      &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01,
23568      &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05,
23569      &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05,
23570      &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06,
23571      &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05,
23572      &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02,
23573      &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03,
23574      &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05,
23575      &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02,
23576      &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05,
23577      &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/
23578       DATA (DL(K),K= 3316, 3400) /
23579      &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07,
23580      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23581      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23582      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23583      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23584      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23585      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23586      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23587      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23588      &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05,
23589      &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01,
23590      &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03,
23591      &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05,
23592      &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01,
23593      &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05,
23594      &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05,
23595      &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/
23596       DATA (DL(K),K= 3401, 3485) /
23597      &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05,
23598      &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02,
23599      &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03,
23600      &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05,
23601      &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01,
23602      &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06,
23603      &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06,
23604      &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06,
23605      &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06,
23606      &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02,
23607      &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04,
23608      &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05,
23609      &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02,
23610      &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07,
23611      &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07,
23612      &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06,
23613      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23614       DATA (DL(K),K= 3486, 3570) /
23615      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23616      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23617      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23618      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23619      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23620      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23621      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23622      &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05,
23623      &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02,
23624      &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03,
23625      &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05,
23626      &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01,
23627      &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07,
23628      &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07,
23629      &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06,
23630      &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07,
23631      &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/
23632       DATA (DL(K),K= 3571, 3655) /
23633      &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04,
23634      &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05,
23635      &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02,
23636      &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07,
23637      &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07,
23638      &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06,
23639      &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07,
23640      &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03,
23641      &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04,
23642      &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06,
23643      &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02,
23644      &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07,
23645      &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07,
23646      &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07,
23647      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23648      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23649      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23650       DATA (DL(K),K= 3656, 3740) /
23651      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23652      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23653      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23654      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23655      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23656      &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07,
23657      &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02,
23658      &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04,
23659      &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06,
23660      &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02,
23661      &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06,
23662      &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06,
23663      &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06,
23664      &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06,
23665      &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03,
23666      &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04,
23667      &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/
23668       DATA (DL(K),K= 3741, 3825) /
23669      &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02,
23670      &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07,
23671      &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07,
23672      &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07,
23673      &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07,
23674      &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03,
23675      &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05,
23676      &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07,
23677      &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03,
23678      &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07,
23679      &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08,
23680      &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08,
23681      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23682      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23683      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23684      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23685      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23686       DATA (DL(K),K= 3826, 3910) /
23687      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23688      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23689      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23690      &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08,
23691      &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03,
23692      &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05,
23693      &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06,
23694      &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02,
23695      &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06,
23696      &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06,
23697      &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06,
23698      &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06,
23699      &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04,
23700      &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05,
23701      &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06,
23702      &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03,
23703      &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/
23704       DATA (DL(K),K= 3911, 3995) /
23705      &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07,
23706      &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07,
23707      &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07,
23708      &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04,
23709      &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06,
23710      &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06,
23711      &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04,
23712      &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07,
23713      &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07,
23714      &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07,
23715      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23716      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23717      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23718      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23719      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23720      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23721      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23722       DATA (DL(K),K= 3996, 4000) /
23723      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23724 C
23725       ANS = 0.
23726       IF (X.GT.0.9985) RETURN
23727       IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
23728 C
23729       IS  = S/DELTA+1
23730       IS1 = IS+1
23731       DO 1 L=1,25
23732          KL    = L+NDRV*25
23733          F1(L) = GF(I,IS,KL)
23734          F2(L) = GF(I,IS1,KL)
23735     1 CONTINUE
23736       A1 = DT_CKMTFF(X,F1)
23737       A2 = DT_CKMTFF(X,F2)
23738 C      A1=ALOG(A1)
23739 C      A2=ALOG(A2)
23740       S1  = (IS-1)*DELTA
23741       S2  = S1+DELTA
23742       ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
23743 C      ANS=EXP(ANS)
23744       RETURN
23745       END
23746 C
23747 C
23748
23749 *$ CREATE DT_CKMTPR.FOR
23750 *COPY DT_CKMTPR
23751       SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
23752 C
23753 C**********************************************************************
23754 C    Proton   - PDFs
23755 C    I   = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
23756 C    ANS = PDF(I)
23757 C    This version by S. Roesler, 31.01.96
23758 C**********************************************************************
23759
23760       SAVE
23761       DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
23762       EQUIVALENCE (GF(1,1,1),DL(1))
23763       DATA DELTA/.10/
23764 C
23765       DATA (DL(K),K=    1,   85) /
23766      &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00,
23767      &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00,
23768      &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01,
23769      &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00,
23770      &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00,
23771      &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00,
23772      &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00,
23773      &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00,
23774      &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00,
23775      &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00,
23776      &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02,
23777      &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00,
23778      &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01,
23779      &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00,
23780      &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01,
23781      &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00,
23782      &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/
23783       DATA (DL(K),K=   86,  170) /
23784      &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01,
23785      &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02,
23786      &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01,
23787      &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01,
23788      &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01,
23789      &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01,
23790      &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01,
23791      &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01,
23792      &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01,
23793      &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02,
23794      &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01,
23795      &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01,
23796      &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01,
23797      &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23798      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23799      &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00,
23800      &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/
23801       DATA (DL(K),K=  171,  255) /
23802      &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01,
23803      &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00,
23804      &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00,
23805      &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00,
23806      &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00,
23807      &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00,
23808      &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00,
23809      &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00,
23810      &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02,
23811      &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00,
23812      &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00,
23813      &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00,
23814      &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00,
23815      &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00,
23816      &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00,
23817      &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01,
23818      &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/
23819       DATA (DL(K),K=  256,  340) /
23820      &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01,
23821      &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01,
23822      &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01,
23823      &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01,
23824      &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01,
23825      &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01,
23826      &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01,
23827      &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02,
23828      &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01,
23829      &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01,
23830      &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01,
23831      &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23832      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23833      &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00,
23834      &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00,
23835      &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01,
23836      &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/
23837       DATA (DL(K),K=  341,  425) /
23838      &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00,
23839      &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00,
23840      &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00,
23841      &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00,
23842      &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00,
23843      &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00,
23844      &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01,
23845      &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00,
23846      &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00,
23847      &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00,
23848      &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00,
23849      &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00,
23850      &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00,
23851      &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00,
23852      &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02,
23853      &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00,
23854      &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/
23855       DATA (DL(K),K=  426,  510) /
23856      &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00,
23857      &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00,
23858      &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00,
23859      &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00,
23860      &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01,
23861      &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02,
23862      &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01,
23863      &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01,
23864      &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01,
23865      &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23866      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23867      &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00,
23868      &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00,
23869      &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01,
23870      &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00,
23871      &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00,
23872      &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/
23873       DATA (DL(K),K=  511,  595) /
23874      &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00,
23875      &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00,
23876      &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00,
23877      &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00,
23878      &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01,
23879      &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00,
23880      &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00,
23881      &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00,
23882      &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00,
23883      &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00,
23884      &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00,
23885      &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00,
23886      &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01,
23887      &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00,
23888      &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00,
23889      &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00,
23890      &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/
23891       DATA (DL(K),K=  596,  680) /
23892      &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00,
23893      &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00,
23894      &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00,
23895      &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02,
23896      &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00,
23897      &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00,
23898      &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00,
23899      &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23900      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23901      &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23902      &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00,
23903      &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01,
23904      &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00,
23905      &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00,
23906      &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00,
23907      &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00,
23908      &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/
23909       DATA (DL(K),K=  681,  765) /
23910      &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00,
23911      &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00,
23912      &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01,
23913      &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00,
23914      &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00,
23915      &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00,
23916      &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00,
23917      &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00,
23918      &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00,
23919      &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00,
23920      &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01,
23921      &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00,
23922      &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00,
23923      &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00,
23924      &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00,
23925      &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00,
23926      &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/
23927       DATA (DL(K),K=  766,  850) /
23928      &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00,
23929      &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01,
23930      &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00,
23931      &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00,
23932      &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00,
23933      &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23934      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23935      &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23936      &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00,
23937      &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01,
23938      &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00,
23939      &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00,
23940      &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00,
23941      &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00,
23942      &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01,
23943      &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00,
23944      &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/
23945       DATA (DL(K),K=  851,  935) /
23946      &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01,
23947      &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00,
23948      &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00,
23949      &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00,
23950      &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00,
23951      &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00,
23952      &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00,
23953      &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00,
23954      &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01,
23955      &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00,
23956      &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00,
23957      &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00,
23958      &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00,
23959      &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00,
23960      &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00,
23961      &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00,
23962      &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/
23963       DATA (DL(K),K=  936, 1020) /
23964      &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00,
23965      &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00,
23966      &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00,
23967      &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23968      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23969      &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23970      &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00,
23971      &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01,
23972      &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00,
23973      &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00,
23974      &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00,
23975      &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00,
23976      &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01,
23977      &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00,
23978      &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00,
23979      &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01,
23980      &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/
23981       DATA (DL(K),K= 1021, 1105) /
23982      &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00,
23983      &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00,
23984      &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00,
23985      &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01,
23986      &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00,
23987      &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00,
23988      &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01,
23989      &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00,
23990      &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00,
23991      &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00,
23992      &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00,
23993      &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01,
23994      &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00,
23995      &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00,
23996      &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01,
23997      &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00,
23998      &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/
23999       DATA (DL(K),K= 1106, 1190) /
24000      &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00,
24001      &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00,
24002      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24003      &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01,
24004      &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00,
24005      &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01,
24006      &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01,
24007      &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00,
24008      &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01,
24009      &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01,
24010      &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01,
24011      &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01,
24012      &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00,
24013      &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01,
24014      &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01,
24015      &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00,
24016      &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/
24017       DATA (DL(K),K= 1191, 1275) /
24018      &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01,
24019      &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01,
24020      &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01,
24021      &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00,
24022      &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00,
24023      &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01,
24024      &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00,
24025      &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01,
24026      &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01,
24027      &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01,
24028      &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01,
24029      &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00,
24030      &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00,
24031      &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01,
24032      &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00,
24033      &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01,
24034      &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/
24035       DATA (DL(K),K= 1276, 1360) /
24036      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24037      &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01,
24038      &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00,
24039      &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00,
24040      &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01,
24041      &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00,
24042      &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01,
24043      &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01,
24044      &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02,
24045      &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01,
24046      &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00,
24047      &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00,
24048      &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01,
24049      &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00,
24050      &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01,
24051      &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01,
24052      &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/
24053       DATA (DL(K),K= 1361, 1445) /
24054      &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01,
24055      &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00,
24056      &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00,
24057      &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01,
24058      &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00,
24059      &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01,
24060      &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01,
24061      &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01,
24062      &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01,
24063      &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00,
24064      &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00,
24065      &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01,
24066      &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00,
24067      &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01,
24068      &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00,
24069      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24070      &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/
24071       DATA (DL(K),K= 1446, 1530) /
24072      &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00,
24073      &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00,
24074      &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01,
24075      &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00,
24076      &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01,
24077      &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01,
24078      &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02,
24079      &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01,
24080      &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00,
24081      &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00,
24082      &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01,
24083      &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00,
24084      &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01,
24085      &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01,
24086      &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02,
24087      &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01,
24088      &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/
24089       DATA (DL(K),K= 1531, 1615) /
24090      &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00,
24091      &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01,
24092      &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00,
24093      &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01,
24094      &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01,
24095      &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02,
24096      &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01,
24097      &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00,
24098      &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00,
24099      &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01,
24100      &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00,
24101      &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01,
24102      &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24103      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24104      &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01,
24105      &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00,
24106      &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/
24107       DATA (DL(K),K= 1616, 1700) /
24108      &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01,
24109      &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00,
24110      &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01,
24111      &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01,
24112      &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02,
24113      &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01,
24114      &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00,
24115      &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00,
24116      &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01,
24117      &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00,
24118      &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01,
24119      &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01,
24120      &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02,
24121      &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01,
24122      &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00,
24123      &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00,
24124      &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/
24125       DATA (DL(K),K= 1701, 1785) /
24126      &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00,
24127      &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01,
24128      &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01,
24129      &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02,
24130      &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01,
24131      &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00,
24132      &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00,
24133      &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02,
24134      &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00,
24135      &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02,
24136      &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24137      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24138      &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01,
24139      &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00,
24140      &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00,
24141      &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01,
24142      &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/
24143       DATA (DL(K),K= 1786, 1870) /
24144      &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01,
24145      &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01,
24146      &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02,
24147      &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01,
24148      &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00,
24149      &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00,
24150      &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02,
24151      &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00,
24152      &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02,
24153      &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02,
24154      &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02,
24155      &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02,
24156      &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00,
24157      &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00,
24158      &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02,
24159      &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00,
24160      &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/
24161       DATA (DL(K),K= 1871, 1955) /
24162      &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02,
24163      &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02,
24164      &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02,
24165      &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00,
24166      &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01,
24167      &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02,
24168      &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00,
24169      &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02,
24170      &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24171      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24172      &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02,
24173      &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00,
24174      &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00,
24175      &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02,
24176      &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00,
24177      &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02,
24178      &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/
24179       DATA (DL(K),K= 1956, 2040) /
24180      &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03,
24181      &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02,
24182      &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00,
24183      &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00,
24184      &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02,
24185      &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00,
24186      &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02,
24187      &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02,
24188      &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03,
24189      &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02,
24190      &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00,
24191      &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01,
24192      &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02,
24193      &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00,
24194      &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02,
24195      &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02,
24196      &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/
24197       DATA (DL(K),K= 2041, 2125) /
24198      &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02,
24199      &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01,
24200      &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01,
24201      &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02,
24202      &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00,
24203      &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02,
24204      &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24205      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24206      &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02,
24207      &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00,
24208      &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00,
24209      &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02,
24210      &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00,
24211      &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02,
24212      &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02,
24213      &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03,
24214      &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/
24215       DATA (DL(K),K= 2126, 2210) /
24216      &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00,
24217      &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01,
24218      &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02,
24219      &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00,
24220      &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02,
24221      &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02,
24222      &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03,
24223      &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02,
24224      &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01,
24225      &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01,
24226      &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02,
24227      &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00,
24228      &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02,
24229      &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02,
24230      &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03,
24231      &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02,
24232      &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/
24233       DATA (DL(K),K= 2211, 2295) /
24234      &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01,
24235      &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02,
24236      &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00,
24237      &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02,
24238      &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24239      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24240      &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02,
24241      &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00,
24242      &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01,
24243      &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02,
24244      &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00,
24245      &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02,
24246      &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02,
24247      &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03,
24248      &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02,
24249      &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01,
24250      &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/
24251       DATA (DL(K),K= 2296, 2380) /
24252      &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02,
24253      &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00,
24254      &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02,
24255      &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02,
24256      &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03,
24257      &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02,
24258      &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01,
24259      &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01,
24260      &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02,
24261      &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00,
24262      &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03,
24263      &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03,
24264      &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03,
24265      &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03,
24266      &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01,
24267      &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01,
24268      &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/
24269       DATA (DL(K),K= 2381, 2465) /
24270      &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00,
24271      &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03,
24272      &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24273      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24274      &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02,
24275      &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00,
24276      &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01,
24277      &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02,
24278      &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00,
24279      &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02,
24280      &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02,
24281      &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04,
24282      &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02,
24283      &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01,
24284      &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01,
24285      &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03,
24286      &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/
24287       DATA (DL(K),K= 2466, 2550) /
24288      &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03,
24289      &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03,
24290      &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03,
24291      &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03,
24292      &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01,
24293      &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01,
24294      &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03,
24295      &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00,
24296      &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03,
24297      &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03,
24298      &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03,
24299      &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03,
24300      &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01,
24301      &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02,
24302      &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03,
24303      &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00,
24304      &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/
24305       DATA (DL(K),K= 2551, 2635) /
24306      &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24307      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24308      &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03,
24309      &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01,
24310      &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01,
24311      &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03,
24312      &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00,
24313      &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03,
24314      &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03,
24315      &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04,
24316      &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03,
24317      &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01,
24318      &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01,
24319      &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03,
24320      &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00,
24321      &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03,
24322      &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/
24323       DATA (DL(K),K= 2636, 2720) /
24324      &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04,
24325      &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03,
24326      &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01,
24327      &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02,
24328      &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03,
24329      &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00,
24330      &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03,
24331      &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03,
24332      &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04,
24333      &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03,
24334      &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01,
24335      &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02,
24336      &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03,
24337      &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01,
24338      &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03,
24339      &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24340      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24341       DATA (DL(K),K= 2721, 2805) /
24342      &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03,
24343      &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01,
24344      &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01,
24345      &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03,
24346      &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00,
24347      &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03,
24348      &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03,
24349      &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04,
24350      &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03,
24351      &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01,
24352      &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02,
24353      &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03,
24354      &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00,
24355      &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03,
24356      &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03,
24357      &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04,
24358      &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/
24359       DATA (DL(K),K= 2806, 2890) /
24360      &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01,
24361      &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02,
24362      &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03,
24363      &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01,
24364      &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04,
24365      &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04,
24366      &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04,
24367      &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04,
24368      &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01,
24369      &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02,
24370      &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04,
24371      &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01,
24372      &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04,
24373      &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24374      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24375      &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03,
24376      &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/
24377       DATA (DL(K),K= 2891, 2975) /
24378      &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02,
24379      &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03,
24380      &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00,
24381      &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03,
24382      &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03,
24383      &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05,
24384      &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04,
24385      &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01,
24386      &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02,
24387      &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04,
24388      &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00,
24389      &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04,
24390      &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04,
24391      &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05,
24392      &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04,
24393      &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01,
24394      &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/
24395       DATA (DL(K),K= 2976, 3060) /
24396      &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04,
24397      &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01,
24398      &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04,
24399      &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04,
24400      &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05,
24401      &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04,
24402      &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02,
24403      &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02,
24404      &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04,
24405      &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01,
24406      &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04,
24407      &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24408      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24409      &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04,
24410      &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01,
24411      &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02,
24412      &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/
24413       DATA (DL(K),K= 3061, 3145) /
24414      &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00,
24415      &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04,
24416      &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04,
24417      &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05,
24418      &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04,
24419      &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01,
24420      &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02,
24421      &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04,
24422      &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01,
24423      &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04,
24424      &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04,
24425      &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05,
24426      &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04,
24427      &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02,
24428      &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02,
24429      &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04,
24430      &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/
24431       DATA (DL(K),K= 3146, 3230) /
24432      &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04,
24433      &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04,
24434      &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05,
24435      &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05,
24436      &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02,
24437      &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03,
24438      &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05,
24439      &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01,
24440      &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05,
24441      &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24442      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24443      &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04,
24444      &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01,
24445      &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02,
24446      &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04,
24447      &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01,
24448      &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/
24449       DATA (DL(K),K= 3231, 3315) /
24450      &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04,
24451      &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06,
24452      &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04,
24453      &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02,
24454      &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03,
24455      &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05,
24456      &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01,
24457      &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05,
24458      &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05,
24459      &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06,
24460      &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05,
24461      &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02,
24462      &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03,
24463      &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05,
24464      &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01,
24465      &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05,
24466      &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/
24467       DATA (DL(K),K= 3316, 3400) /
24468      &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06,
24469      &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05,
24470      &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02,
24471      &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03,
24472      &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05,
24473      &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01,
24474      &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05,
24475      &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24476      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24477      &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05,
24478      &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02,
24479      &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03,
24480      &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05,
24481      &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01,
24482      &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05,
24483      &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05,
24484      &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/
24485       DATA (DL(K),K= 3401, 3485) /
24486      &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05,
24487      &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02,
24488      &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03,
24489      &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05,
24490      &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01,
24491      &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05,
24492      &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05,
24493      &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07,
24494      &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05,
24495      &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02,
24496      &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03,
24497      &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05,
24498      &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01,
24499      &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06,
24500      &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06,
24501      &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06,
24502      &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/
24503       DATA (DL(K),K= 3486, 3570) /
24504      &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03,
24505      &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04,
24506      &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06,
24507      &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02,
24508      &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06,
24509      &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24510      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24511      &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05,
24512      &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02,
24513      &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03,
24514      &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06,
24515      &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01,
24516      &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06,
24517      &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06,
24518      &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07,
24519      &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06,
24520      &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/
24521       DATA (DL(K),K= 3571, 3655) /
24522      &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03,
24523      &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06,
24524      &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01,
24525      &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06,
24526      &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06,
24527      &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07,
24528      &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06,
24529      &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03,
24530      &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04,
24531      &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06,
24532      &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02,
24533      &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07,
24534      &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07,
24535      &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07,
24536      &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07,
24537      &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03,
24538      &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/
24539       DATA (DL(K),K= 3656, 3740) /
24540      &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06,
24541      &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02,
24542      &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07,
24543      &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00,
24544      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24545      &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07,
24546      &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02,
24547      &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04,
24548      &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07,
24549      &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01,
24550      &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07,
24551      &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07,
24552      &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07,
24553      &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07,
24554      &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03,
24555      &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04,
24556      &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/
24557       DATA (DL(K),K= 3741, 3825) /
24558      &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02,
24559      &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07,
24560      &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07,
24561      &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07,
24562      &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07,
24563      &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03,
24564      &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04,
24565      &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07,
24566      &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02,
24567      &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07,
24568      &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07,
24569      &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08,
24570      &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07,
24571      &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04,
24572      &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05,
24573      &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09,
24574      &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/
24575       DATA (DL(K),K= 3826, 3910) /
24576      &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08,
24577      &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00,
24578      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24579      &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08,
24580      &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03,
24581      &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05,
24582      &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06,
24583      &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02,
24584      &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07,
24585      &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07,
24586      &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07,
24587      &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07,
24588      &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04,
24589      &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05,
24590      &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06,
24591      &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03,
24592      &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/
24593       DATA (DL(K),K= 3911, 3995) /
24594      &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07,
24595      &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07,
24596      &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07,
24597      &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04,
24598      &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06,
24599      &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07,
24600      &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03,
24601      &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07,
24602      &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07,
24603      &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07,
24604      &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07,
24605      &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05,
24606      &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06,
24607      &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07,
24608      &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04,
24609      &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08,
24610      &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/
24611       DATA (DL(K),K= 3996, 4000) /
24612      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24613 C
24614       ANS = 0.
24615       IF (X.GT.0.9985) RETURN
24616       IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
24617 C
24618       IS  = S/DELTA+1
24619       IS1 = IS+1
24620       DO 1 L=1,25
24621          KL    = L+NDRV*25
24622          F1(L) = GF(I,IS,KL)
24623          F2(L) = GF(I,IS1,KL)
24624     1 CONTINUE
24625       A1 = DT_CKMTFF(X,F1)
24626       A2 = DT_CKMTFF(X,F2)
24627 C      A1=ALOG(A1)
24628 C      A2=ALOG(A2)
24629       S1  = (IS-1)*DELTA
24630       S2  = S1+DELTA
24631       ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
24632 C      ANS=EXP(ANS)
24633       RETURN
24634       END
24635 C
24636
24637 *$ CREATE DT_CKMTFF.FOR
24638 *COPY DT_CKMTFF
24639       FUNCTION DT_CKMTFF(X,FVL)
24640 C**********************************************************************
24641 C
24642 C     LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
24643 C     FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
24644 C     NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
24645 C     IN MAIN ROUTINE.
24646 C
24647 C**********************************************************************
24648
24649       SAVE
24650       DIMENSION FVL(25),XGRID(25)
24651       DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
24652      *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
24653 C
24654       DT_CKMTFF=0.
24655       DO 1 I=1,NX
24656       IF(X.LT.XGRID(I)) GO TO 2
24657     1 CONTINUE
24658     2 I=I-1
24659       IF(I.EQ.0) THEN
24660          I=I+1
24661       ELSE IF(I.GT.23) THEN
24662          I=23
24663       ENDIF
24664       J=I+1
24665       K=J+1
24666       AXI=LOG(XGRID(I))
24667       BXI=LOG(1.-XGRID(I))
24668       AXJ=LOG(XGRID(J))
24669       BXJ=LOG(1.-XGRID(J))
24670       AXK=LOG(XGRID(K))
24671       BXK=LOG(1.-XGRID(K))
24672       FI=LOG(ABS(FVL(I)) +1.E-15)
24673       FJ=LOG(ABS(FVL(J)) +1.E-16)
24674       FK=LOG(ABS(FVL(K)) +1.E-17)
24675       DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
24676       ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
24677      $ BXI))/DET
24678       ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
24679       BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
24680       IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
24681      1RETURN
24682 C      IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
24683 C         WRITE(6,2001) X,FVL
24684 C 2001    FORMAT(8E12.4)
24685 C         WRITE(6,2001) ALPHA,BETA,ALOGA,DET
24686 C      ENDIF
24687       DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
24688       RETURN
24689       END
24690
24691 *$ CREATE DT_FLUINI.FOR
24692 *COPY DT_FLUINI
24693 *
24694 *===fluini=============================================================*
24695 *
24696       SUBROUTINE DT_FLUINI
24697
24698 ************************************************************************
24699 * Initialisation of the nucleon-nucleon cross section fluctuation      *
24700 * treatment. The original version by J. Ranft.                         *
24701 * This version dated 21.04.95 is revised by S. Roesler.                *
24702 ************************************************************************
24703
24704       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24705       SAVE
24706       PARAMETER ( LINP = 10 ,
24707      &            LOUT = 6 ,
24708      &            LDAT = 9 )
24709       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
24710
24711       PARAMETER ( A     = 0.1D0,
24712      &            B     = 0.893D0,
24713      &            OM    = 1.1D0,
24714      &            N     = 6,
24715      &            DX    = 0.003D0)
24716
24717 * n-n cross section fluctuations
24718       PARAMETER (NBINS = 1000)
24719       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
24720       DIMENSION FLUSI(NBINS),FLUIX(NBINS)
24721
24722       WRITE(LOUT,1000)
24723  1000 FORMAT(/,1X,'FLUINI:  hadronic cross section fluctuations ',
24724      &       'treated')
24725
24726       FLUSU  = ZERO
24727       FLUSUU = ZERO
24728
24729       DO 1 I=1,NBINS
24730          X        = DBLE(I)*DX
24731          FLUIX(I) = X
24732          FLUS     = ((X-B)/(OM*B))**N
24733          IF (FLUS.LE.20.0D0) THEN
24734             FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
24735          ELSE
24736             FLUSI(I) = ZERO
24737          ENDIF
24738          FLUSU = FLUSU+FLUSI(I)
24739     1 CONTINUE
24740       DO 2 I=1,NBINS
24741          FLUSUU   = FLUSUU+FLUSI(I)/FLUSU
24742          FLUSI(I) = FLUSUU
24743     2 CONTINUE
24744
24745 C     WRITE(LOUT,1001)
24746 C1001 FORMAT(1X,'FLUCTUATIONS')
24747 C     CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
24748
24749       DO 3 I=1,NBINS
24750          AF = DBLE(I)*0.001D0
24751          DO 4 J=1,NBINS
24752             IF (AF.LE.FLUSI(J)) THEN
24753                FLUIXX(I) = FLUIX(J)
24754                GOTO 5
24755             ENDIF
24756     4    CONTINUE
24757     5    CONTINUE
24758     3 CONTINUE
24759       FLUIXX(1)     = FLUIX(1)
24760       FLUIXX(NBINS) = FLUIX(NBINS)
24761
24762       RETURN
24763       END
24764
24765 *$ CREATE DT_SIGTBL.FOR
24766 *COPY DT_SIGTBL
24767 *
24768 *===sigtab=============================================================*
24769 *
24770       SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
24771
24772 ************************************************************************
24773 * This version dated 18.11.95 is written by S. Roesler                 *
24774 ************************************************************************
24775
24776       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24777       SAVE
24778       PARAMETER ( LINP = 10 ,
24779      &            LOUT = 6 ,
24780      &            LDAT = 9 )
24781
24782       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24783      &           OHALF=0.5D0,ONE=1.0D0)
24784       PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150)
24785
24786       LOGICAL LINIT
24787
24788 * particle properties (BAMJET index convention)
24789       CHARACTER*8  ANAME
24790       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24791      &                IICH(210),IIBAR(210),K1(210),K2(210)
24792
24793       DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23)
24794       DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0,
24795      &             0, 0, 3, 4, 0, 0, 0, 0, 0, 0,
24796      &             0, 0, 5/
24797       DATA LINIT /.FALSE./
24798
24799 * precalculation and tabulation of elastic cross sections
24800       IF (ABS(MODE).EQ.1) THEN
24801          IF (MODE.EQ.1)
24802      &      OPEN(LDAT,FILE='outdata0/sigtab.out',STATUS='UNKNOWN')
24803          PLABLX = LOG10(PLO)
24804          PLABHX = LOG10(PHI)
24805          DPLAB  = (PLABHX-PLABLX)/DBLE(NBINS)
24806          DO 1 I=1,NBINS+1
24807             PLAB = PLABLX+DBLE(I-1)*DPLAB
24808             PLAB = 10**PLAB
24809             DO 2 IPROJ=1,23
24810                IDX = IDSIG(IPROJ)
24811                IF (IDX.GT.0) THEN
24812 C                 CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
24813 C                 CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
24814                   DUMZER = ZERO
24815                   CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
24816                   CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
24817                ENDIF
24818     2       CONTINUE
24819             IF (MODE.EQ.1) THEN
24820                WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5),
24821      &                                (SIGEN(IDX,I),IDX=1,5)
24822  1000          FORMAT(F5.1,10F7.2)
24823             ENDIF
24824     1    CONTINUE
24825          IF (MODE.EQ.1) CLOSE(LDAT)
24826          LINIT = .TRUE.
24827       ELSE
24828          SIGE = -ONE
24829          IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
24830      &                           .AND.(PTOT.LE.PHI) ) THEN
24831             IDX = IDSIG(JP)
24832             IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
24833                PLABX = LOG10(PTOT)
24834                IF (PLABX.LE.PLABLX) THEN
24835                   I1 = 1
24836                   I2 = 1
24837                ELSEIF (PLABX.GE.PLABHX) THEN
24838                   I1 = NBINS+1
24839                   I2 = NBINS+1
24840                ELSE
24841                   I1 = INT((PLABX-PLABLX)/DPLAB)+1
24842                   I2 = I1+1
24843                ENDIF
24844                PLAB1X = PLABLX+DBLE(I1-1)*DPLAB
24845                PLAB2X = PLABLX+DBLE(I2-1)*DPLAB
24846                PBIN   = PLAB2X-PLAB1X
24847                IF (PBIN.GT.TINY10) THEN
24848                   RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X)
24849                ELSE
24850                   RATX = ZERO
24851                ENDIF
24852                IF (JT.EQ.1) THEN
24853                   SIG1 = SIGEP(IDX,I1)
24854                   SIG2 = SIGEP(IDX,I2)
24855                ELSE
24856                   SIG1 = SIGEN(IDX,I1)
24857                   SIG2 = SIGEN(IDX,I2)
24858                ENDIF
24859                SIGE = SIG1+RATX*(SIG2-SIG1)
24860             ENDIF
24861          ENDIF
24862       ENDIF
24863
24864       RETURN
24865       END
24866
24867 *$ CREATE DT_XSTABL.FOR
24868 *COPY DT_XSTABL
24869 *
24870 *===xstabl=============================================================*
24871 *
24872       SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
24873
24874       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24875       SAVE
24876       PARAMETER ( LINP = 10 ,
24877      &            LOUT = 6 ,
24878      &            LDAT = 9 )
24879       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24880      &           OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
24881       LOGICAL LLAB,LELOG,LQLOG
24882
24883 * particle properties (BAMJET index convention)
24884       CHARACTER*8  ANAME
24885       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24886      &                IICH(210),IIBAR(210),K1(210),K2(210)
24887 * properties of interacting particles
24888       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
24889       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
24890 * Glauber formalism: cross sections
24891       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
24892      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
24893      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
24894      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
24895      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
24896      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
24897      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
24898      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
24899      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
24900      &                BSLOPE,NEBINI,NQBINI
24901 * emulsion treatment
24902       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
24903      &                NCOMPO,IEMUL
24904
24905       DIMENSION WHAT(6)
24906
24907       LLAB   = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
24908       ELO    = ABS(WHAT(1))
24909       EHI    = ABS(WHAT(2))
24910       IF (ELO.GT.EHI) ELO = EHI
24911       LELOG  = WHAT(3).LT.ZERO
24912       NEBINS = MAX(INT(ABS(WHAT(3))),1)
24913       DEBINS = (EHI-ELO)/DBLE(NEBINS)
24914       IF (LELOG) THEN
24915          AELO   = LOG10(ELO)
24916          AEHI   = LOG10(EHI)
24917          ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
24918       ENDIF
24919       Q2LO   = WHAT(4)
24920       Q2HI   = WHAT(5)
24921       IF (Q2LO.GT.Q2HI) Q2LO = Q2HI
24922       LQLOG  = WHAT(6).LT.ZERO
24923       NQBINS = MAX(INT(ABS(WHAT(6))),1)
24924       DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS)
24925       IF (LQLOG) THEN
24926          AQ2LO  = LOG10(Q2LO)
24927          AQ2HI  = LOG10(Q2HI)
24928          ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
24929       ENDIF
24930
24931       IF ( ELO.EQ. EHI) NEBINS = 0
24932       IF (Q2LO.EQ.Q2HI) NQBINS = 0
24933
24934       WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT
24935  1000 FORMAT(/,1X,'XSTABL:  E_lo  =',E10.3,' GeV  E_hi  =',E10.3,
24936      &       ' GeV     Lab = ',L1,'  qel: ',I2,/,10X,'Q2_lo =',F10.5,
24937      &       ' GeV^2  Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2,
24938      &       '   A_p = ',I3,'   A_t = ',I3,/)
24939
24940 C     IF (IJPROJ.NE.7) THEN
24941          WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)'
24942 * normalize fractions of emulsion components
24943          IF (NCOMPO.GT.0) THEN
24944             SUMFRA = ZERO
24945             DO 10 I=1,NCOMPO
24946                SUMFRA = SUMFRA+EMUFRA(I)
24947    10       CONTINUE
24948             IF (SUMFRA.GT.ZERO) THEN
24949                DO 11 I=1,NCOMPO
24950                   EMUFRA(I) = EMUFRA(I)/SUMFRA
24951    11          CONTINUE
24952             ENDIF
24953          ENDIF
24954 C     ELSE
24955 C        WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
24956 C     ENDIF
24957       DO 1 I=1,NEBINS+1
24958          IF (LELOG) THEN
24959             E = 10**(AELO+DBLE(I-1)*ADEBIN)
24960          ELSE
24961             E = ELO+DBLE(I-1)*DEBINS
24962          ENDIF
24963          DO 2 J=1,NQBINS+1
24964             IF (LQLOG) THEN
24965                Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
24966             ELSE
24967                Q2 = Q2LO+DBLE(J-1)*DQBINS
24968             ENDIF
24969 c            IF (IJPROJ.NE.7) THEN
24970                IF (LLAB) THEN
24971                   PLAB = ZERO
24972                   ECM  = ZERO
24973                   CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
24974                ELSE
24975                   ECM = E
24976                ENDIF
24977                XI  = ZERO
24978                Q2I = ZERO
24979                IF (IJPROJ.EQ.7) Q2I = Q2
24980                IF (NCOMPO.GT.0) THEN
24981                   DO 20 IC=1,NCOMPO
24982                      IIT = IEMUMA(IC)
24983                      CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
24984    20             CONTINUE
24985                ELSE
24986                   CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
24987 C                 CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
24988                ENDIF
24989                IF (NCOMPO.GT.0) THEN
24990                   XTOT = ZERO
24991                   ETOT = ZERO
24992                   XELA = ZERO
24993                   EELA = ZERO
24994                   XQEP = ZERO
24995                   EQEP = ZERO
24996                   XQET = ZERO
24997                   EQET = ZERO
24998                   XQE2 = ZERO
24999                   EQE2 = ZERO
25000                   XPRO = ZERO
25001                   EPRO = ZERO
25002                   XPRO1= ZERO
25003                   XDEL = ZERO
25004                   EDEL = ZERO
25005                   XDQE = ZERO
25006                   EDQE = ZERO
25007                   DO 21 IC=1,NCOMPO
25008                      XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC)
25009                      ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2
25010                      XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC)
25011                      EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2
25012                      XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC)
25013                      EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2
25014                      XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC)
25015                      EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2
25016                      XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC)
25017                      EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2
25018                      XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC)
25019                      EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2
25020                      XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC)
25021                      EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2
25022                      XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC)
25023                      EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2
25024                      YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC)
25025      &                     -XSQEP(1,1,IC)-XSQET(1,1,IC)
25026      &                     -XSQE2(1,1,IC)
25027                      XPRO1= XPRO1+EMUFRA(IC)*YPRO
25028    21             CONTINUE
25029                   ETOT = SQRT(ETOT)
25030                   EELA = SQRT(EELA)
25031                   EQEP = SQRT(EQEP)
25032                   EQET = SQRT(EQET)
25033                   EQE2 = SQRT(EQE2)
25034                   EPRO = SQRT(EPRO)
25035                   EDEL = SQRT(EDEL)
25036                   EDQE = SQRT(EDQE)
25037                   WRITE(LOUT,'(8E9.3)')
25038      &               E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
25039 C                 WRITE(LOUT,'(4E9.3)')
25040 C    &               E,XDEL,XDQE,XDEL+XDQE
25041                ELSE
25042                   WRITE(LOUT,'(11E10.3)')
25043      &              E,
25044      &              XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1),
25045      &              XSQE2(1,1,1),XSPRO(1,1,1),
25046      &              XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1)
25047      &             -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1),
25048      &              XSDEL(1,1,1)+XSDQE(1,1,1)
25049 C                 WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
25050 C    &                                    XSDEL(1,1,1)+XSDQE(1,1,1)
25051                ENDIF
25052 c            ELSE
25053 c               IF (LLAB) THEN
25054 c                  IF (IT.GT.1) THEN
25055 c                     IF (IXSQEL.EQ.0) THEN
25056 cC                       CALL DT_SIGGA(IT,  Q2, E,ZERO,ZERO,
25057 cC                       CALL DT_SIGGA(IT,   E,Q2,ZERO,ZERO,
25058 c                        CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
25059 c     &                             STOT,ETOT,SIN,EIN,STOT0)
25060 c                        IF (IRATIO.EQ.1) THEN
25061 c                           CALL DT_SIGGP(  Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
25062 cC                          CALL DT_SIGGP(   E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
25063 cC                          CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
25064 c*!! save cross sections
25065 c                           STOTA = STOT
25066 c                           ETOTA = ETOT
25067 c                           STOTP = STGP
25068 c*!!
25069 c                           STOT  = STOT/(DBLE(IT)*STGP)
25070 c                           SIN   =  SIN/(DBLE(IT)*SIGP)
25071 c                           STOT0 = STGP
25072 c                           ETOT  = ZERO
25073 c                           EIN   = ZERO
25074 c                        ENDIF
25075 c                     ELSE
25076 c                        WRITE(LOUT,*)
25077 c     &                  ' XSTABL:  qel. xs. not implemented for nuclei'
25078 c                        STOP
25079 c                     ENDIF
25080 c                  ELSE
25081 c                     ETOT = ZERO
25082 c                     EIN  = ZERO
25083 c                     STOT0= ZERO
25084 c                     IF (IXSQEL.EQ.0) THEN
25085 c                        CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
25086 c                     ELSE
25087 c                       SIN = ZERO
25088 c                       CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
25089 c                     ENDIF
25090 c                  ENDIF
25091 c               ELSE
25092 c                  IF (IT.GT.1) THEN
25093 c                     IF (IXSQEL.EQ.0) THEN
25094 c                        CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
25095 c     &                             STOT,ETOT,SIN,EIN,STOT0)
25096 c                        IF (IRATIO.EQ.1) THEN
25097 c                           CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
25098 c*!! save cross sections
25099 c                           STOTA = STOT
25100 c                           ETOTA = ETOT
25101 c                           STOTP = STGP
25102 c*!!
25103 c                           STOT  = STOT/(DBLE(IT)*STGP)
25104 c                           SIN   =  SIN/(DBLE(IT)*SIGP)
25105 c                           STOT0 = STGP
25106 c                           ETOT  = ZERO
25107 c                           EIN   = ZERO
25108 c                        ENDIF
25109 c                     ELSE
25110 c                        WRITE(LOUT,*)
25111 c     &                  ' XSTABL:  qel. xs. not implemented for nuclei'
25112 c                        STOP
25113 c                     ENDIF
25114 c                  ELSE
25115 c                     ETOT = ZERO
25116 c                     EIN  = ZERO
25117 c                     STOT0= ZERO
25118 c                     IF (IXSQEL.EQ.0) THEN
25119 c                        CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
25120 c                     ELSE
25121 c                       SIN = ZERO
25122 c                       CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
25123 c                     ENDIF
25124 c                  ENDIF
25125 c               ENDIF
25126 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
25127 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
25128 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
25129 c               WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
25130 c            ENDIF
25131     2    CONTINUE
25132     1 CONTINUE
25133
25134       RETURN
25135       END
25136
25137 *$ CREATE DT_TESTXS.FOR
25138 *COPY DT_TESTXS
25139 *
25140 *===testxs=============================================================*
25141 *
25142       SUBROUTINE DT_TESTXS
25143
25144       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25145       SAVE
25146
25147       DIMENSION XSTOT(26,2),XSELA(26,2)
25148
25149       OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN')
25150       OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN')
25151       OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN')
25152       OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN')
25153       DUMECM = 0.0D0
25154       PLABL = 0.01D0
25155       PLABH = 10000.0D0
25156       NBINS = 120
25157       APLABL = LOG10(PLABL)
25158       APLABH = LOG10(PLABH)
25159       ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
25160       DO 1 I=1,NBINS+1
25161          ADP = APLABL+DBLE(I-1)*ADPLAB
25162          P = 10.0D0**ADP
25163          DO 2 J=1,26
25164             CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1))
25165             CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2))
25166     2    CONTINUE
25167          WRITE(10,1000) P,(XSTOT(K,1),K=1,26)
25168          WRITE(11,1000) P,(XSELA(K,1),K=1,26)
25169          WRITE(12,1000) P,(XSTOT(K,2),K=1,26)
25170          WRITE(13,1000) P,(XSELA(K,2),K=1,26)
25171     1 CONTINUE
25172  1000 FORMAT(F8.3,26F9.3)
25173
25174       RETURN
25175       END
25176
25177 ************************************************************************
25178 *                                                                      *
25179 *  DTUNUC 2.0:   library routines                                      *
25180 *                                   processed by S. Roesler, 6.5.95    *
25181 *                                                                      *
25182 ************************************************************************
25183 *
25184 *     1) Handling of parton momenta
25185 *          SUBROUTINE MASHEL
25186 *          SUBROUTINE DFERMI
25187 *
25188 *     2) Handling of parton flavors and particle indices
25189 *          INTEGER FUNCTION IPDG2B
25190 *          INTEGER FUNCTION IB2PDG
25191 *          INTEGER FUNCTION IQUARK
25192 *          INTEGER FUNCTION IBJQUA
25193 *          INTEGER FUNCTION ICIHAD
25194 *          INTEGER FUNCTION IPDGHA
25195 *          INTEGER FUNCTION MCHAD
25196 *          SUBROUTINE FLAHAD
25197 *
25198 *     3) Energy-momentum and quantum number conservation check routines
25199 *          SUBROUTINE EMC1
25200 *          SUBROUTINE EMC2
25201 *          SUBROUTINE EVTEMC
25202 *          SUBROUTINE EVTFLC
25203 *          SUBROUTINE EVTCHG
25204 *
25205 *     4) Transformations
25206 *          SUBROUTINE LTINI
25207 *          SUBROUTINE LTRANS
25208 *          SUBROUTINE LTNUC
25209 *          SUBROUTINE DALTRA
25210 *          SUBROUTINE DTRAFO
25211 *          SUBROUTINE STTRAN
25212 *          SUBROUTINE MYTRAN
25213 *          SUBROUTINE LT2LAO
25214 *          SUBROUTINE LT2LAB
25215 *
25216 *     5) Sampling from distributions
25217 *          INTEGER FUNCTION NPOISS
25218 *          DOUBLE PRECISION FUNCTION SAMPXB
25219 *          DOUBLE PRECISION FUNCTION SAMPEX
25220 *          DOUBLE PRECISION FUNCTION SAMSQX
25221 *          DOUBLE PRECISION FUNCTION BETREJ
25222 *          DOUBLE PRECISION FUNCTION DGAMRN
25223 *          DOUBLE PRECISION FUNCTION DBETAR
25224 *          SUBROUTINE RANNOR
25225 *          SUBROUTINE DPOLI
25226 *          SUBROUTINE DSFECF
25227 *          SUBROUTINE RACO
25228 *
25229 *     6) Special functions, algorithms and service routines
25230 *          DOUBLE PRECISION FUNCTION YLAMB
25231 *          SUBROUTINE SORT
25232 *          SUBROUTINE SORT1
25233 *          SUBROUTINE DT_XTIME
25234 *
25235 *     7) Random number generator package
25236 *          DOUBLE PRECISION FUNCTION DT_RNDM
25237 *          SUBROUTINE DT_RNDMST
25238 *          SUBROUTINE DT_RNDMIN
25239 *          SUBROUTINE DT_RNDMOU
25240 *          SUBROUTINE DT_RNDMTE
25241 *
25242 ************************************************************************
25243 *                                                                      *
25244 *                 1) Handling of parton momenta                        *
25245 *                                                                      *
25246 ************************************************************************
25247 *$ CREATE DT_MASHEL.FOR
25248 *COPY DT_MASHEL
25249 *
25250 *===mashel=============================================================*
25251 *
25252       SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
25253
25254 ************************************************************************
25255 *                                                                      *
25256 *    rescaling of momenta of two partons to put both                   *
25257 *                                       on mass shell                  *
25258 *                                                                      *
25259 *    input:       PA1,PA2   input momentum vectors                     *
25260 *                 XM1,2     desired masses of particles afterwards     *
25261 *                 P1,P2     changed momentum vectors                   *
25262 *                                                                      *
25263 * The original version is written by R. Engel.                         *
25264 * This version dated 12.12.94 is modified by S. Roesler.               *
25265 ************************************************************************
25266
25267       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25268       SAVE
25269       PARAMETER ( LINP = 10 ,
25270      &            LOUT = 6 ,
25271      &            LDAT = 9 )
25272       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
25273
25274       DIMENSION PA1(4),PA2(4),P1(4),P2(4)
25275
25276       IREJ = 0
25277
25278 * Lorentz transformation into system CMS
25279       PX  = PA1(1)+PA2(1)
25280       PY  = PA1(2)+PA2(2)
25281       PZ  = PA1(3)+PA2(3)
25282       EE  = PA1(4)+PA2(4)
25283       XPTOT = SQRT(PX**2+PY**2+PZ**2)
25284       XMS   = (EE-XPTOT)*(EE+XPTOT)
25285       IF(XMS.LT.(XM1+XM2)**2) THEN
25286 C        WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
25287          GOTO 9999
25288       ENDIF
25289       XMS = SQRT(XMS)
25290       BGX = PX/XMS
25291       BGY = PY/XMS
25292       BGZ = PZ/XMS
25293       GAM = EE/XMS
25294       CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
25295      &           PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
25296 * rotation angles
25297       COD = P1(3)/PTOT1
25298 C     SID = SQRT((ONE-COD)*(ONE+COD))
25299       PPT = SQRT(P1(1)**2+P1(2)**2)
25300       SID = PPT/PTOT1
25301       COF = ONE
25302       SIF = ZERO
25303       IF(PTOT1*SID.GT.TINY10) THEN
25304          COF   = P1(1)/(SID*PTOT1)
25305          SIF   = P1(2)/(SID*PTOT1)
25306          ANORF = SQRT(COF*COF+SIF*SIF)
25307          COF   = COF/ANORF
25308          SIF   = SIF/ANORF
25309       ENDIF
25310 * new CM momentum and energies (for masses XM1,XM2)
25311       XM12 = SIGN(XM1**2,XM1)
25312       XM22 = SIGN(XM2**2,XM2)
25313       SS   = XMS**2
25314       PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
25315       EE1  = SQRT(XM12+PCMP**2)
25316       EE2  = XMS-EE1
25317 * back rotation
25318       MODE = 1
25319       CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
25320       CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
25321      &            PTOT1,P1(1),P1(2),P1(3),P1(4))
25322       CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
25323      &            PTOT2,P2(1),P2(2),P2(3),P2(4))
25324 * check consistency
25325       DEL = XMS*0.0001D0
25326       IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
25327         IDEV = 1
25328       ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
25329         IDEV = 2
25330       ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
25331         IDEV = 3
25332       ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
25333         IDEV = 4
25334       ELSE
25335         IDEV = 0
25336       ENDIF
25337       IF (IDEV.NE.0) THEN
25338          WRITE(LOUT,'(/1X,A,I3)')
25339      &      'MASHEL: inconsistent transformation',IDEV
25340          WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:'
25341          WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1
25342          WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2
25343          WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:'
25344          WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4)
25345          WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4)
25346       ENDIF
25347       RETURN
25348
25349  9999 CONTINUE
25350       IREJ = 1
25351       RETURN
25352       END
25353
25354 *$ CREATE DT_DFERMI.FOR
25355 *COPY DT_DFERMI
25356 *
25357 *===dfermi=============================================================*
25358 *
25359       SUBROUTINE DT_DFERMI(GPART)
25360
25361 ************************************************************************
25362 * Find largest of three random numbers.                                *
25363 ************************************************************************
25364
25365       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25366       SAVE
25367
25368       DIMENSION G(3)
25369
25370       DO 10 I=1,3
25371         G(I)=DT_RNDM(GPART)
25372    10 CONTINUE
25373       IF (G(3).LT.G(2)) GOTO 40
25374       IF (G(3).LT.G(1)) GOTO 30
25375       GPART = G(3)
25376    20 RETURN
25377    30 GPART = G(1)
25378       GOTO 20
25379    40 IF (G(2).LT.G(1)) GOTO 30
25380       GPART = G(2)
25381       GOTO 20
25382
25383       END
25384
25385 ************************************************************************
25386 *                                                                      *
25387 *         2) Handling of parton flavors and particle indices           *
25388 *                                                                      *
25389 ************************************************************************
25390 *$ CREATE IDT_IPDG2B.FOR
25391 *COPY IDT_IPDG2B
25392 *
25393 *===ipdg2b=============================================================*
25394 *
25395       INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
25396
25397 ************************************************************************
25398 *                                                                      *
25399 *     conversion of quark numbering scheme                             *
25400 *                                                                      *
25401 *     input:   PDG parton numbering                                    *
25402 *              for diquarks:  NN number of the constituent quark       *
25403 *                             (e.g. ID=2301,NN=1 -> ICONV2=1)          *
25404 *                                                                      *
25405 *     output:  BAMJET particle codes                                   *
25406 *              1 u     7 a-u   (MODE=1)  -1 a-u   (MODE=2)             *
25407 *              2 d     8 a-d             -2 a-d                        *
25408 *              3 s     9 a-s             -3 a-s                        *
25409 *              4 c    10 a-c             -4 a-c                        *
25410 *                                                                      *
25411 * This is a modified version of ICONV2 written by R. Engel.            *
25412 * This version dated 13.12.94 is written by S. Roesler.                *
25413 ************************************************************************
25414
25415       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25416       SAVE
25417       PARAMETER ( LINP = 10 ,
25418      &            LOUT = 6 ,
25419      &            LDAT = 9 )
25420
25421       IDA = ABS(ID)
25422 * diquarks
25423       IF (IDA.GT.6) THEN
25424         KF  = 3
25425         IF (IDA.GE.1000) KF = 4
25426         IDA = IDA/(10**(KF-NN))
25427         IDA = MOD(IDA,10)
25428       ENDIF
25429 * exchange up and dn quarks
25430       IF (IDA.EQ.1) THEN
25431         IDA = 2
25432       ELSEIF (IDA.EQ.2) THEN
25433         IDA = 1
25434       ENDIF
25435 * antiquarks
25436       IF (ID.LT.0) THEN
25437          IF (MODE.EQ.1) THEN
25438             IDA = IDA+6
25439          ELSE
25440             IDA = -IDA
25441          ENDIF
25442       ENDIF
25443       IDT_IPDG2B = IDA
25444
25445       RETURN
25446       END
25447
25448 *$ CREATE IDT_IB2PDG.FOR
25449 *COPY IDT_IB2PDG
25450 *
25451 *===ib2pdg=============================================================*
25452 *
25453       INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
25454
25455 ************************************************************************
25456 *                                                                      *
25457 *     conversion of quark numbering scheme                             *
25458 *                                                                      *
25459 *     input:   BAMJET particle codes                                   *
25460 *              1 u     7 a-u   (MODE=1)  -1 a-u   (MODE=2)             *
25461 *              2 d     8 a-d             -2 a-d                        *
25462 *              3 s     9 a-s             -3 a-s                        *
25463 *              4 c    10 a-c             -4 a-c                        *
25464 *                                                                      *
25465 *     output:  PDG parton numbering                                    *
25466 *                                                                      *
25467 * This version dated 13.12.94 is written by S. Roesler.                *
25468 ************************************************************************
25469
25470       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25471       SAVE
25472       PARAMETER ( LINP = 10 ,
25473      &            LOUT = 6 ,
25474      &            LDAT = 9 )
25475
25476       DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
25477       DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
25478       DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
25479      &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
25480      &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
25481
25482       IDA = ID1
25483       IDB = ID2
25484       IF (MODE.EQ.1) THEN
25485          IF (ID1.GT.6) IDA = -(ID1-6)
25486          IF (ID2.GT.6) IDB = -(ID2-6)
25487       ENDIF
25488       IF (ID2.EQ.0) THEN
25489          IDT_IB2PDG = IHKKQ(IDA)
25490       ELSE
25491          IDT_IB2PDG = IHKKQQ(IDA,IDB)
25492       ENDIF
25493
25494       RETURN
25495       END
25496
25497 *$ CREATE IDT_IQUARK.FOR
25498 *COPY IDT_IQUARK
25499 *
25500 *===ipdgqu=============================================================*
25501 *
25502       INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
25503
25504 ************************************************************************
25505 *                                                                      *
25506 *     quark contents according to PDG conventions                      *
25507 *     (random selection in case of quark mixing)                       *
25508 *                                                                      *
25509 *     input:   IDBAMJ BAMJET particle code                             *
25510 *              K      1..3   quark number                              *
25511 *                                                                      *
25512 *     output:  1   d  (anti --> neg.)                                  *
25513 *              2   u                                                   *
25514 *              3   s                                                   *
25515 *              4   c                                                   *
25516 *                                                                      *
25517 * This version written by R. Engel.                                    *
25518 ************************************************************************
25519
25520       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25521       SAVE
25522
25523       IQ = IDT_IBJQUA(K,IDBAMJ)
25524 * quark-antiquark
25525       IF (IQ.GT.6) THEN
25526          IQ = 6-IQ
25527       ENDIF
25528 * exchange of up and down
25529       IF (ABS(IQ).EQ.1) THEN
25530          IQ = SIGN(2,IQ)
25531       ELSEIF (ABS(IQ).EQ.2) THEN
25532          IQ = SIGN(1,IQ)
25533       ENDIF
25534       IDT_IQUARK = IQ
25535
25536       RETURN
25537       END
25538
25539 *$ CREATE IDT_IBJQUA.FOR
25540 *COPY IDT_IBJQUA
25541 *
25542 *===ibamq==============================================================*
25543 *
25544       INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
25545
25546 ************************************************************************
25547 *                                                                      *
25548 *     quark contents according to BAMJET conventions                   *
25549 *     (random selection in case of quark mixing)                       *
25550 *                                                                      *
25551 *     input:   IDBAMJ BAMJET particle code                             *
25552 *              K      1..3   quark number                              *
25553 *                                                                      *
25554 *     output:  1   u      7   u bar                                    *
25555 *              2   d      8   d bar                                    *
25556 *              3   s      9   s bar                                    *
25557 *              4   c     10   c bar                                    *
25558 *                                                                      *
25559 * This version written by R. Engel.                                    *
25560 ************************************************************************
25561
25562       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25563       SAVE
25564
25565       DIMENSION ITAB(3,210)
25566       DATA ((ITAB(I,K),I=1,3),K=1,30) /
25567      &    1,  1,  2,   7,  7,  8,   0,  0,  0,
25568      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25569      &    0,  0,  0,   1,  2,  2,   7,  8,  8,
25570 *sr 10.1.94
25571 C    &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25572      &    0,  0,  0,   0,  0,  0,   3,  8,  0,
25573 *
25574      &    1,  8,  0,   2,  7,  0,   1,  9,  0,
25575 *sr 10.1.94
25576 C    &    3,  7,  0,   0,  0,  0,   0,  0,  0,
25577      &    3,  7,  0,   3,  1,  2,   9,  7,  8,
25578 *sr 10.1.94
25579 C    &    0,  0,  0,   2,  2,  3,   1,  1,  3,
25580      &    2,  9,  0,   2,  2,  3,   1,  1,  3,
25581 *
25582      &    1,  2,  3, 201,202,  0,   2,  9,  0,
25583      &    3,  8,  0,   0,  0,  0,   0,  0,  0,
25584      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25585       DATA ((ITAB(I,K),I=1,3),K=31,60) /
25586      &    3,  9,  0,   1,  8,  0, 203,204,  0,
25587      &    2,  7,  0,   0,  0,  0,   1,  9,  0,
25588      &    2,  9,  0,   3,  7,  0,   3,  8,  0,
25589      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25590      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25591      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25592      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25593      &    0,  0,  0,   1,  1,  1,   1,  1,  2,
25594      &    1,  2,  2,   2,  2,  2,   0,  0,  0,
25595      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25596       DATA ((ITAB(I,K),I=1,3),K=61,90) /
25597      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25598      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25599      &    7,  7,  7,   7,  7,  8,   7,  8,  8,
25600      &    8,  8,  8,   0,  0,  0,   0,  0,  0,
25601      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25602      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25603      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25604      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25605      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25606      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25607       DATA ((ITAB(I,K),I=1,3),K=91,120) /
25608      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25609      &    0,  0,  0,   0,  0,  0,   3,  9,  0,
25610      &    1,  3,  3,   2,  3,  3,   7,  7,  9,
25611      &    7,  8,  9,   8,  8,  9,   7,  9,  9,
25612      &    8,  9,  9,   1,  1,  3,   1,  2,  3,
25613      &    2,  2,  3,   1,  3,  3,   2,  3,  3,
25614      &    3,  3,  3,   7,  7,  9,   7,  8,  9,
25615      &    8,  8,  9,   7,  9,  9,   8,  9,  9,
25616      &    9,  9,  9,   4,  7,  0,   4,  8,  0,
25617      &    2, 10,  0,   1, 10,  0,   4,  9,  0 /
25618       DATA ((ITAB(I,K),I=1,3),K=121,150) /
25619      &    3, 10,  0,   4, 10,  0,   4,  7,  0,
25620      &    4,  8,  0,   2, 10,  0,   1, 10,  0,
25621      &    4,  9,  0,   3, 10,  0,   4, 10,  0,
25622      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25623      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25624      &    0,  0,  0,   1,  2,  4,   1,  3,  4,
25625      &    2,  3,  4,   1,  1,  4,   0,  0,  0,
25626      &    2,  2,  4,   0,  0,  0,   0,  0,  0,
25627      &    3,  3,  4,   1,  4,  4,   2,  4,  4,
25628      &    3,  4,  4,   7,  8, 10,   7,  9, 10 /
25629       DATA ((ITAB(I,K),I=1,3),K=151,180) /
25630      &    8,  9, 10,   7,  7, 10,   0,  0,  0,
25631      &    8,  8, 10,   0,  0,  0,   0,  0,  0,
25632      &    9,  9, 10,   7, 10, 10,   8, 10, 10,
25633      &    9, 10, 10,   1,  1,  4,   1,  2,  4,
25634      &    2,  2,  4,   1,  3,  4,   2,  3,  4,
25635      &    3,  3,  4,   1,  4,  4,   2,  4,  4,
25636      &    3,  4,  4,   4,  4,  4,   7,  7, 10,
25637      &    7,  8, 10,   8,  8, 10,   7,  9, 10,
25638      &    8,  9, 10,   9,  9, 10,   7, 10, 10,
25639      &    8, 10, 10,   9, 10, 10,  10, 10, 10 /
25640       DATA ((ITAB(I,K),I=1,3),K=181,210) /
25641      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25642      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25643      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25644      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25645      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25646      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25647      &    0,  0,  0,   0,  0,  0,   1,  7,  0,
25648      &    2,  8,  0,   1,  7,  0,   2,  8,  0,
25649      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25650      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25651       DATA IDOLD /0/
25652
25653       ONE = 1.0D0
25654       IF (ITAB(1,IDBAMJ).LE.200) THEN
25655          ID = ITAB(K,IDBAMJ)
25656       ELSE
25657          IF(IDOLD.NE.IDBAMJ) THEN
25658             IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
25659      &           DT_RNDM(ONE)+ITAB(1,IDBAMJ))
25660         ELSE
25661            IDOLD = 0
25662         ENDIF
25663         ID = ITAB(K,IT)
25664       ENDIF
25665       IDOLD  = IDBAMJ
25666       IDT_IBJQUA = ID
25667
25668       RETURN
25669       END
25670
25671 *$ CREATE IDT_ICIHAD.FOR
25672 *COPY IDT_ICIHAD
25673 *
25674 *===icihad=============================================================*
25675 *
25676       INTEGER FUNCTION IDT_ICIHAD(MCIND)
25677
25678 ************************************************************************
25679 * Conversion of particle index PDG proposal --> BAMJET-index scheme    *
25680 * This is a completely new version dated 25.10.95.                     *
25681 * Renamed to be not in conflict with the modified PHOJET-version       *
25682 ************************************************************************
25683
25684       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25685       SAVE
25686
25687 * hadron index conversion (BAMJET <--> PDG)
25688       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25689      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25690      &                IAMCIN(210)
25691
25692       IDT_ICIHAD = 0
25693       KPDG   = ABS(MCIND)
25694       IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
25695       IF (MCIND.LT.0) THEN
25696          JSIGN = 1
25697       ELSE
25698          JSIGN = 2
25699       ENDIF
25700       IF (KPDG.GE.10000) THEN
25701          DO 1 I=1,19
25702             IDT_ICIHAD = IBAM5(JSIGN,I)
25703             IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
25704             IDT_ICIHAD = 0
25705     1    CONTINUE
25706       ELSEIF (KPDG.GE.1000) THEN
25707          DO 2 I=1,29
25708             IDT_ICIHAD = IBAM4(JSIGN,I)
25709             IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
25710             IDT_ICIHAD = 0
25711     2    CONTINUE
25712       ELSEIF (KPDG.GE.100) THEN
25713          DO 3 I=1,22
25714             IDT_ICIHAD = IBAM3(JSIGN,I)
25715             IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
25716             IDT_ICIHAD = 0
25717     3    CONTINUE
25718       ELSEIF (KPDG.GE.10) THEN
25719          DO 4 I=1,7
25720             IDT_ICIHAD = IBAM2(JSIGN,I)
25721             IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
25722             IDT_ICIHAD = 0
25723     4    CONTINUE
25724       ENDIF
25725     5 CONTINUE
25726
25727       RETURN
25728       END
25729
25730 *$ CREATE IDT_IPDGHA.FOR
25731 *COPY IDT_IPDGHA
25732 *
25733 *===ipdgha=============================================================*
25734 *
25735       INTEGER FUNCTION IDT_IPDGHA(MCIND)
25736
25737 ************************************************************************
25738 * Conversion of particle index BAMJET-index scheme --> PDG proposal    *
25739 * Adopted from the original by S. Roesler. This version dated 12.5.95  *
25740 * Renamed to be not in conflict with the modified PHOJET-version       *
25741 ************************************************************************
25742
25743       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25744       SAVE
25745
25746 * hadron index conversion (BAMJET <--> PDG)
25747       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25748      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25749      &                IAMCIN(210)
25750
25751       IDT_IPDGHA = IAMCIN(MCIND)
25752
25753       RETURN
25754       END
25755
25756 *$ CREATE DT_FLAHAD.FOR
25757 *COPY DT_FLAHAD
25758 *
25759 *===flahad=============================================================*
25760 *
25761       SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
25762
25763 ************************************************************************
25764 * sampling of FLAvor composition for HADrons/photons                   *
25765 *              ID         BAMJET-id of hadron                          *
25766 *              IF1,2,3    flavor content                               *
25767 *                         (u,d,s: 1,2,3;  au,ad,as: -1,-1,-3)          *
25768 * Note:  -  u,d numbering as in BAMJET                                 *
25769 *        -  ID .le. 30 !!                                              *
25770 * This version dated 12.03.96 is written by S. Roesler                 *
25771 ************************************************************************
25772
25773       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25774       SAVE
25775
25776 * auxiliary common for reggeon exchange (DTUNUC 1.x)
25777       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
25778      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
25779      &                IQTCHR(-6:6),MQUARK(3,39)
25780
25781       DIMENSION JSEL(3,6)
25782       DATA JSEL/ 1,2,3,  2,3,1,  3,1,2,  1,3,2,   2,1,3,   3,2,1/
25783
25784       ONE = 1.0D0
25785       IF (ID.EQ.7) THEN
25786 * photon (charge dependent flavour sampling)
25787          K = INT(DT_RNDM(ONE)*6.D0+1.D0)
25788          IF (K.LE.4) THEN
25789             IF1 = 2
25790             IF2 = -2
25791          ELSE IF(K.EQ.5) THEN
25792             IF1 = 1
25793             IF2 = -1
25794          ELSE
25795             IF1 = 3
25796             IF2 = -3
25797          ENDIF
25798          IF(DT_RNDM(ONE).LT.0.5D0) THEN
25799             K   = IF1
25800             IF1 = IF2
25801             IF2 = K
25802          ENDIF
25803          IF3 = 0
25804       ELSE
25805 * hadron
25806          IX  = INT(1.0D0+5.99999D0*DT_RNDM(ONE))
25807          IF1 = MQUARK(JSEL(1,IX),ID)
25808          IF2 = MQUARK(JSEL(2,IX),ID)
25809          IF3 = MQUARK(JSEL(3,IX),ID)
25810          IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN
25811             IF1 = IF3
25812             IF3 = 0
25813          ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
25814             IF2 = IF3
25815             IF3 = 0
25816          ENDIF
25817       ENDIF
25818
25819       RETURN
25820       END
25821
25822 *$ CREATE IDT_MCHAD.FOR
25823 *COPY IDT_MCHAD
25824 *
25825 *===mchad==============================================================*
25826 *
25827       INTEGER FUNCTION IDT_MCHAD(ITDTU)
25828
25829 ************************************************************************
25830 * Conversion of particle index BAMJET-index scheme --> HADRIN index s. *
25831 * Adopted from the original by S. Roesler. This version dated 6.5.95   *
25832 *                                                                      *
25833 * Last change 28.12.2006 by S. Roesler.                                *
25834 ************************************************************************
25835
25836       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25837       SAVE
25838
25839       DIMENSION ITRANS(210)
25840       DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14,
25841      &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13,
25842      &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8,
25843      &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2,
25844      &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1,
25845      &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9,
25846      &9, 9, 9, 85*- 1,7*-1,1,8,-1/
25847
25848       IF ( ITDTU .GT. 0 ) THEN
25849          IDT_MCHAD = ITRANS(ITDTU)
25850       ELSE
25851          IDT_MCHAD = -1
25852       END IF
25853
25854       RETURN
25855       END
25856
25857 ************************************************************************
25858 *                                                                      *
25859 *   3) Energy-momentum and quantum number conservation check routines  *
25860 *                                                                      *
25861 ************************************************************************
25862 *$ CREATE DT_EMC1.FOR
25863 *COPY DT_EMC1
25864 *
25865 *===emc1===============================================================*
25866 *
25867       SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
25868
25869 ************************************************************************
25870 * This version dated 15.12.94 is written by S. Roesler                 *
25871 ************************************************************************
25872
25873       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25874       SAVE
25875       PARAMETER ( LINP = 10 ,
25876      &            LOUT = 6 ,
25877      &            LDAT = 9 )
25878       PARAMETER (TINY10=1.0D-10)
25879
25880       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
25881
25882       IREJ = 0
25883
25884       IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
25885      &   WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
25886
25887       IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN
25888          IF (MODE.EQ.1) THEN
25889             CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM)
25890          ELSEIF (MODE.EQ.2) THEN
25891             CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM)
25892          ENDIF
25893          CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM)
25894          CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM)
25895          CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM)
25896       ELSEIF (MODE.LT.0) THEN
25897          IF (MODE.EQ.-1) THEN
25898             CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM)
25899          ELSEIF (MODE.EQ.-2) THEN
25900             CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM)
25901          ENDIF
25902          CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM)
25903          CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM)
25904          CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM)
25905       ENDIF
25906
25907       IF (ABS(MODE).EQ.3) THEN
25908          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1)
25909          IF (IREJ1.NE.0) GOTO 9999
25910       ENDIF
25911       RETURN
25912
25913  9999 CONTINUE
25914       IREJ = 1
25915       RETURN
25916       END
25917
25918 *$ CREATE DT_EMC2.FOR
25919 *COPY DT_EMC2
25920 *
25921 *===emc2===============================================================*
25922 *
25923       SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
25924      &                                                MODE,IPOS,IREJ)
25925
25926 ************************************************************************
25927 *             MODE = 1   energy-momentum cons. check                   *
25928 *                  = 2   flavor-cons. check                            *
25929 *                  = 3   energy-momentum & flavor cons. check          *
25930 *                  = 4   energy-momentum & charge cons. check          *
25931 *                  = 5   energy-momentum & flavor & charge cons. check *
25932 * This version dated 16.01.95 is written by S. Roesler                 *
25933 ************************************************************************
25934
25935       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25936       SAVE
25937       PARAMETER ( LINP = 10 ,
25938      &            LOUT = 6 ,
25939      &            LDAT = 9 )
25940       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
25941
25942 * event history
25943       PARAMETER (NMXHKK=200000)
25944       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25945      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25946      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25947 * extended event history
25948       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25949      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25950      &                IHIST(2,NMXHKK)
25951
25952       IREJ  = 0
25953       IREJ1 = 0
25954       IREJ2 = 0
25955       IREJ3 = 0
25956
25957       IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25958      &                CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM)
25959       IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25960      &                                CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM)
25961       IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM)
25962       DO 1 I=1,NHKK
25963          IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR.
25964      &       (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR.
25965      &       (ISTHKK(I).EQ.IP5))                          THEN
25966             IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25967      &                                    .OR.(MODE.EQ.5))
25968      &      CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
25969      &                                               2,IDUM,IDUM)
25970             IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25971      &         CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM)
25972             IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25973      &                            CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM)
25974          ENDIF
25975          IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR.
25976      &       (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR.
25977      &       (ISTHKK(I).EQ.IN5))                          THEN
25978             IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25979      &                                    .OR.(MODE.EQ.5))
25980      &      CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
25981      &                                                   2,IDUM,IDUM)
25982             IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25983      &         CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM)
25984             IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25985      &                            CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM)
25986          ENDIF
25987     1 CONTINUE
25988       IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25989      &   CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1)
25990       IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25991      &   CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2)
25992       IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3)
25993       IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999
25994
25995       RETURN
25996
25997  9999 CONTINUE
25998       IREJ = 1
25999       RETURN
26000       END
26001
26002 *$ CREATE DT_EVTEMC.FOR
26003 *COPY DT_EVTEMC
26004 *
26005 *===evtemc=============================================================*
26006 *
26007       SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
26008
26009 ************************************************************************
26010 * This version dated 13.12.94 is written by S. Roesler                 *
26011 ************************************************************************
26012
26013       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26014       SAVE
26015       PARAMETER ( LINP = 10 ,
26016      &            LOUT = 6 ,
26017      &            LDAT = 9 )
26018       PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10,
26019      &           ZERO=0.0D0)
26020
26021 * event history
26022       PARAMETER (NMXHKK=200000)
26023       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26024      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26025      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26026 * flags for input different options
26027       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
26028       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
26029      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
26030
26031       IREJ = 0
26032
26033       MODE = IMODE
26034       CHKLEV = TINY10
26035       IF (MODE.EQ.4) THEN
26036          CHKLEV = TINY2
26037          MODE   = 3
26038       ELSEIF (MODE.EQ.5) THEN
26039          CHKLEV = TINY1
26040          MODE   = 3
26041       ELSEIF (MODE.EQ.-1) THEN
26042          CHKLEV = EIO
26043          MODE   = 3
26044       ENDIF
26045
26046       IF (ABS(MODE).EQ.3) THEN
26047          PXDEV = PX
26048          PYDEV = PY
26049          PZDEV = PZ
26050          EDEV  = E
26051          IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4
26052          IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR.
26053      &       (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN
26054             IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)')
26055      &         'EVTEMC: energy-momentum cons. failure at pos. ',IPOS,
26056      &         '  event  ',NEVHKK,
26057      &         ' ! ',PXDEV,PYDEV,PZDEV,EDEV
26058             PX   = 0.0D0
26059             PY   = 0.0D0
26060             PZ   = 0.0D0
26061             E    = 0.0D0
26062             GOTO 9999
26063          ENDIF
26064          PX   = 0.0D0
26065          PY   = 0.0D0
26066          PZ   = 0.0D0
26067          E    = 0.0D0
26068          RETURN
26069       ENDIF
26070
26071       IF (MODE.EQ.1) THEN
26072          PX = 0.0D0
26073          PY = 0.0D0
26074          PZ = 0.0D0
26075          E  = 0.0D0
26076       ENDIF
26077
26078       PX = PX+PXIO
26079       PY = PY+PYIO
26080       PZ = PZ+PZIO
26081       E  = E+EIO
26082
26083       RETURN
26084
26085  9999 CONTINUE
26086       IREJ = 1
26087       RETURN
26088       END
26089
26090 *$ CREATE DT_EVTFLC.FOR
26091 *COPY DT_EVTFLC
26092 *
26093 *===evtflc=============================================================*
26094 *
26095       SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
26096
26097 ************************************************************************
26098 * Flavor conservation check.                                           *
26099 *        ID       identity of particle                                 *
26100 *        ID1 = 1  ID for q,aq,qq,aqaq in PDG-numbering scheme          *
26101 *            = 2  ID for particle/resonance in BAMJET numbering scheme *
26102 *            = 3  ID for particle/resonance in PDG    numbering scheme *
26103 *        MODE = 1 initialization and add ID                            *
26104 *             =-1 initialization and subtract ID                       *
26105 *             = 2 add ID                                               *
26106 *             =-2 subtract ID                                          *
26107 *             = 3 check flavor cons.                                   *
26108 *        IPOS     flag to give position of call of EVTFLC to output    *
26109 *                 unit in case of violation                            *
26110 * This version dated 10.01.95 is written by S. Roesler                 *
26111 ************************************************************************
26112
26113       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26114       SAVE
26115       PARAMETER ( LINP = 10 ,
26116      &            LOUT = 6 ,
26117      &            LDAT = 9 )
26118       PARAMETER (TINY10=1.0D-10)
26119
26120       IREJ = 0
26121
26122       IF (MODE.EQ.3) THEN
26123          IF (IFL.NE.0) THEN
26124             WRITE(LOUT,'(1X,A,I3,A,I3)')
26125      &         'EVTFLC: flavor-conservation failure at pos. ',IPOS,
26126      &         ' !  IFL = ',IFL
26127             IFL = 0
26128             GOTO 9999
26129          ENDIF
26130          IFL = 0
26131          RETURN
26132       ENDIF
26133
26134       IF (MODE.EQ.1) IFL = 0
26135       IF (ID.EQ.0)   RETURN
26136
26137       IF (ID1.EQ.1) THEN
26138          IDD = ABS(ID)
26139          NQ  = 1
26140          IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
26141          IF (IDD.GE.1000) NQ = 3
26142          DO 1 I=1,NQ
26143             IFBAM = IDT_IPDG2B(ID,I,2)
26144             IF (ABS(IFBAM).EQ.1) THEN
26145                IFBAM = SIGN(2,IFBAM)
26146             ELSEIF (ABS(IFBAM).EQ.2) THEN
26147                IFBAM = SIGN(1,IFBAM)
26148             ENDIF
26149             IF (MODE.GT.0) THEN
26150                IFL = IFL+IFBAM
26151             ELSE
26152                IFL = IFL-IFBAM
26153             ENDIF
26154     1    CONTINUE
26155          RETURN
26156       ENDIF
26157
26158       IDD = ID
26159       IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
26160       IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
26161          DO 2 I=1,3
26162             IF (MODE.GT.0) THEN
26163                IFL = IFL+IDT_IQUARK(I,IDD)
26164             ELSE
26165                IFL = IFL-IDT_IQUARK(I,IDD)
26166             ENDIF
26167     2    CONTINUE
26168       ENDIF
26169       RETURN
26170
26171  9999 CONTINUE
26172       IREJ = 1
26173       RETURN
26174       END
26175
26176 *$ CREATE DT_EVTCHG.FOR
26177 *COPY DT_EVTCHG
26178 *
26179 *===evtchg=============================================================*
26180 *
26181       SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
26182
26183 ************************************************************************
26184 * Charge conservation check.                                           *
26185 *        ID       identity of particle (PDG-numbering scheme)          *
26186 *        MODE = 1 initialization                                       *
26187 *             =-2 subtract ID-charge                                   *
26188 *             = 2 add ID-charge                                        *
26189 *             = 3 check charge cons.                                   *
26190 *        IPOS     flag to give position of call of EVTCHG to output    *
26191 *                 unit in case of violation                            *
26192 * This version dated 10.01.95 is written by S. Roesler                 *
26193 * Last change: s.r. 21.01.01                                           *
26194 ************************************************************************
26195
26196       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26197       SAVE
26198       PARAMETER ( LINP = 10 ,
26199      &            LOUT = 6 ,
26200      &            LDAT = 9 )
26201
26202 * event history
26203       PARAMETER (NMXHKK=200000)
26204       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26205      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26206      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26207 * particle properties (BAMJET index convention)
26208       CHARACTER*8  ANAME
26209       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26210      &                IICH(210),IIBAR(210),K1(210),K2(210)
26211
26212       IREJ = 0
26213
26214       IF (MODE.EQ.1) THEN
26215          ICH  = 0
26216          IBAR = 0
26217          RETURN
26218       ENDIF
26219
26220       IF (MODE.EQ.3) THEN
26221          IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN
26222             WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)')
26223      &         'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS,
26224      &         '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK
26225             ICH  = 0
26226             IBAR = 0
26227             GOTO 9999
26228          ENDIF
26229          ICH  = 0
26230          IBAR = 0
26231          RETURN
26232       ENDIF
26233
26234       IF (ID.EQ.0)   RETURN
26235
26236       IDD = IDT_ICIHAD(ID)
26237 * modification 21.1.01: use intrinsic phojet-functions to determine charge
26238 * and baryon number
26239 C     IF (IDD.GT.0) THEN
26240 C        IF (MODE.EQ.2) THEN
26241 C           ICH  = ICH+IICH(IDD)
26242 C           IBAR = IBAR+IIBAR(IDD)
26243 C        ELSEIF (MODE.EQ.-2) THEN
26244 C           ICH  = ICH-IICH(IDD)
26245 C           IBAR = IBAR-IIBAR(IDD)
26246 C        ENDIF
26247 C     ELSE
26248 C        WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
26249 C        CALL DT_EVTOUT(4)
26250 C        STOP
26251 C     ENDIF
26252       IF (MODE.EQ.2) THEN
26253          ICH  = ICH+IPHO_CHR3(ID,1)/3
26254          IBAR = IBAR+IPHO_BAR3(ID,1)/3
26255       ELSEIF (MODE.EQ.-2) THEN
26256          ICH  = ICH-IPHO_CHR3(ID,1)/3
26257          IBAR = IBAR-IPHO_BAR3(ID,1)/3
26258       ENDIF
26259
26260       RETURN
26261
26262  9999 CONTINUE
26263       IREJ = 1
26264       RETURN
26265       END
26266
26267 ************************************************************************
26268 *                                                                      *
26269 *                 4) Transformations                                   *
26270 *                                                                      *
26271 ************************************************************************
26272 *$ CREATE DT_LTINI.FOR
26273 *COPY DT_LTINI
26274 *
26275 *===ltini==============================================================*
26276 *
26277       SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
26278
26279 ************************************************************************
26280 * Initializations of Lorentz-transformations, calculation of Lorentz-  *
26281 * parameters.                                                          *
26282 * This version dated 13.11.95 is written by  S. Roesler.               *
26283 ************************************************************************
26284
26285       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26286       SAVE
26287       PARAMETER ( LINP = 10 ,
26288      &            LOUT = 6 ,
26289      &            LDAT = 9 )
26290       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,
26291      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
26292
26293 * Lorentz-parameters of the current interaction
26294       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26295      &                UMO,PPCM,EPROJ,PPROJ
26296 * properties of photon/lepton projectiles
26297       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
26298 * particle properties (BAMJET index convention)
26299       CHARACTER*8  ANAME
26300       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26301      &                IICH(210),IIBAR(210),K1(210),K2(210)
26302 * nucleon-nucleon event-generator
26303       CHARACTER*8 CMODEL
26304       LOGICAL LPHOIN
26305       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
26306
26307       Q2   = VIRT
26308       IDP  = IDPR
26309       IF (MCGENE.NE.3) THEN
26310 * lepton-projectiles and PHOJET: initialize real photon instead
26311          IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26312      &       (IDPR.EQ.10).OR.(IDPR.EQ.11).OR.
26313      &       (IDPR.EQ. 5).OR.(IDPR.EQ. 6))   THEN
26314             IDP = 7
26315             Q2  = ZERO
26316          ENDIF
26317       ENDIF
26318       IDT  = IDTA
26319       EPN  = EPN0
26320       PPN  = PPN0
26321       ECM  = ECM0
26322       AMP  = AAM(IDP)-SQRT(ABS(Q2))
26323       AMT  = AAM(IDT)
26324       AMP2 = SIGN(AMP**2,AMP)
26325       AMT2 = AMT**2
26326       IF (ECM0.GT.ZERO) THEN
26327          EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT)
26328          IF (AMP2.GT.ZERO) THEN
26329             PPN = SQRT((EPN+AMP)*(EPN-AMP))
26330          ELSE
26331             PPN = SQRT(EPN**2-AMP2)
26332          ENDIF
26333       ELSE
26334          IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26335             IF (IDP.EQ.7) EPN = ABS(EPN)
26336             IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP
26337             IF (AMP2.GT.ZERO) THEN
26338                PPN = SQRT((EPN+AMP)*(EPN-AMP))
26339             ELSE
26340                PPN = SQRT(EPN**2-AMP2)
26341             ENDIF
26342          ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26343             IF (AMP2.GT.ZERO) THEN
26344                EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
26345             ELSE
26346                EPN = SQRT(PPN**2+AMP2)
26347             ENDIF
26348          ENDIF
26349          ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
26350       ENDIF
26351       UMO   = ECM
26352       EPROJ = EPN
26353       PPROJ = PPN
26354       IF (AMP2.GT.ZERO) THEN
26355          ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
26356          PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
26357       ELSE
26358          ETARG = TINY10
26359          PTARG = TINY10
26360       ENDIF
26361 * photon-projectiles (get momentum in cm-frame for virtuality Q^2)
26362       IF (IDP.EQ.7) THEN
26363          PGAMM(1) = ZERO
26364          PGAMM(2) = ZERO
26365          AMGAM  = AMP
26366          AMGAM2 = AMP2
26367          IF (ECM0.GT.ZERO) THEN
26368             S = ECM0**2
26369          ELSE
26370             IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26371                S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0)
26372             ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26373                S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2)
26374             ENDIF
26375          ENDIF
26376          PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2
26377      &                     +AMGAM2**2+AMT2**2)/(4.0D0*S) )
26378          PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2)
26379          IF (MODE.EQ.1) THEN
26380             PNUCL(1) = ZERO
26381             PNUCL(2) = ZERO
26382             PNUCL(3) = -PGAMM(3)
26383             PNUCL(4) = SQRT(S)-PGAMM(4)
26384          ENDIF
26385       ENDIF
26386       IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26387      &    (IDPR.EQ.10).OR.(IDPR.EQ.11))   THEN
26388          PLEPT0(1) = ZERO
26389          PLEPT0(2) = ZERO
26390 * neglect lepton masses
26391 C        AMLPT2   = AAM(IDPR)**2
26392          AMLPT2   = ZERO
26393 *
26394          IF (ECM0.GT.ZERO) THEN
26395             S = ECM0**2
26396          ELSE
26397             IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26398                S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0)
26399             ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26400                S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2)
26401             ENDIF
26402          ENDIF
26403          PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2
26404      &                     +AMLPT2**2+AMT2**2)/(4.0D0*S) )
26405          PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2)
26406          PNUCL(1) = ZERO
26407          PNUCL(2) = ZERO
26408          PNUCL(3) = -PLEPT0(3)
26409          PNUCL(4) = SQRT(S)-PLEPT0(4)
26410       ENDIF
26411 * Lorentz-parameter for transformation Lab. - projectile rest system
26412       IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
26413          GALAB = TINY10
26414          BGLAB = TINY10
26415          BLAB  = TINY10
26416       ELSE
26417          GALAB = EPROJ/AMP
26418          BGLAB = PPROJ/AMP
26419          BLAB  = BGLAB/GALAB
26420       ENDIF
26421 * Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
26422       IF (IDP.EQ.7) THEN
26423          GACMS(1) = TINY10
26424          BGCMS(1) = TINY10
26425       ELSE
26426          GACMS(1) = (ETARG+AMP)/UMO
26427          BGCMS(1) = PTARG/UMO
26428       ENDIF
26429 * Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
26430       GACMS(2) = (EPROJ+AMT)/UMO
26431       BGCMS(2) = PPROJ/UMO
26432       PPCM     = GACMS(2)*PPROJ-BGCMS(2)*EPROJ
26433
26434       EPN0 = EPN
26435       PPN0 = PPN
26436       ECM0 = ECM
26437
26438       RETURN
26439       END
26440
26441 *$ CREATE DT_LTRANS.FOR
26442 *COPY DT_LTRANS
26443 *
26444 *===ltrans=============================================================*
26445 *
26446       SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
26447
26448 ************************************************************************
26449 * Lorentz-transformations.                                             *
26450 *   MODE = 1(-1)    projectile rest syst.   --> Lab (back)             *
26451 *        = 2(-2)    projectile rest syst.   --> nucl.-nucl.cms (back)  *
26452 *        = 3(-3)    target rest syst. (=Lab)--> nucl.-nucl.cms (back)  *
26453 * This version dated 01.11.95 is written by  S. Roesler.               *
26454 ************************************************************************
26455
26456       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26457       SAVE
26458       PARAMETER ( LINP = 10 ,
26459      &            LOUT = 6 ,
26460      &            LDAT = 9 )
26461       PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
26462
26463       PARAMETER (SQTINF=1.0D+15)
26464
26465 * particle properties (BAMJET index convention)
26466       CHARACTER*8  ANAME
26467       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26468      &                IICH(210),IIBAR(210),K1(210),K2(210)
26469
26470       PXO = PXI
26471       PYO = PYI
26472       CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
26473
26474 * check particle mass for consistency (numerical rounding errors)
26475       PO     = SQRT(PXO*PXO+PYO*PYO+PZO*PZO)
26476       AMO2   = (PEO-PO)*(PEO+PO)
26477       AMORQ2 = AAM(ID)**2
26478       AMDIF2 = ABS(AMO2-AMORQ2)
26479       IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN
26480          DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO))
26481          PEO   = PEO+DELTA
26482          PO1   = PO -DELTA
26483          PXO   = PXO*PO1/PO
26484          PYO   = PYO*PO1/PO
26485          PZO   = PZO*PO1/PO
26486 C        WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
26487       ENDIF
26488
26489       RETURN
26490       END
26491
26492 *$ CREATE DT_LTNUC.FOR
26493 *COPY DT_LTNUC
26494 *
26495 *===ltnuc==============================================================*
26496 *
26497       SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
26498
26499 ************************************************************************
26500 * Lorentz-transformations.                                             *
26501 *   PIN        longitudnal momentum       (input)                      *
26502 *   EIN        energy                     (input)                      *
26503 *   POUT       transformed long. momentum (output)                     *
26504 *   EOUT       transformed energy         (output)                     *
26505 *   MODE = 1(-1)    projectile rest syst.   --> Lab (back)             *
26506 *        = 2(-2)    projectile rest syst.   --> nucl.-nucl.cms (back)  *
26507 *        = 3(-3)    target rest syst. (=Lab)--> nucl.-nucl.cms (back)  *
26508 * This version dated 01.11.95 is written by  S. Roesler.               *
26509 ************************************************************************
26510
26511       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26512       SAVE
26513       PARAMETER ( LINP = 10 ,
26514      &            LOUT = 6 ,
26515      &            LDAT = 9 )
26516       PARAMETER (ZERO=0.0D0)
26517
26518 * Lorentz-parameters of the current interaction
26519       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26520      &                UMO,PPCM,EPROJ,PPROJ
26521
26522       BDUM1 = ZERO
26523       BDUM2 = ZERO
26524       PDUM1 = ZERO
26525       PDUM2 = ZERO
26526       IF (ABS(MODE).EQ.1) THEN
26527          BG = -SIGN(BGLAB,DBLE(MODE))
26528          CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN,
26529      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26530       ELSEIF (ABS(MODE).EQ.2) THEN
26531          BG = SIGN(BGCMS(1),DBLE(MODE))
26532          CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26533      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26534       ELSEIF (ABS(MODE).EQ.3) THEN
26535          BG = -SIGN(BGCMS(2),DBLE(MODE))
26536          CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26537      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26538       ELSE
26539          WRITE(LOUT,1000) MODE
26540  1000    FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
26541          EOUT = EIN
26542          POUT = PIN
26543       ENDIF
26544
26545       RETURN
26546       END
26547
26548 *$ CREATE DT_DALTRA.FOR
26549 *COPY DT_DALTRA
26550 *
26551 *===daltra=============================================================*
26552 *
26553       SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
26554
26555 ************************************************************************
26556 * Arbitrary Lorentz-transformation.                                    *
26557 * Adopted from the original by S. Roesler. This version dated 15.01.95 *
26558 ************************************************************************
26559
26560       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26561       SAVE
26562       PARAMETER (ONE=1.0D0)
26563
26564       EP = PCX*BGX+PCY*BGY+PCZ*BGZ
26565       PE = EP/(GA+ONE)+EC
26566       PX = PCX+BGX*PE
26567       PY = PCY+BGY*PE
26568       PZ = PCZ+BGZ*PE
26569       P  = SQRT(PX*PX+PY*PY+PZ*PZ)
26570       E  = GA*EC+EP
26571
26572       RETURN
26573       END
26574
26575 *$ CREATE DT_DTRAFO.FOR
26576 *COPY DT_DTRAFO
26577 *
26578 *====dtrafo============================================================*
26579 *
26580       SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
26581      &                                    PL,CXL,CYL,CZL,EL)
26582
26583 C     LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
26584
26585       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26586       SAVE
26587
26588       IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
26589       SID  = SQRT(1.D0-COD*COD)
26590       PLX  = P*SID*COF
26591       PLY  = P*SID*SIF
26592       PCMZ = P*COD
26593       PLZ  = GAM*PCMZ+BGAM*ECM
26594       PL   = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
26595       EL   = GAM*ECM+BGAM*PCMZ
26596 C     ROTATION INTO THE ORIGINAL DIRECTION
26597       COZ  = PLZ/PL
26598       SIZ  = SQRT(1.D0-COZ**2)
26599       CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
26600
26601       RETURN
26602       END
26603
26604 *$ CREATE DT_STTRAN.FOR
26605 *COPY DT_STTRAN
26606 *
26607 *====sttran============================================================*
26608 *
26609       SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
26610
26611       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26612       SAVE
26613       DATA ANGLSQ/1.D-30/
26614 ************************************************************************
26615 *     VERSION BY                     J. RANFT                          *
26616 *                                    LEIPZIG                           *
26617 *                                                                      *
26618 *     THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES      *
26619 *                                                                      *
26620 *     INPUT VARIABLES:                                                 *
26621 *        XO,YO,ZO = ORIGINAL DIRECTION COSINES                         *
26622 *        CDE,SDE  = COSINE AND SINE OF THE POLAR (THETA)               *
26623 *                   ANGLE OF "SCATTERING"                              *
26624 *        SDE      = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING"    *
26625 *        SFE,CFE  = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE       *
26626 *                   OF "SCATTERING"                                    *
26627 *                                                                      *
26628 *     OUTPUT VARIABLES:                                                *
26629 *        X,Y,Z     = NEW DIRECTION COSINES                             *
26630 *                                                                      *
26631 *     ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 )                  *
26632 ************************************************************************
26633 *
26634 *
26635 *  Changed by A. Ferrari
26636 *
26637 *     IF (ABS(XO)-0.0001D0) 1,1,2
26638 *   1 IF (ABS(YO)-0.0001D0) 3,3,2
26639 *   3 CONTINUE
26640       A = XO**2 + YO**2
26641       IF ( A .LT. ANGLSQ ) THEN
26642          X=SDE*CFE
26643          Y=SDE*SFE
26644          Z=CDE*ZO
26645       ELSE
26646          XI=SDE*CFE
26647          YI=SDE*SFE
26648          ZI=CDE
26649          A=SQRT(A)
26650          X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
26651          Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
26652          Z=A*YI+ZO*ZI
26653       ENDIF
26654
26655       RETURN
26656       END
26657
26658 *$ CREATE DT_MYTRAN.FOR
26659 *COPY DT_MYTRAN
26660 *
26661 *===mytran=============================================================*
26662 *
26663       SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
26664
26665 ************************************************************************
26666 * This subroutine rotates the coordinate frame                         *
26667 *    a) theta  around y                                                *
26668 *    b) phi    around z      if IMODE = 1                              *
26669 *                                                                      *
26670 *     x'          cos(ph) -sin(ph) 0      cos(th)  0  sin(th)   x      *
26671 *     y' = A B =  sin(ph) cos(ph)  0  .   0        1        0   y      *
26672 *     z'          0       0        1     -sin(th)  0  cos(th)   z      *
26673 *                                                                      *
26674 * and vice versa if IMODE = 0.                                         *
26675 * This version dated 5.4.94 is based on the original version DTRAN     *
26676 * by J. Ranft and is written by S. Roesler.                            *
26677 ************************************************************************
26678
26679       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26680       SAVE
26681       PARAMETER ( LINP = 10 ,
26682      &            LOUT = 6 ,
26683      &            LDAT = 9 )
26684
26685       IF (IMODE.EQ.1) THEN
26686          X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
26687          Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
26688          Z=-SDE    *XO       +CDE    *ZO
26689       ELSE
26690          X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
26691          Y= -SFE*XO+CFE*YO
26692          Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
26693       ENDIF
26694       RETURN
26695       END
26696
26697 *$ CREATE DT_LT2LAO.FOR
26698 *COPY DT_LT2LAO
26699 *
26700 *===lt2lab=============================================================*
26701 *
26702       SUBROUTINE DT_LT2LAO
26703
26704 ************************************************************************
26705 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1   *
26706 * for final state particles/fragments defined in nucleon-nucleon-cms   *
26707 * and transforms them back to the lab.                                 *
26708 * This version dated 16.11.95 is written by S. Roesler                 *
26709 ************************************************************************
26710
26711       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26712       SAVE
26713       PARAMETER ( LINP = 10 ,
26714      &            LOUT = 6 ,
26715      &            LDAT = 9 )
26716
26717 * event history
26718       PARAMETER (NMXHKK=200000)
26719       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26720      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26721      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26722 * extended event history
26723       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26724      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26725      &                IHIST(2,NMXHKK)
26726
26727       NEND      = NHKK
26728       NPOINT(5) = NHKK+1
26729       IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
26730       DO 1 I=NPOINT(4),NEND
26731 C     DO 1 I=1,NEND
26732          IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26733      &                                (ISTHKK(I).EQ.1001)) THEN
26734             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26735             NOB = NOBAM(I)
26736             CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I),
26737      &                            PZ,PE,IDRES(I),IDXRES(I),IDCH(I))
26738             IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN
26739                ISTHKK(I) = 3*ISTHKK(I)
26740                NOBAM(NHKK)  = NOB
26741             ELSE
26742                IF (ISTHKK(I).EQ.-1) NOBAM(NHKK)  = NOB
26743                ISTHKK(I) = SIGN(3,ISTHKK(I))
26744             ENDIF
26745             JDAHKK(1,I) = NHKK
26746          ENDIF
26747     1 CONTINUE
26748
26749       RETURN
26750       END
26751
26752 *$ CREATE DT_LT2LAB.FOR
26753 *COPY DT_LT2LAB
26754 *
26755 *===lt2lab=============================================================*
26756 *
26757       SUBROUTINE DT_LT2LAB
26758
26759 ************************************************************************
26760 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1   *
26761 * for final state particles/fragments defined in nucleon-nucleon-cms   *
26762 * and transforms them to the lab.                                      *
26763 * This version dated 07.01.96 is written by S. Roesler                 *
26764 ************************************************************************
26765
26766       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26767       SAVE
26768       PARAMETER ( LINP = 10 ,
26769      &            LOUT = 6 ,
26770      &            LDAT = 9 )
26771
26772 * event history
26773       PARAMETER (NMXHKK=200000)
26774       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26775      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26776      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26777 * extended event history
26778       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26779      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26780      &                IHIST(2,NMXHKK)
26781
26782       IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
26783       DO 1 I=NPOINT(4),NHKK
26784          IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26785      &                                (ISTHKK(I).EQ.1001)) THEN
26786
26787             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26788             PHKK(3,I) = PZ
26789             PHKK(4,I) = PE
26790          ENDIF
26791     1 CONTINUE
26792
26793       RETURN
26794       END
26795
26796 ************************************************************************
26797 *                                                                      *
26798 *                 5) Sampling from distributions                       *
26799 *                                                                      *
26800 ************************************************************************
26801 *$ CREATE IDT_NPOISS.FOR
26802 *COPY IDT_NPOISS
26803 *
26804 *===npoiss=============================================================*
26805 *
26806       INTEGER FUNCTION IDT_NPOISS(AVN)
26807
26808 ************************************************************************
26809 * Sample according to Poisson distribution with Poisson parameter AVN. *
26810 * The original version written by J. Ranft.                            *
26811 * This version dated 11.1.95 is written by S. Roesler.                 *
26812 ************************************************************************
26813
26814       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26815       SAVE
26816       PARAMETER ( LINP = 10 ,
26817      &            LOUT = 6 ,
26818      &            LDAT = 9 )
26819
26820       EXPAVN = EXP(-AVN)
26821       K = 1
26822       A = 1.0D0
26823
26824    10 CONTINUE
26825       A = DT_RNDM(A)*A
26826       IF (A.GE.EXPAVN) THEN
26827          K = K+1
26828          GOTO 10
26829       ENDIF
26830       IDT_NPOISS = K-1
26831
26832       RETURN
26833       END
26834
26835 *$ CREATE DT_SAMPXB.FOR
26836 *COPY DT_SAMPXB
26837 *
26838 *===sampxb=============================================================*
26839 *
26840       DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
26841
26842 ************************************************************************
26843 * Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2.             *
26844 * Processed by S. Roesler, 6.5.95                                      *
26845 ************************************************************************
26846
26847       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26848       SAVE
26849       PARAMETER (TWO=2.0D0)
26850
26851       A1 = LOG(X1+SQRT(X1**2+B**2))
26852       A2 = LOG(X2+SQRT(X2**2+B**2))
26853       AN = A2-A1
26854       A  = AN*DT_RNDM(A1)+A1
26855       BB = EXP(A)
26856       DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
26857
26858       RETURN
26859       END
26860
26861 *$ CREATE DT_SAMPEX.FOR
26862 *COPY DT_SAMPEX
26863 *
26864 *===sampex=============================================================*
26865 *
26866       DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
26867
26868 ************************************************************************
26869 * Sampling from f(x)=1./x between x1 and x2.                           *
26870 * Processed by S. Roesler, 6.5.95                                      *
26871 ************************************************************************
26872
26873       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26874       SAVE
26875       PARAMETER (ONE=1.0D0)
26876
26877       R   = DT_RNDM(X1)
26878       AL1 = LOG(X1)
26879       AL2 = LOG(X2)
26880       DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
26881
26882       RETURN
26883       END
26884
26885 *$ CREATE DT_SAMSQX.FOR
26886 *COPY DT_SAMSQX
26887 *
26888 *===samsqx=============================================================*
26889 *
26890       DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
26891
26892 ************************************************************************
26893 * Sampling from f(x)=1./x^0.5 between x1 and x2.                       *
26894 * Processed by S. Roesler, 6.5.95                                      *
26895 ************************************************************************
26896
26897       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26898       SAVE
26899       PARAMETER (ONE=1.0D0)
26900
26901       R = DT_RNDM(X1)
26902       DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
26903
26904       RETURN
26905       END
26906
26907 *$ CREATE DT_SAMPLW.FOR
26908 *COPY DT_SAMPLW
26909 *
26910 *===samplw=============================================================*
26911 *
26912       DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
26913
26914 ************************************************************************
26915 * Sampling from f(x)=1/x^b between x_min and x_max.                    *
26916 * S. Roesler, 18.4.98                                                  *
26917 ************************************************************************
26918
26919       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26920       SAVE
26921       PARAMETER (ONE=1.0D0)
26922
26923       R = DT_RNDM(B)
26924       IF (B.EQ.ONE) THEN
26925          DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
26926       ELSE
26927          ONEMB  = ONE-B
26928          DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
26929       ENDIF
26930
26931       RETURN
26932       END
26933
26934 *$ CREATE DT_BETREJ.FOR
26935 *COPY DT_BETREJ
26936 *
26937 *===betrej=============================================================*
26938 *
26939       DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
26940
26941       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26942       SAVE
26943
26944       PARAMETER ( LINP = 10 ,
26945      &            LOUT = 6 ,
26946      &            LDAT = 9 )
26947       PARAMETER (ONE=1.0D0)
26948
26949       IF (XMIN.GE.XMAX)THEN
26950          WRITE (LOUT,500) XMIN,XMAX
26951   500    FORMAT(1X,'DT_BETREJ:  XMIN<XMAX execution stopped ',2F10.5)
26952          STOP
26953       ENDIF
26954
26955    10 CONTINUE
26956       XX     = XMIN+(XMAX-XMIN)*DT_RNDM(ETA)
26957       BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE)
26958       YY     = BETMAX*DT_RNDM(XX)
26959       BETXX  = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE)
26960       IF (YY.GT.BETXX) GOTO 10
26961       DT_BETREJ = XX
26962
26963       RETURN
26964       END
26965
26966 *$ CREATE DT_DGAMRN.FOR
26967 *COPY DT_DGAMRN
26968 *
26969 *===dgamrn=============================================================*
26970 *
26971       DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
26972
26973 ************************************************************************
26974 * Sampling from Gamma-distribution.                                    *
26975 *       F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)            *
26976 * Processed by S. Roesler, 6.5.95                                      *
26977 ************************************************************************
26978
26979       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26980       SAVE
26981       PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
26982
26983       NCOU = 0
26984       N    = INT(ETA)
26985       F    = ETA-DBLE(N)
26986       IF (F.EQ.ZERO) GOTO 20
26987    10 R = DT_RNDM(F)
26988       NCOU = NCOU+1
26989       IF (NCOU.GE.11) GOTO 20
26990       IF (R.LT.F/(F+2.71828D0)) GOTO 30
26991       YYY = LOG(DT_RNDM(R)+TINY9)/F
26992       IF (ABS(YYY).GT.50.0D0) GOTO 20
26993       Y = EXP(YYY)
26994       IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
26995       GOTO 40
26996    20 Y = 0.0D0
26997       GOTO 50
26998    30 Y = ONE-LOG(DT_RNDM(Y)+TINY9)
26999       IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10
27000    40 IF (N.EQ.0) GOTO 70
27001    50 Z = 1.0D0
27002       DO 60 I = 1,N
27003    60 Z = Z*DT_RNDM(Z)
27004       Y = Y-LOG(Z+TINY9)
27005    70 DT_DGAMRN = Y/ALAM
27006
27007       RETURN
27008       END
27009
27010 *$ CREATE DT_DBETAR.FOR
27011 *COPY DT_DBETAR
27012 *
27013 *===dbetar=============================================================*
27014 *
27015       DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
27016
27017 ************************************************************************
27018 * Sampling from Beta -distribution between 0.0 and 1.0                 *
27019 *  F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
27020 * Processed by S. Roesler, 6.5.95                                      *
27021 ************************************************************************
27022
27023       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27024       SAVE
27025
27026       Y = DT_DGAMRN(1.0D0,GAM)
27027       Z = DT_DGAMRN(1.0D0,ETA)
27028       DT_DBETAR = Y/(Y+Z)
27029
27030       RETURN
27031       END
27032
27033 *$ CREATE DT_RANNOR.FOR
27034 *COPY DT_RANNOR
27035 *
27036 *===rannor=============================================================*
27037 *
27038       SUBROUTINE DT_RANNOR(X,Y)
27039
27040 ************************************************************************
27041 * Sampling from Gaussian distribution.                                 *
27042 * Processed by S. Roesler, 6.5.95                                      *
27043 ************************************************************************
27044
27045       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27046       SAVE
27047       PARAMETER (TINY10=1.0D-10)
27048
27049       CALL DT_DSFECF(SFE,CFE)
27050       V = MAX(TINY10,DT_RNDM(X))
27051       A = SQRT(-2.D0*LOG(V))
27052       X = A*SFE
27053       Y = A*CFE
27054
27055       RETURN
27056       END
27057
27058 *$ CREATE DT_DPOLI.FOR
27059 *COPY DT_DPOLI
27060 *
27061 *===dpoli==============================================================*
27062 *
27063       SUBROUTINE DT_DPOLI(CS,SI)
27064
27065       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27066       SAVE
27067
27068       U  = DT_RNDM(CS)
27069       CS = DT_RNDM(U)
27070       IF (U.LT.0.5D0) CS=-CS
27071       SI = SQRT(1.0D0-CS*CS+1.0D-10)
27072
27073       RETURN
27074       END
27075
27076 *$ CREATE DT_DSFECF.FOR
27077 *COPY DT_DSFECF
27078 *
27079 *===dsfecf=============================================================*
27080 *
27081       SUBROUTINE DT_DSFECF(SFE,CFE)
27082
27083       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27084       SAVE
27085       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
27086
27087     1 CONTINUE
27088       X  = DT_RNDM(SFE)
27089       Y  = DT_RNDM(X)
27090       XX = X*X
27091       YY = Y*Y
27092       XY = XX+YY
27093       IF (XY.GT.ONE) GOTO 1
27094       CFE = (XX-YY)/XY
27095       SFE = TWO*X*Y/XY
27096       IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
27097       RETURN
27098       END
27099
27100 *$ CREATE DT_RACO.FOR
27101 *COPY DT_RACO
27102 *
27103 *===raco===============================================================*
27104 *
27105       SUBROUTINE DT_RACO(WX,WY,WZ)
27106
27107 ************************************************************************
27108 * Direction cosines of random uniform (isotropic) direction in three   *
27109 * dimensional space                                                    *
27110 * Processed by S. Roesler, 20.11.95                                    *
27111 ************************************************************************
27112
27113       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27114       SAVE
27115       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
27116
27117   10  CONTINUE
27118       X  = TWO*DT_RNDM(WX)-ONE
27119       Y  = DT_RNDM(X)
27120       X2 = X*X
27121       Y2 = Y*Y
27122       IF (X2+Y2.GT.ONE) GOTO 10
27123
27124       CFE = (X2-Y2)/(X2+Y2)
27125       SFE = TWO*X*Y/(X2+Y2)
27126 * z = 1/2 [ 1 + cos (theta) ]
27127       Z   = DT_RNDM(X)
27128 * 1/2 sin (theta)
27129       WZ = SQRT(Z*(ONE-Z))
27130       WX = TWO*WZ*CFE
27131       WY = TWO*WZ*SFE
27132       WZ = TWO*Z-ONE
27133
27134       RETURN
27135       END
27136
27137 ************************************************************************
27138 *                                                                      *
27139 *           6) Special functions, algorithms and service routines      *
27140 *                                                                      *
27141 ************************************************************************
27142 *$ CREATE DT_YLAMB.FOR
27143 *COPY DT_YLAMB
27144 *
27145 *===ylamb==============================================================*
27146 *
27147       DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
27148
27149 ************************************************************************
27150 *                                                                      *
27151 *     auxiliary function for three particle decay mode                 *
27152 *     (standard LAMBDA**(1/2) function)                                *
27153 *                                                                      *
27154 * Adopted from an original version written by R. Engel.                *
27155 * This version dated 12.12.94 is written by S. Roesler.                *
27156 ************************************************************************
27157
27158       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27159       SAVE
27160
27161       YZ   = Y-Z
27162       XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ
27163       IF (XLAM.LE.0.D0) XLAM = ABS(XLAM)
27164       DT_YLAMB = SQRT(XLAM)
27165
27166       RETURN
27167       END
27168
27169 *$ CREATE DT_SORT.FOR
27170 *COPY DT_SORT
27171 *
27172 *===sort1==============================================================*
27173 *
27174       SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
27175
27176 ************************************************************************
27177 * This subroutine sorts entries in A in increasing/decreasing order    *
27178 * of A(3,i).                                                           *
27179 *              MODE  = 1     increasing in A(3,i=1..N)                 *
27180 *                    = 2     decreasing in A(3,i=1..N)                 *
27181 * This version dated 21.04.95 is revised by S. Roesler                 *
27182 ************************************************************************
27183
27184       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27185       SAVE
27186
27187       DIMENSION A(3,N)
27188
27189       M = I1
27190    10 CONTINUE
27191       M = I1-1
27192       IF (M.LE.0) RETURN
27193       L = 0
27194       DO 20 I=I0,M
27195          J = I+1
27196          IF (MODE.EQ.1) THEN
27197             IF (A(3,I).LE.A(3,J)) GOTO 20
27198          ELSE
27199             IF (A(3,I).GE.A(3,J)) GOTO 20
27200          ENDIF
27201          B = A(3,I)
27202          C = A(1,I)
27203          D = A(2,I)
27204          A(3,I) = A(3,J)
27205          A(2,I) = A(2,J)
27206          A(1,I) = A(1,J)
27207          A(3,J) = B
27208          A(1,J) = C
27209          A(2,J) = D
27210          L = 1
27211    20 CONTINUE
27212       IF (L.EQ.1) GOTO 10
27213
27214       RETURN
27215       END
27216
27217 *$ CREATE DT_SORT1.FOR
27218 *COPY DT_SORT1
27219 *
27220 *===sort1==============================================================*
27221 *
27222       SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
27223
27224 ************************************************************************
27225 * This subroutine sorts entries in A in increasing/decreasing order    *
27226 * of A(i).                                                             *
27227 *              MODE  = 1     increasing in A(i=1..N)                   *
27228 *                    = 2     decreasing in A(i=1..N)                   *
27229 * This version dated 21.04.95 is revised by S. Roesler                 *
27230 ************************************************************************
27231
27232       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27233       SAVE
27234
27235       DIMENSION A(N),IDX(N)
27236
27237       M = I1
27238    10 CONTINUE
27239       M = I1-1
27240       IF (M.LE.0) RETURN
27241       L = 0
27242       DO 20 I=I0,M
27243          J = I+1
27244          IF (MODE.EQ.1) THEN
27245             IF (A(I).LE.A(J)) GOTO 20
27246          ELSE
27247             IF (A(I).GE.A(J)) GOTO 20
27248          ENDIF
27249          B    = A(I)
27250          A(I) = A(J)
27251          A(J) = B
27252          IX     = IDX(I)
27253          IDX(I) = IDX(J)
27254          IDX(J) = IX
27255          L = 1
27256    20 CONTINUE
27257       IF (L.EQ.1) GOTO 10
27258
27259       RETURN
27260       END
27261
27262 *$ CREATE DT_XTIME.FOR
27263 *COPY DT_XTIME
27264 *
27265 *===xtime==============================================================*
27266 *
27267       SUBROUTINE DT_XTIME
27268
27269       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27270       SAVE
27271       PARAMETER ( LINP = 10 ,
27272      &            LOUT = 6 ,
27273      &            LDAT = 9 )
27274
27275       CHARACTER DAT*9,TIM*11
27276
27277       DAT = '         '
27278       TIM = '           '
27279 C     CALL GETDAT(IYEAR,IMONTH,IDAY)
27280 C     CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
27281
27282 C     CALL DATE(DAT)
27283 C     CALL TIME(TIM)
27284 C     WRITE(LOUT,1000) DAT,TIM
27285  1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
27286
27287       RETURN
27288       END
27289
27290 ************************************************************************
27291 *                                                                      *
27292 *                 7) Random number generator package                   *
27293 *                                                                      *
27294 *    THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND        *
27295 *    SERVICE ROUTINES.                                                 *
27296 *    THE ALGORITHM IS FROM                                             *
27297 *      'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR'                     *
27298 *      G.MARSAGLIA, A.ZAMAN ;  FSU-SCRI-87-50                          *
27299 *    IMPLEMENTATION BY K. HAHN  DEC. 88,                               *
27300 *    THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS *
27301 *    AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ),        *
27302 *    THE PERIOD IS ABOUT 2**144,                                       *
27303 *    TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS,            *
27304 *    THE PACKAGE CONTAINS                                              *
27305 *      FUNCTION DT_RNDM(I)                  : GENERATOR                *
27306 *      SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION           *
27307 *      SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J)  : PUT SEED TO GENERATOR    *
27308 *      SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J)  : TAKE SEED FROM GENERATOR *
27309 *      SUBROUTINE DT_RNDMTE(IO)             : TEST OF GENERATOR        *
27310 *---                                                                   *
27311 *    FUNCTION DT_RNDM(I)                                               *
27312 *       GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS  IN (0..1)          *
27313 *       I  - DUMMY VARIABLE, NOT USED                                  *
27314 *    SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)                             *
27315 *       INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM *
27316 *       NA1,NA2,NA3,NB1  - VALUES FOR INITIALIZING THE GENERATOR       *
27317 *                          NA? MUST BE IN 1..178 AND NOT ALL 1         *
27318 *                          12,34,56  ARE THE STANDARD VALUES           *
27319 *                          NB1 MUST BE IN 1..168                       *
27320 *                          78  IS THE STANDARD VALUE                   *
27321 *    SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J)                               *
27322 *       PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS   *
27323 *       AS AFTER THE LAST DT_RNDMOU CALL )                             *
27324 *       U(97),C,CD,CM,I,J  - SEED VALUES AS TAKEN FROM DT_RNDMOU       *
27325 *    SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J)                               *
27326 *       TAKES SEED FROM GENERATOR                                      *
27327 *       U(97),C,CD,CM,I,J  - SEED VALUES                               *
27328 *    SUBROUTINE DT_RNDMTE(IO)                                          *
27329 *       TEST OF THE GENERATOR                                          *
27330 *       IO     - DEFINES OUTPUT                                        *
27331 *                  = 0  OUTPUT ONLY IF AN ERROR IS DETECTED            *
27332 *                  = 1  OUTPUT INDEPENDEND ON AN ERROR                 *
27333 *       DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO   *
27334 *       SAME STATUS                                                    *
27335 *       AS BEFORE CALL OF DT_RNDMTE                                    *
27336 ************************************************************************
27337 *$ CREATE DT_RNDM.FOR
27338 *COPY DT_RNDM
27339 *
27340 c$$$*===rndm===============================================================*
27341 c$$$*
27342 c$$$      DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
27343 c$$$
27344 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27345 c$$$      SAVE
27346 c$$$
27347 c$$$* random number generator
27348 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27349 c$$$
27350 c$$$* counter of calls to random number generator
27351 c$$$* uncomment if needed
27352 c$$$C     COMMON /DTRNCT/ IRNCT0,IRNCT1
27353 c$$$C     LOGICAL LFIRST
27354 c$$$C     DATA LFIRST /.TRUE./
27355 c$$$
27356 c$$$* counter of calls to random number generator
27357 c$$$* uncomment if needed
27358 c$$$C     IF (LFIRST) THEN
27359 c$$$C        IRNCT0 = 0
27360 c$$$C        IRNCT1 = 0
27361 c$$$C        LFIRST = .FALSE.
27362 c$$$C     ENDIF
27363 c$$$ 100  CONTINUE
27364 c$$$      DT_RNDM = U(I)-U(J)
27365 c$$$      IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0
27366 c$$$      U(I) = DT_RNDM
27367 c$$$      I    = I-1
27368 c$$$      IF ( I.EQ.0 ) I = 97
27369 c$$$      J    = J-1
27370 c$$$      IF ( J.EQ.0 ) J = 97
27371 c$$$      C    = C-CD
27372 c$$$      IF ( C.LT.0.0D0 ) C = C+CM
27373 c$$$      DT_RNDM = DT_RNDM-C
27374 c$$$      IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0
27375 c$$$
27376 c$$$      IF ((DT_RNDM.EQ.0.D0).OR.(DT_RNDM.EQ.1.D0)) GOTO 100
27377 c$$$
27378 c$$$* counter of calls to random number generator
27379 c$$$* uncomment if needed
27380 c$$$C     IRNCT0 = IRNCT0+1
27381 c$$$
27382 c$$$      RETURN
27383 c$$$      END
27384 c$$$
27385 c$$$*$ CREATE DT_RNDMST.FOR
27386 c$$$*COPY DT_RNDMST
27387 c$$$*
27388 c$$$*===rndmst=============================================================*
27389 c$$$*
27390 c$$$      SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
27391 c$$$
27392 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27393 c$$$      SAVE
27394 c$$$
27395 c$$$* random number generator
27396 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27397 c$$$
27398 c$$$      MA1 = NA1
27399 c$$$      MA2 = NA2
27400 c$$$      MA3 = NA3
27401 c$$$      MB1 = NB1
27402 c$$$      I   = 97
27403 c$$$      J   = 33
27404 c$$$      DO 20 II2 = 1,97
27405 c$$$        S = 0
27406 c$$$        T = 0.5D0
27407 c$$$        DO 10 II1 = 1,24
27408 c$$$          MAT  = MOD(MOD(MA1*MA2,179)*MA3,179)
27409 c$$$          MA1  = MA2
27410 c$$$          MA2  = MA3
27411 c$$$          MA3  = MAT
27412 c$$$          MB1  = MOD(53*MB1+1,169)
27413 c$$$          IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
27414 c$$$   10   T = 0.5D0*T
27415 c$$$   20 U(II2) = S
27416 c$$$      C  =   362436.0D0/16777216.0D0
27417 c$$$      CD =  7654321.0D0/16777216.0D0
27418 c$$$      CM = 16777213.0D0/16777216.0D0
27419 c$$$      RETURN
27420 c$$$      END
27421 c$$$
27422 c$$$*$ CREATE DT_RNDMIN.FOR
27423 c$$$*COPY DT_RNDMIN
27424 c$$$*
27425 c$$$*===rndmin=============================================================*
27426 c$$$*
27427 c$$$      SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
27428 c$$$
27429 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27430 c$$$      SAVE
27431 c$$$
27432 c$$$* random number generator
27433 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27434 c$$$
27435 c$$$      DIMENSION UIN(97)
27436 c$$$
27437 c$$$      DO 10 KKK = 1,97
27438 c$$$   10 U(KKK) = UIN(KKK)
27439 c$$$      C  = CIN
27440 c$$$      CD = CDIN
27441 c$$$      CM = CMIN
27442 c$$$      I  = IIN
27443 c$$$      J  = JIN
27444 c$$$
27445 c$$$      RETURN
27446 c$$$      END
27447 c$$$
27448 c$$$*$ CREATE DT_RNDMOU.FOR
27449 c$$$*COPY DT_RNDMOU
27450 c$$$*
27451 c$$$*===rndmou=============================================================*
27452 c$$$*
27453 c$$$      SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
27454 c$$$
27455 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27456 c$$$      SAVE
27457 c$$$
27458 c$$$* random number generator
27459 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27460 c$$$
27461 c$$$      DIMENSION UOUT(97)
27462 c$$$
27463 c$$$      DO 10 KKK = 1,97
27464 c$$$   10 UOUT(KKK) = U(KKK)
27465 c$$$      COUT  = C
27466 c$$$      CDOUT = CD
27467 c$$$      CMOUT = CM
27468 c$$$      IOUT  = I
27469 c$$$      JOUT  = J
27470 c$$$
27471 c$$$      RETURN
27472 c$$$      END
27473 c$$$
27474 c$$$*$ CREATE DT_RNDMTE.FOR
27475 c$$$*COPY DT_RNDMTE
27476 c$$$*
27477 c$$$*===rndmte=============================================================*
27478 c$$$*
27479 c$$$      SUBROUTINE DT_RNDMTE(IO)
27480 c$$$
27481 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27482 c$$$      SAVE
27483 c$$$
27484 c$$$      DIMENSION UU(97),U(6),X(6),D(6)
27485 c$$$      DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0,
27486 c$$$     +8354498.D0, 10633180.D0/
27487 c$$$
27488 c$$$      CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ)
27489 c$$$      CALL DT_RNDMST(12,34,56,78)
27490 c$$$      DO 10 II1 = 1,20000
27491 c$$$   10 XX = DT_RNDM(XX)
27492 c$$$      SD        = 0.0D0
27493 c$$$      DO 20 II2 = 1,6
27494 c$$$        X(II2)  = 4096.D0*(4096.D0*DT_RNDM(SD))
27495 c$$$        D(II2)  = X(II2)-U(II2)
27496 c$$$   20 SD = SD+D(II2)
27497 c$$$      CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
27498 c$$$**sr 24.01.95
27499 c$$$C     IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6)
27500 c$$$      IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN
27501 c$$$C        WRITE(6,1000)
27502 c$$$ 1000    FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
27503 c$$$     &          ' passed')
27504 c$$$      ENDIF
27505 c$$$**
27506 c$$$      RETURN
27507 c$$$  500 FORMAT('  === TEST OF THE RANDOM-GENERATOR ===',/,
27508 c$$$     &'    EXPECTED VALUE    CALCULATED VALUE     DIFFERENCE',/, 6(F17.
27509 c$$$     &1,F20.1,F15.3,/), '  === END OF TEST ;',
27510 c$$$     &'  GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE')
27511 c$$$      END
27512 *
27513 *$ CREATE PHO_RNDM.FOR
27514 *COPY PHO_RNDM
27515 *
27516 *===pho_rndm===========================================================*
27517 *
27518       DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
27519
27520       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27521       SAVE
27522
27523       PHO_RNDM = DT_RNDM(DUMMY)
27524
27525       RETURN
27526       END
27527
27528 *$ CREATE PYR.FOR
27529 *COPY PYR
27530 *
27531 *===pyr================================================================*
27532 *
27533       DOUBLE PRECISION FUNCTION PYR(IDUMMY)
27534
27535       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27536       SAVE
27537
27538       DUMMY = DBLE(IDUMMY)
27539       PYR = DT_RNDM(DUMMY)
27540
27541       RETURN
27542       END
27543
27544 *$ CREATE DT_TITLE.FOR
27545 *COPY DT_TITLE
27546 *
27547 *===title==============================================================*
27548 *
27549       SUBROUTINE DT_TITLE
27550
27551       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27552       SAVE
27553       PARAMETER ( LINP = 10 ,
27554      &            LOUT = 6 ,
27555      &            LDAT = 9 )
27556
27557       CHARACTER*6 CVERSI
27558       CHARACTER*11 CCHANG
27559       DATA CVERSI,CCHANG /'3.0-5 ','08 Jan 2007'/
27560
27561       CALL DT_XTIME
27562       WRITE(LOUT,1000) CVERSI,CCHANG
27563  1000 FORMAT(1X,'+-------------------------------------------------',
27564      &                  '----------------------+',/,
27565      &     1X,'|',71X,'|',/,
27566      &     1X,'|',26X,'DPMJET version ',A6,24X,'|',/,
27567      &     1X,'|',71X,'|',/,
27568      &     1X,'|',22X,'(Last change: ',A11,')',23X,'|',/,
27569      &     1X,'|',71X,'|',/,
27570      &     1X,'|',12X,'Authors: Stefan Roesler   (CERN)',27X,'|',/,
27571      &     1X,'|',21X,'Ralph Engel      (FZ Karlsruhe)',19X,'|',/,
27572      &     1X,'|',21X,'Johannes Ranft   (Siegen Univ.)',19X,'|',/,
27573      &     1X,'|',71X,'|',/,
27574      &     1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html',
27575      &                                              17X,'|',/,
27576      &     1X,'|',71X,'|',/,
27577      &     1X,'+-------------------------------------------------',
27578      &                '----------------------+',/,
27579      &     1X,'| Please send suggestions, bug reports, etc. to: ',
27580      &                                  'Stefan.Roesler@cern.ch |',/,
27581      &     1X,'+-------------------------------------------------',
27582      &                '----------------------+',/)
27583
27584       RETURN
27585       END
27586
27587 *$ CREATE DT_EVTINI.FOR
27588 *COPY DT_EVTINI
27589 *
27590 *===evtini=============================================================*
27591 *
27592       SUBROUTINE DT_EVTINI
27593
27594 ************************************************************************
27595 * Initialization of DTEVT1.                                            *
27596 * This version dated 15.01.94 is written by S. Roesler                 *
27597 ************************************************************************
27598
27599       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27600       SAVE
27601       PARAMETER ( LINP = 10 ,
27602      &            LOUT = 6 ,
27603      &            LDAT = 9 )
27604
27605 * event history
27606       PARAMETER (NMXHKK=200000)
27607       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27608      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27609      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27610 * extended event history
27611       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27612      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27613      &                IHIST(2,NMXHKK)
27614 * event flag
27615       COMMON /DTEVNO/ NEVENT,ICASCA
27616       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27617 * emulsion treatment
27618       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
27619      &                NCOMPO,IEMUL
27620
27621 * initialization of DTEVT1/DTEVT2
27622       NEND = NHKK
27623       IF (NEVENT.EQ.1) NEND = NMXHKK
27624       NHKK   = 0
27625       NEVHKK = NEVENT
27626       DO 1 I=1,NEND
27627          ISTHKK(I)   = 0
27628          IDHKK(I)    = 0
27629          JMOHKK(1,I) = 0
27630          JMOHKK(2,I) = 0
27631          JDAHKK(1,I) = 0
27632          JDAHKK(2,I) = 0
27633          IDRES(I)    = 0
27634          IDXRES(I)   = 0
27635          NOBAM(I)    = 0
27636          IDCH(I)     = 0
27637          IHIST(1,I)  = 0
27638          IHIST(2,I)  = 0
27639          DO 2 J=1,4
27640             PHKK(J,I) = 0.0D0
27641             VHKK(J,I) = 0.0D0
27642             WHKK(J,I) = 0.0D0
27643     2    CONTINUE
27644          PHKK(5,I) = 0.0D0
27645     1 CONTINUE
27646       DO 3 I=1,10
27647          NPOINT(I) = 0
27648     3 CONTINUE
27649       CALL DT_CHASTA(-1)
27650
27651 C* initialization of DTLTRA
27652 C      IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
27653
27654       RETURN
27655       END
27656
27657 *$ CREATE DT_STATIS.FOR
27658 *COPY DT_STATIS
27659 *
27660 *===statis=============================================================*
27661 *
27662       SUBROUTINE DT_STATIS(MODE)
27663
27664 ************************************************************************
27665 * Initialization and output of run-statistics.                         *
27666 *              MODE  = 1     initialization                            *
27667 *                    = 2     output                                    *
27668 * This version dated 23.01.94 is written by S. Roesler                 *
27669 ************************************************************************
27670
27671       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27672       SAVE
27673       PARAMETER ( LINP = 10 ,
27674      &            LOUT = 6 ,
27675      &            LDAT = 9 )
27676       PARAMETER (TINY3=1.0D-3)
27677
27678 * statistics
27679       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
27680      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
27681      &                ICEVTG(8,0:30)
27682 * rejection counter
27683       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27684      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27685      &                IREXCI(3),IRDIFF(2),IRINC
27686 * central particle production, impact parameter biasing
27687       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
27688 * various options for treatment of partons (DTUNUC 1.x)
27689 * (chain recombination, Cronin,..)
27690       LOGICAL LCO2CR,LINTPT
27691       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
27692      &                LCO2CR,LINTPT
27693 * nucleon-nucleon event-generator
27694       CHARACTER*8 CMODEL
27695       LOGICAL LPHOIN
27696       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
27697 * flags for particle decays
27698       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
27699      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
27700      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
27701 * diquark-breaking mechanism
27702       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
27703
27704       DIMENSION PP(4),PT(4)
27705
27706       GOTO (1,2) MODE
27707
27708 * initialization
27709     1 CONTINUE
27710
27711 *   initialize statistics counter
27712       ICREQU = 0
27713       ICSAMP = 0
27714       ICCPRO = 0
27715       ICDPR  = 0
27716       ICDTA  = 0
27717       ICRJSS = 0
27718       ICVV2S = 0
27719       DO 10 I=1,9
27720          ICRES(I)    = 0
27721          ICCHAI(1,I) = 0
27722          ICCHAI(2,I) = 0
27723    10 CONTINUE
27724 *   initialize rejection counter
27725       IRPT      = 0
27726       IRHHA     = 0
27727       LOMRES    = 0
27728       LOBRES    = 0
27729       IRFRAG    = 0
27730       IREVT     = 0
27731       IRRES(1)  = 0
27732       IRRES(2)  = 0
27733       IRCHKI(1) = 0
27734       IRCHKI(2) = 0
27735       IRCRON(1) = 0
27736       IRCRON(2) = 0
27737       IRCRON(3) = 0
27738       IRDIFF(1) = 0
27739       IRDIFF(2) = 0
27740       IRINC     = 0
27741       DO 11 I=1,5
27742          ICDIFF(I) = 0
27743    11 CONTINUE
27744       DO 12 I=1,8
27745          DO 13 J=0,30
27746             ICEVTG(I,J) = 0
27747    13    CONTINUE
27748    12 CONTINUE
27749
27750       RETURN
27751
27752 * output
27753     2 CONTINUE
27754
27755 *   statistics counter
27756       WRITE(LOUT,1000)
27757  1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/,
27758      &       28X,'---------------------')
27759       IF (ICREQU.GT.0) THEN
27760       WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
27761  1001 FORMAT(/,1X,'number of events requested / sampled',13X,
27762      &       I8,' / ',I8,/,1X,'number of samp. evts per requested ',
27763      &       'event',11X,F9.1)
27764       ENDIF
27765       IF (ICDIFF(1).NE.0) THEN
27766          WRITE(LOUT,1009) ICDIFF
27767  1009    FORMAT(/,1X,'diffractive events:    total   ',I8,/,49X,
27768      &          'low mass   high mass',/,24X,'single diffraction',
27769      &          7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
27770       ENDIF
27771       IF (ICENTR.GT.0.AND.ICSAMP.GT.0.AND.ICCPRO.GT.0) THEN
27772          WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
27773      &                    DBLE(ICSAMP)/DBLE(ICCPRO)
27774  1002    FORMAT(/,1X,'central production:',/,2X,'mean number',
27775      &          ' of sampled Glauber-events per event',9X,F9.1,/,
27776      &          2X,'fraction of production cross section',21X,F10.6)
27777       ENDIF
27778       IF (ICSAMP.GT.0) THEN
27779       WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
27780      &                 DBLE(ICDTA)/DBLE(ICSAMP)
27781  1003 FORMAT(/,54X,'proj.    targ.',/,1X,'average number of wounded',
27782      &       ' nucleons after x-sampling',2(4X,F6.2))
27783       ENDIF
27784
27785       IF (MCGENE.EQ.1) THEN
27786          IF (ICSAMP.GT.0) THEN
27787          WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
27788  1004    FORMAT(/,1X,'mean number of sea-sea chain rejections per',
27789      &          ' event',3X,F9.1)
27790          IF (ISICHA.EQ.1) THEN
27791             WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
27792  1005       FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
27793      &             'of single chains  per event',13X,F9.1)
27794          ENDIF
27795          ENDIF
27796          IF (ICSAMP.GT.0.AND.ICREQU.GT.0) THEN
27797          WRITE(LOUT,1006)
27798  1006    FORMAT(/,1X,'chain system statistics:  (per event)',/,
27799      &       23X,'mean number of chains      mean number of chains',/,
27800      &       23X,'sampled    hadronized      having mass of a reso.')
27801          WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
27802      &                     DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
27803      &                     DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
27804      &                  DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
27805  1007    FORMAT(1X,'sea     - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27806      &          1X,'disea   - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27807      &          1X,'sea     - disea   ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27808      &          1X,'sea     - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27809      &          1X,'disea   - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27810      &          1X,'valence - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27811      &          1X,'valence - disea   ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27812      &          1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27813      &          1X,'fused chains      ',18X,F4.1,17X,F4.1,/)
27814          WRITE(LOUT,1008)
27815      &     (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
27816      &     DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
27817      &     DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
27818      &     (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
27819      &     (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
27820      &     DBLE(IRHHA)/DBLE(ICREQU),
27821      &     DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
27822      &     (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
27823  1008    FORMAT(/,1X,'Rejection counter:  (NEVT = no. of events)',/,/,
27824      &       1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
27825      &       F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
27826      &       'Intrins. p_t (GETSPT)',21X,'IRPT     /NEVT = ',F7.2,/,
27827      &       1X,'Chain mass corr. for resonances (EVTRES)',2X,
27828      &       'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES)  IRRES(2) /',
27829      &       'NEVT = ',F7.2,/,43X,'LOMRES   /NEVT = ',F7.2,/,
27830      &       43X,'LOBRES   /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
27831      &       ' 2-chain systems (CHKINE)  IRCHKI(1)/NEVT = ',F7.2,/,
27832      &       43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
27833      &       'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
27834      &       F7.2,/,1X,'Total no. of rej.',
27835      &       ' in chain-systems treatment (GETCSY)',/,43X,
27836      &       'IRHHA    /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
27837      &       ' (not yet used!)',4X,'IRFRAG   /NEVT = ',F7.2,/,
27838      &       1X,'Total no. of rej. in DPM-treatment of one event',
27839      &       ' (EVENTA)',/,43X,'IREVT    /NEVT = ',F7.2,/,1X,
27840      &       'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
27841      &       ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
27842      &       'IREXCI(3) = ',I5,/)
27843          ENDIF
27844       ELSEIF (MCGENE.EQ.2) THEN
27845          WRITE(LOUT,1010) ELOJET
27846  1010    FORMAT(/,/,1X,'PHOJET-treatment of chain systems above  ',
27847      &          F4.1,' GeV')
27848          WRITE(LOUT,1011)
27849  1011    FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
27850      &          30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
27851      &          5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
27852          WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
27853      &                    (INT(ICCHAI(2,I)/2.0D0),I=1,8),
27854      &                    (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
27855      &                    ((ICEVTG(I,J),I=1,8),J=3,7),
27856      &                    ((ICEVTG(I,J),I=1,8),J=19,21),
27857      &                    (ICEVTG(I,8),I=1,8),
27858      &                    ((ICEVTG(I,J),I=1,8),J=22,24),
27859      &                    (ICEVTG(I,9),I=1,8),
27860      &                    ((ICEVTG(I,J),I=1,8),J=25,28),
27861      &                    ((ICEVTG(I,J),I=1,8),J=10,18)
27862  1012    FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
27863      &          8I8,/,/,1X,'PHOJET ',8I8,/,'   sngl ',8I8,/,/,
27864      &          ' no-dif.',8I8,/,
27865      &          ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
27866      &          ' diff-1 ',8I8,/,'  low   ',8I8,/,'  high  ',8I8,/,
27867      &          '  h-diff',8I8,/,' diff-2 ',8I8,/,'  low   ',8I8,/,
27868      &          '  high  ',8I8,/,'  h-diff',8I8,/,' dbl-di.',8I8,/,
27869      &          '  lo-lo ',8I8,/,'  hi-hi ',8I8,/,'  lo-hi ',8I8,/,
27870      &          '  hi-lo ',8I8,/,
27871      &          ' dir-ga.',8I8,/,/,' dir-1  ',8I8,/,' dir-2  ',8I8,/,
27872      &          ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
27873      &          ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
27874          WRITE(LOUT,1013)
27875  1013    FORMAT(/,1X,'2. chain system statistics -',
27876      &          ' mean numbers per evt:',/,30X,'---------------------',
27877      &          /,/,16X,'s-s',7X,'d-s',7X,'s-d')
27878          IF (ICSAMP.GT.0) THEN
27879          WRITE(LOUT,1014)
27880      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
27881      &                 (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
27882      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
27883  1014    FORMAT(/,1X,'req.to.    ',3E10.2,/,/,1X,'low rq.    ',3E10.2,/,
27884      &          1X,'low ac.    ',3E10.2,/,/,1X,'PHOJET     ',3E10.2,/,/,
27885      &          ' no-dif.    ',3E10.2,/,' el-sca.    ',3E10.2,/,
27886      &          ' qel-sc.    ',3E10.2,/,' dbl-Po.    ',3E10.2,/,
27887      &          ' diff-1     ',3E10.2,/,' diff-2     ',3E10.2,/,
27888      &          ' dbl-di.    ',3E10.2,/,' dir-ga.    ',3E10.2,/,/,
27889      &          ' dir-1      ',3E10.2,/,' dir-2      ',3E10.2,/,
27890      &          ' dbl-dir    ',3E10.2,/,' s-Pom.     ',3E10.2,/,
27891      &          ' h-Pom.     ',3E10.2,/,' s-Reg.     ',3E10.2,/,
27892      &          ' enh-trg    ',3E10.2,/,' enh-log    ',3E10.2)
27893          ENDIF
27894          WRITE(LOUT,1015)
27895  1015    FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
27896          IF (ICSAMP.GT.0) THEN
27897          WRITE(LOUT,1016)
27898      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
27899      &                 (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
27900      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
27901  1016    FORMAT(/,1X,'req.to.    ',5E10.2,/,/,1X,'low rq.    ',5E10.2,/,
27902      &          1X,'low ac.    ',5E10.2,/,/,1X,'PHOJET     ',5E10.2,/,/,
27903      &          ' no-dif.    ',5E10.2,/,' el-sca.    ',5E10.2,/,
27904      &          ' qel-sc.    ',5E10.2,/,' dbl-Po.    ',5E10.2,/,
27905      &          ' diff-1     ',5E10.2,/,' diff-2     ',5E10.2,/,
27906      &          ' dbl-di.    ',5E10.2,/,' dir-ga.    ',5E10.2,/,/,
27907      &          ' dir-1      ',5E10.2,/,' dir-2      ',5E10.2,/,
27908      &          ' dbl-dir    ',5E10.2,/,' s-Pom.     ',5E10.2,/,
27909      &          ' h-Pom.     ',5E10.2,/,' s-Reg.     ',5E10.2,/,
27910      &          ' enh-trg    ',5E10.2,/,' enh-log    ',5E10.2)
27911          ENDIF
27912
27913       ENDIF
27914       CALL DT_CHASTA(1)
27915
27916       IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
27917      &                        .OR.(PDBSEA(3).GT.0.0D0)) THEN
27918          WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
27919      &    DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
27920      &    DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
27921          WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
27922      &    DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
27923      &    DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
27924          WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
27925      &    DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
27926      &    DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
27927          WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
27928      &    DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
27929      &    DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
27930          WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
27931      &    DBRKA(3,1),DBRKA(3,2),
27932      &    DBRKA(3,3),DBRKA(3,4)
27933          WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
27934      &    DBRKR(3,1),DBRKR(3,2),
27935      &    DBRKR(3,3),DBRKR(3,4)
27936          WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
27937      &    DBRKA(3,5),DBRKA(3,6),
27938      &    DBRKA(3,7),DBRKA(3,8)
27939          WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
27940      &    DBRKR(3,5),DBRKR(3,6),
27941      &    DBRKR(3,7),DBRKR(3,8)
27942       ENDIF
27943
27944       FAC = 1.0D0
27945       IF (MCGENE.EQ.2) THEN
27946 C        CALL PHO_PHIST(-2,SIGMAX)
27947          CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
27948       ENDIF
27949
27950       CALL DT_XTIME
27951
27952       RETURN
27953       END
27954
27955 *$ CREATE DT_EVTOUT.FOR
27956 *COPY DT_EVTOUT
27957 *
27958 *===evtout=============================================================*
27959 *
27960       SUBROUTINE DT_EVTOUT(MODE)
27961
27962 ************************************************************************
27963 *            MODE  = 1  plot content of complete DTEVT1 to out. unit   *
27964 *                    3  plot entries of extended DTEVT1 (DTEVT2)       *
27965 *                    4  plot entries of DTEVT1 and DTEVT2              *
27966 * This version dated 11.12.94 is written by S. Roesler                 *
27967 ************************************************************************
27968
27969       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27970       SAVE
27971       PARAMETER ( LINP = 10 ,
27972      &            LOUT = 6 ,
27973      &            LDAT = 9 )
27974 * event history
27975       PARAMETER (NMXHKK=200000)
27976       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27977      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27978      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27979
27980       DIMENSION IRANGE(NMXHKK)
27981
27982       IF (MODE.EQ.2) RETURN
27983
27984       CALL DT_EVTPLO(IRANGE,MODE)
27985
27986       RETURN
27987       END
27988
27989 *$ CREATE DT_EVTPLO.FOR
27990 *COPY DT_EVTPLO
27991 *
27992 *===evtplo=============================================================*
27993 *
27994       SUBROUTINE DT_EVTPLO(IRANGE,MODE)
27995
27996 ************************************************************************
27997 *            MODE  = 1  plot content of complete DTEVT1 to out. unit   *
27998 *                    2  plot entries of DTEVT1 given by IRANGE         *
27999 *                    3  plot entries of extended DTEVT1 (DTEVT2)       *
28000 *                    4  plot entries of DTEVT1 and DTEVT2              *
28001 *                    5  plot rejection counter                         *
28002 * This version dated 11.12.94 is written by S. Roesler                 *
28003 ************************************************************************
28004
28005       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28006       SAVE
28007       PARAMETER ( LINP = 10 ,
28008      &            LOUT = 6 ,
28009      &            LDAT = 9 )
28010
28011       CHARACTER*16 CHAU
28012
28013 * event history
28014       PARAMETER (NMXHKK=200000)
28015       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28016      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28017      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28018 * extended event history
28019       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28020      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28021      &                IHIST(2,NMXHKK)
28022 * rejection counter
28023       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
28024      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
28025      &                IREXCI(3),IRDIFF(2),IRINC
28026
28027       DIMENSION IRANGE(NMXHKK)
28028
28029       IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
28030          WRITE(LOUT,1000)
28031  1000    FORMAT(/,1X,'EVTPLO:',14X,'    content of COMMON /DTEVT1/',/,
28032      &         15X,'           --------------------------',/,/,
28033      &             '       ST    ID  M1   M2   D1   D2     PX     PY',
28034      &             '     PZ      E       M',/)
28035          DO 1 I=1,NHKK
28036             WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28037      &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28038      &                       PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
28039      &                       PHKK(5,I)
28040 C           WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28041 C    &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28042 C    &                       PHKK(3,I),PHKK(4,I)
28043 C           WRITE(LOUT,'(4E15.4)')
28044 C    &         VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
28045  1001       FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
28046  1011       FORMAT(I5,I5,I6,4I5,2E15.5)
28047     1    CONTINUE
28048          WRITE(LOUT,*)
28049 C        DO 4 I=1,NHKK
28050 C           WRITE(LOUT,1006) I,ISTHKK(I),
28051 C    &                    VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
28052 C    &                    WHKK(2,I),WHKK(3,I)
28053 C1006       FORMAT(1X,I4,I6,6E10.3)
28054 C   4    CONTINUE
28055       ENDIF
28056
28057       IF (MODE.EQ.2) THEN
28058          WRITE(LOUT,1000)
28059          NC = 0
28060     2    CONTINUE
28061          NC = NC+1
28062          IF (IRANGE(NC).EQ.-100) GOTO 9999
28063          I = IRANGE(NC)
28064          WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28065      &                    JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28066      &                    PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
28067      &                    PHKK(5,I)
28068          GOTO 2
28069       ENDIF
28070
28071       IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
28072          WRITE(LOUT,1002)
28073  1002    FORMAT(/,1X,'EVTPLO:',14X,
28074      &         ' content of COMMON /DTEVT1/,/DTEVT2/',/,
28075      &         15X,'        -----------------------------------',/,/,
28076      &             '       ST    ID   M1   M2   D1   D2  IDR  IDXR',
28077      &             ' NOBAM IDCH    M',/)
28078          DO 3 I=1,NHKK
28079 C           IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
28080                KF    = IDHKK(I)
28081                IDCHK = KF/10000
28082                IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28083      &            (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
28084                CALL PYNAME(KF,CHAU)
28085                WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28086      &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28087      &                       IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
28088      &                       PHKK(5,I),CHAU
28089  1003          FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
28090 C           ENDIF
28091     3    CONTINUE
28092       ENDIF
28093
28094       IF (MODE.EQ.5) THEN
28095          WRITE(LOUT,1004)
28096  1004    FORMAT(/,1X,'EVTPLO:',14X,'    content of COMMON /DTREJC/',/,
28097      &         15X,'           --------------------------',/)
28098          WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
28099      &                    IRSEA,IRCRON
28100  1005    FORMAT(1X,'IRPT   = ',I5,'  IRHHA = ',I5,/,
28101      &          1X,'IRRES  = ',2I5,'  LOMRES = ',I5,'  LOBRES = ',I5,/,
28102      &          1X,'IREMC  = ',10I5,/,
28103      &          1X,'IRFRAG = ',I5,'  IRSEA = ',I5,' IRCRON = ',I5,/)
28104       ENDIF
28105
28106  9999 RETURN
28107       END
28108
28109 *$ CREATE DT_EVTPUT.FOR
28110 *COPY DT_EVTPUT
28111 *
28112 *===evtput=============================================================*
28113 *
28114       SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
28115
28116       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28117       SAVE
28118       PARAMETER ( LINP = 10 ,
28119      &            LOUT = 6 ,
28120      &            LDAT = 9 )
28121       PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
28122      &           TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0)
28123
28124 * event history
28125       PARAMETER (NMXHKK=200000)
28126       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28127      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28128      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28129 * extended event history
28130       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28131      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28132      &                IHIST(2,NMXHKK)
28133 * Lorentz-parameters of the current interaction
28134       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28135      &                UMO,PPCM,EPROJ,PPROJ
28136 * particle properties (BAMJET index convention)
28137       CHARACTER*8  ANAME
28138       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28139      &                IICH(210),IIBAR(210),K1(210),K2(210)
28140
28141 C     IF (MODE.GT.100) THEN
28142 C        WRITE(LOUT,'(1X,A,I5,A,I5)')
28143 C    &        'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
28144 C        NHKK = NHKK-MODE+100
28145 C        RETURN
28146 C     ENDIF
28147       MO1  = M1
28148       MO2  = M2
28149       NHKK = NHKK+1
28150
28151       IF (NHKK.GT.NMXHKK) THEN
28152          WRITE(LOUT,1000) NHKK
28153  1000    FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
28154      &             '! program execution stopped..')
28155          STOP
28156       ENDIF
28157       IF (M1.LT.0) MO1 = NHKK+M1
28158       IF (M2.LT.0) MO2 = NHKK+M2
28159       ISTHKK(NHKK)   = IST
28160       IDHKK(NHKK)    = ID
28161       JMOHKK(1,NHKK) = MO1
28162       JMOHKK(2,NHKK) = MO2
28163       JDAHKK(1,NHKK) = 0
28164       JDAHKK(2,NHKK) = 0
28165       IDRES(NHKK)    = IDR
28166       IDXRES(NHKK)   = IDXR
28167       IDCH(NHKK)     = IDC
28168 ** here we need to do something..
28169       IF (ID.EQ.88888) THEN
28170          IDMO1 = ABS(IDHKK(MO1))
28171          IDMO2 = ABS(IDHKK(MO2))
28172          IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
28173          IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
28174          IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
28175          IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
28176       ELSE
28177          NOBAM(NHKK) = 0
28178       ENDIF
28179       IDBAM(NHKK) = IDT_ICIHAD(ID)
28180       IF (MO1.GT.0) THEN
28181          IF (JDAHKK(1,MO1).NE.0) THEN
28182             JDAHKK(2,MO1) = NHKK
28183          ELSE
28184             JDAHKK(1,MO1) = NHKK
28185          ENDIF
28186       ENDIF
28187       IF (MO2.GT.0) THEN
28188          IF (JDAHKK(1,MO2).NE.0) THEN
28189             JDAHKK(2,MO2) = NHKK
28190          ELSE
28191             JDAHKK(1,MO2) = NHKK
28192          ENDIF
28193       ENDIF
28194 C      IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
28195 C         PTOT   = SQRT(PX**2+PY**2+PZ**2)
28196 C         AM0    = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
28197 C         AMRQ   = AAM(IDBAM(NHKK))
28198 C         AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
28199 C         IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
28200 C     &       (PTOT.GT.ZERO)) THEN
28201 C            DELTA = -AMDIF2/(2.0D0*(E+PTOT))
28202 CC           DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
28203 C            E     = E+DELTA
28204 C            PTOT1 = PTOT-DELTA
28205 C            PX    = PX*PTOT1/PTOT
28206 C            PY    = PY*PTOT1/PTOT
28207 C            PZ    = PZ*PTOT1/PTOT
28208 C         ENDIF
28209 C      ENDIF
28210       PHKK(1,NHKK) = PX
28211       PHKK(2,NHKK) = PY
28212       PHKK(3,NHKK) = PZ
28213       PHKK(4,NHKK) = E
28214       PTOT = SQRT( PX**2+PY**2+PZ**2 )
28215       IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
28216          PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
28217          PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
28218       ELSE
28219          PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
28220 C        IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
28221 C    &      WRITE(LOUT,'(1X,A,G10.3)')
28222 C    &        'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
28223          PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
28224       ENDIF
28225       IDCHK = ID/10000
28226       IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
28227 * special treatment for chains:
28228 *    z coordinate of chain in Lab  = pos. of target nucleon
28229 *    time of chain-creation in Lab = time of passage of projectile
28230 *                                    nucleus at pos. of taget nucleus
28231 C        VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
28232 C        VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
28233          VHKK(1,NHKK) = VHKK(1,MO2)
28234          VHKK(2,NHKK) = VHKK(2,MO2)
28235          VHKK(3,NHKK) = VHKK(3,MO2)
28236          VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
28237 C        WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
28238 C        WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
28239          WHKK(1,NHKK) = WHKK(1,MO1)
28240          WHKK(2,NHKK) = WHKK(2,MO1)
28241          WHKK(3,NHKK) = WHKK(3,MO1)
28242          WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
28243       ELSE
28244          IF (MO1.GT.0) THEN
28245             DO 1 I=1,4
28246                VHKK(I,NHKK) = VHKK(I,MO1)
28247                WHKK(I,NHKK) = WHKK(I,MO1)
28248     1       CONTINUE
28249          ELSE
28250             DO 2 I=1,4
28251                VHKK(I,NHKK) = ZERO
28252                WHKK(I,NHKK) = ZERO
28253     2       CONTINUE
28254          ENDIF
28255       ENDIF
28256
28257       RETURN
28258       END
28259
28260 *$ CREATE DT_CHASTA.FOR
28261 *COPY DT_CHASTA
28262 *
28263 *===chasta=============================================================*
28264 *
28265       SUBROUTINE DT_CHASTA(MODE)
28266
28267 ************************************************************************
28268 * This subroutine performs CHAin STAtistics and checks sequence of     *
28269 * partons in dtevt1 and sorts them with projectile partons coming      *
28270 * first if necessary.                                                  *
28271 *                                                                      *
28272 * This version dated  8.5.00  is written by S. Roesler.                *
28273 ************************************************************************
28274
28275       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28276       SAVE
28277       PARAMETER ( LINP = 10 ,
28278      &            LOUT = 6 ,
28279      &            LDAT = 9 )
28280
28281       CHARACTER*5 CCHTYP
28282
28283 * event history
28284       PARAMETER (NMXHKK=200000)
28285       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28286      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28287      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28288 * extended event history
28289       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28290      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28291      &                IHIST(2,NMXHKK)
28292 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
28293       PARAMETER (MAXCHN=10000)
28294       COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
28295
28296       DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
28297      &          CCHTYP(9),ICHSTA(10),ITOT(10)
28298       DATA ICHCFG /1800*0/
28299       DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
28300       DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
28301       DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
28302       DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
28303       DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
28304       DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
28305       DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
28306      &              'ad aq',' d ad','ad d ',' g g '/
28307 *
28308 * initialization
28309 *
28310       IF (MODE.EQ.-1) THEN
28311          NCHAIN = 0
28312 *
28313 * loop over DTEVT1 and analyse chain configurations
28314 *
28315       ELSEIF (MODE.EQ.0) THEN
28316          DO 21 IDX=NPOINT(3),NHKK
28317             IDCHK = IDHKK(IDX)/10000
28318             IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28319      &          (IDHKK(IDX).NE.80000).AND.
28320      &          (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
28321                IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
28322                   WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
28323      &                          ' at entry ',IDX
28324                   GOTO 21
28325                ENDIF
28326 *
28327                IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28328                IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28329                IMO1 = IST1/10
28330                IMO1 = IST1-10*IMO1
28331                IMO2 = IST2/10
28332                IMO2 = IST2-10*IMO2
28333 *   swop parton entries if necessary since we need projectile partons
28334 *   to come first in the common
28335                IF (IMO1.GT.IMO2) THEN
28336                   NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
28337                   DO 22 K=1,NPTN/2
28338                      I0 = JMOHKK(1,IDX)-1+K
28339                      I1 = JMOHKK(2,IDX)+1-K
28340                      ITMP = ISTHKK(I0)
28341                      ISTHKK(I0) = ISTHKK(I1)
28342                      ISTHKK(I1) = ITMP
28343                      ITMP = IDHKK(I0)
28344                      IDHKK(I0) = IDHKK(I1)
28345                      IDHKK(I1) = ITMP
28346                      IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
28347      &                  JDAHKK(1,JMOHKK(1,I0)) = I1
28348                      IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
28349      &                  JDAHKK(2,JMOHKK(1,I0)) = I1
28350                      IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
28351      &                  JDAHKK(1,JMOHKK(2,I0)) = I1
28352                      IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
28353      &                  JDAHKK(2,JMOHKK(2,I0)) = I1
28354                      IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
28355      &                  JDAHKK(1,JMOHKK(1,I1)) = I0
28356                      IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
28357      &                  JDAHKK(2,JMOHKK(1,I1)) = I0
28358                      IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
28359      &                  JDAHKK(1,JMOHKK(2,I1)) = I0
28360                      IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
28361      &                  JDAHKK(2,JMOHKK(2,I1)) = I0
28362                      ITMP = JMOHKK(1,I0)
28363                      JMOHKK(1,I0) = JMOHKK(1,I1)
28364                      JMOHKK(1,I1) = ITMP
28365                      ITMP = JMOHKK(2,I0)
28366                      JMOHKK(2,I0) = JMOHKK(2,I1)
28367                      JMOHKK(2,I1) = ITMP
28368                      ITMP = JDAHKK(1,I0)
28369                      JDAHKK(1,I0) = JDAHKK(1,I1)
28370                      JDAHKK(1,I1) = ITMP
28371                      ITMP = JDAHKK(2,I0)
28372                      JDAHKK(2,I0) = JDAHKK(2,I1)
28373                      JDAHKK(2,I1) = ITMP
28374                      DO 23 J=1,4
28375                         RTMP1 = PHKK(J,I0)
28376                         RTMP2 = VHKK(J,I0)
28377                         RTMP3 = WHKK(J,I0)
28378                         PHKK(J,I0) = PHKK(J,I1)
28379                         VHKK(J,I0) = VHKK(J,I1)
28380                         WHKK(J,I0) = WHKK(J,I1)
28381                         PHKK(J,I1) = RTMP1
28382                         VHKK(J,I1) = RTMP2
28383                         WHKK(J,I1) = RTMP3
28384    23                CONTINUE
28385                      RTMP1 = PHKK(5,I0)
28386                      PHKK(5,I0) = PHKK(5,I1)
28387                      PHKK(5,I1) = RTMP1
28388                      ITMP = IDRES(I0)
28389                      IDRES(I0) = IDRES(I1)
28390                      IDRES(I1) = ITMP
28391                      ITMP = IDXRES(I0)
28392                      IDXRES(I0) = IDXRES(I1)
28393                      IDXRES(I1) = ITMP
28394                      ITMP = NOBAM(I0)
28395                      NOBAM(I0) = NOBAM(I1)
28396                      NOBAM(I1) = ITMP
28397                      ITMP = IDBAM(I0)
28398                      IDBAM(I0) = IDBAM(I1)
28399                      IDBAM(I1) = ITMP
28400                      ITMP = IDCH(I0)
28401                      IDCH(I0) = IDCH(I1)
28402                      IDCH(I1) = ITMP
28403                      ITMP = IHIST(1,I0)
28404                      IHIST(1,I0) = IHIST(1,I1)
28405                      IHIST(1,I1) = ITMP
28406                      ITMP = IHIST(2,I0)
28407                      IHIST(2,I0) = IHIST(2,I1)
28408                      IHIST(2,I1) = ITMP
28409    22             CONTINUE
28410                ENDIF
28411                IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28412                IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28413 *
28414 *   parton 1 (projectile side)
28415                IF (IST1.EQ.21) THEN
28416                   IDX1 = 1
28417                ELSEIF (IST1.EQ.22) THEN
28418                   IDX1 = 2
28419                ELSEIF (IST1.EQ.31) THEN
28420                   IDX1 = 3
28421                ELSEIF (IST1.EQ.32) THEN
28422                   IDX1 = 4
28423                ELSEIF (IST1.EQ.41) THEN
28424                   IDX1 = 5
28425                ELSEIF (IST1.EQ.42) THEN
28426                   IDX1 = 6
28427                ELSEIF (IST1.EQ.51) THEN
28428                   IDX1 = 7
28429                ELSEIF (IST1.EQ.52) THEN
28430                   IDX1 = 8
28431                ELSEIF (IST1.EQ.61) THEN
28432                   IDX1 = 9
28433                ELSEIF (IST1.EQ.62) THEN
28434                   IDX1 = 10
28435                ELSE
28436 c                 WRITE(LOUT,*)
28437 c    &               ' CHASTA: unknown parton status flag (',
28438 c    &               IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28439                   GOTO 21
28440                ENDIF
28441                ID = IDHKK(JMOHKK(1,IDX))
28442                IF (ABS(ID).LE.4) THEN
28443                   IF (ID.GT.0) THEN
28444                      ITYP1 = 1
28445                   ELSE
28446                      ITYP1 = 2
28447                   ENDIF
28448                ELSEIF (ABS(ID).GE.1000) THEN
28449                   IF (ID.GT.0) THEN
28450                      ITYP1 = 3
28451                   ELSE
28452                      ITYP1 = 4
28453                   ENDIF
28454                ELSEIF (ID.EQ.21) THEN
28455                   ITYP1 = 5
28456                ELSE
28457                   WRITE(LOUT,*)
28458      &               ' CHASTA: inconsistent parton identity (',
28459      &               ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28460                   GOTO 21
28461                ENDIF
28462 *
28463 *   parton 2 (target side)
28464                IF (IST2.EQ.21) THEN
28465                   IDX2 = 1
28466                ELSEIF (IST2.EQ.22) THEN
28467                   IDX2 = 2
28468                ELSEIF (IST2.EQ.31) THEN
28469                   IDX2 = 3
28470                ELSEIF (IST2.EQ.32) THEN
28471                   IDX2 = 4
28472                ELSEIF (IST2.EQ.41) THEN
28473                   IDX2 = 5
28474                ELSEIF (IST2.EQ.42) THEN
28475                   IDX2 = 6
28476                ELSEIF (IST2.EQ.51) THEN
28477                   IDX2 = 7
28478                ELSEIF (IST2.EQ.52) THEN
28479                   IDX2 = 8
28480                ELSEIF (IST2.EQ.61) THEN
28481                   IDX2 = 9
28482                ELSEIF (IST2.EQ.62) THEN
28483                   IDX2 = 10
28484                ELSE
28485 c                 WRITE(LOUT,*)
28486 c    &               ' CHASTA: unknown parton status flag (',
28487 c    &               IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
28488                   GOTO 21
28489                ENDIF
28490                ID = IDHKK(JMOHKK(2,IDX))
28491                IF (ABS(ID).LE.4) THEN
28492                   IF (ID.GT.0) THEN
28493                      ITYP2 = 1
28494                   ELSE
28495                      ITYP2 = 2
28496                   ENDIF
28497                ELSEIF (ABS(ID).GE.1000) THEN
28498                   IF (ID.GT.0) THEN
28499                      ITYP2 = 3
28500                   ELSE
28501                      ITYP2 = 4
28502                   ENDIF
28503                ELSEIF (ID.EQ.21) THEN
28504                   ITYP2 = 5
28505                ELSE
28506                   WRITE(LOUT,*)
28507      &               ' CHASTA: inconsistent parton identity (',
28508      &               ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28509                   GOTO 21
28510                ENDIF
28511 *
28512 *   fill counter
28513                ITYPE = ICHTYP(ITYP1,ITYP2)
28514                IF (ITYPE.NE.0) THEN
28515                   ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
28516                   NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
28517                   ICHCFG(IDX1,IDX2,ITYPE,2) =
28518      &               ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
28519
28520                   NCHAIN = NCHAIN+1
28521                   IF (NCHAIN.GT.MAXCHN) THEN
28522                      WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
28523      &                  NCHAIN,MAXCHN
28524                      STOP
28525                   ENDIF
28526                   IDXCHN(1,NCHAIN) = IDX
28527                   IDXCHN(2,NCHAIN) = ITYPE
28528                ELSE
28529                   WRITE(LOUT,*)
28530      &               ' CHASTA: inconsistent chain at entry ',IDX
28531                   GOTO 21
28532                ENDIF
28533             ENDIF
28534    21    CONTINUE
28535 *
28536 * write statistics to output unit
28537 *
28538       ELSEIF (MODE.EQ.1) THEN
28539          WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
28540          DO 31 I=1,10
28541             WRITE(LOUT,'(/,2A)')
28542      &         ' -----------------------------------------',
28543      &         '------------------------------------'
28544             WRITE(LOUT,'(2A)')
28545      &         ' p\\t         21     22     31     32     41',
28546      &         '     42     51     52     61     62'
28547             WRITE(LOUT,'(2A)')
28548      &         ' -----------------------------------------',
28549      &         '------------------------------------'
28550             DO 32 J=1,10
28551                ITOT(J) = 0
28552                DO 33 K=1,9
28553                   ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
28554    33          CONTINUE
28555    32       CONTINUE
28556             WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
28557             DO 34 K=1,9
28558                ISUM = 0
28559                DO 35 J=1,10
28560                   ISUM = ISUM+ICHCFG(I,J,K,1)
28561    35          CONTINUE
28562                IF (ISUM.GT.0)
28563      &            WRITE(LOUT,'(1X,A5,2X,10I7)')
28564      &               CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
28565    34       CONTINUE
28566 C           WRITE(LOUT,'(2A)')
28567 C    &         ' -----------------------------------------',
28568 C    &         '-------------------------------'
28569    31    CONTINUE
28570 *
28571       ELSE
28572          WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
28573          STOP
28574       ENDIF
28575
28576       RETURN
28577       END
28578 *$ CREATE PHO_PHIST.FOR
28579 *COPY PHO_PHIST
28580 *
28581 *===pohist=============================================================*
28582 *
28583       SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
28584
28585       IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28586       SAVE
28587
28588       PARAMETER ( LINP = 10 ,
28589      &            LOUT = 6 ,
28590      &            LDAT = 9 )
28591       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
28592 * Glauber formalism: cross sections
28593       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
28594      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
28595      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
28596      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
28597      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
28598      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
28599      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
28600      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
28601      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
28602      &                BSLOPE,NEBINI,NQBINI
28603
28604       ILAB = 0
28605       IF (IMODE.EQ.10) THEN
28606          IMODE = 1
28607          ILAB  = 1
28608       ENDIF
28609       IF (ABS(IMODE).LT.1000) THEN
28610 * PHOJET-statistics
28611 C        CALL POHISX(IMODE,WEIGHT)
28612          IF (IMODE.EQ.-1) THEN
28613             MODE = 1
28614             XSTOT(1,1,1) = WEIGHT
28615          ENDIF
28616          IF (IMODE.EQ. 1) MODE = 2
28617          IF (IMODE.EQ.-2) MODE = 3
28618          IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
28619 C        IF (MODE.EQ.3) WRITE(LOUT,*)
28620 C    &      ' Sigma = ',XSPRO(1,1,1),' mb   used for normalization'
28621          CALL DT_HISTOG(MODE)
28622          CALL DT_USRHIS(MODE)
28623       ELSE
28624 * DTUNUC-statistics
28625          MODE = IMODE/1000
28626 C        IF (MODE.EQ.3) WRITE(LOUT,*)
28627 C    &      ' Sigma = ',XSPRO(1,1,1),' mb   used for normalization'
28628          CALL DT_HISTOG(MODE)
28629          CALL DT_USRHIS(MODE)
28630       ENDIF
28631
28632       RETURN
28633       END
28634
28635 *$ CREATE DT_SWPPHO.FOR
28636 *COPY DT_SWPPHO
28637 *
28638 *===swppho=============================================================*
28639 *
28640       SUBROUTINE DT_SWPPHO(ILAB)
28641
28642       IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28643       SAVE
28644       PARAMETER ( LINP = 10 ,
28645      &            LOUT = 6 ,
28646      &            LDAT = 9 )
28647       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28648
28649       LOGICAL LSTART
28650
28651 * event history
28652       PARAMETER (NMXHKK=200000)
28653       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28654      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28655      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28656 * extended event history
28657       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28658      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28659      &                IHIST(2,NMXHKK)
28660 * flags for input different options
28661       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28662       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28663      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28664 * properties of photon/lepton projectiles
28665       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
28666
28667 **PHOJET105a
28668 C     PARAMETER (NMXHEP=2000)
28669 C     COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28670 C    &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
28671 C     COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28672 C     COMMON /PLASAV/ PLAB
28673 **PHOJET110
28674 C  standard particle data interface
28675       INTEGER NMXHEP
28676       PARAMETER (NMXHEP=4000)
28677       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28678       DOUBLE PRECISION PHEP,VHEP
28679       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28680      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28681      &                VHEP(4,NMXHEP),NSD1, NSD2, NDD
28682 C  extension to standard particle data interface (PHOJET specific)
28683       INTEGER IMPART,IPHIST,ICOLOR
28684       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28685 C  global event kinematics and particle IDs
28686       INTEGER IFPAP,IFPAB
28687       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28688       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28689 **
28690       DATA ICOUNT/0/
28691
28692       DATA LSTART /.TRUE./
28693
28694 C     IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
28695       IF ((IFRAME.EQ.1).AND.LSTART) THEN
28696          UMO  = ECM
28697          ELA  = ZERO
28698          PLA  = ZERO
28699          IDP  = IDT_ICIHAD(IFPAP(1))
28700          IDT  = IDT_ICIHAD(IFPAP(2))
28701          VIRT = PVIRT(1)
28702          CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
28703          PLAB = PLA
28704          LSTART = .FALSE.
28705       ENDIF
28706
28707       NHKK   = 0
28708       ICOUNT = ICOUNT+1
28709 C     NEVHKK = NEVHEP
28710       NEVHKK = ICOUNT
28711       IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
28712       DO 1 I=3,NHEP
28713          IF (ISTHEP(I).EQ.1) THEN
28714             NHKK = NHKK+1
28715             ISTHKK(NHKK) = 1
28716             IDHKK(NHKK)  = IDHEP(I)
28717             JMOHKK(1,NHKK) = 0
28718             JMOHKK(2,NHKK) = 0
28719             JDAHKK(1,NHKK) = 0
28720             JDAHKK(2,NHKK) = 0
28721             DO 2 K=1,4
28722                PHKK(K,NHKK) = PHEP(K,I)
28723                VHKK(K,NHKK) = ZERO
28724                WHKK(K,NHKK) = ZERO
28725     2       CONTINUE
28726             IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
28727      &         CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
28728      &                    PHKK(3,NHKK),PHKK(4,NHKK),-3)
28729             PHKK(5,NHKK) = PHEP(5,I)
28730             IDRES(NHKK)  = 0
28731             IDXRES(NHKK) = 0
28732             NOBAM(NHKK)  = 0
28733             IDBAM(NHKK)  = IDT_ICIHAD(IDHEP(I))
28734             IDCH(NHKK)   = 0
28735          ENDIF
28736     1 CONTINUE
28737
28738       RETURN
28739       END
28740
28741 *$ CREATE DT_HISTOG.FOR
28742 *COPY DT_HISTOG
28743 *
28744 *===histog=============================================================*
28745 *
28746       SUBROUTINE DT_HISTOG(MODE)
28747
28748 ************************************************************************
28749 * This version dated 25.03.96 is written by S. Roesler                 *
28750 ************************************************************************
28751
28752       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28753       SAVE
28754       PARAMETER ( LINP = 10 ,
28755      &            LOUT = 6 ,
28756      &            LDAT = 9 )
28757
28758       LOGICAL LFSP,LRNL
28759
28760 * event history
28761       PARAMETER (NMXHKK=200000)
28762       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28763      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28764      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28765 * extended event history
28766       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28767      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28768      &                IHIST(2,NMXHKK)
28769 * event flag used for histograms
28770       COMMON /DTNORM/ ICEVT,IEVHKK
28771 * flags for activated histograms
28772       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
28773
28774       IEVHKK = NEVHKK
28775       GOTO (1,2,3) MODE
28776
28777 *------------------------------------------------------------------
28778 * initialization
28779     1 CONTINUE
28780       ICEVT = 0
28781       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
28782       IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
28783
28784       RETURN
28785 *------------------------------------------------------------------
28786 * filling of histogram with event-record
28787     2 CONTINUE
28788       ICEVT = ICEVT+1
28789
28790       DO 20 I=1,NHKK
28791          CALL DT_SWPFSP(I,LFSP,LRNL)
28792          IF (LFSP) THEN
28793             IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
28794             IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
28795          ENDIF
28796          IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
28797    20 CONTINUE
28798       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
28799
28800       RETURN
28801 *------------------------------------------------------------------
28802 * output
28803     3 CONTINUE
28804       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
28805       IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
28806
28807       RETURN
28808       END
28809
28810 *$ CREATE DT_SWPFSP.FOR
28811 *COPY DT_SWPFSP
28812 *
28813 *===swpfsp=============================================================*
28814 *
28815       SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
28816
28817       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28818       SAVE
28819       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28820       PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
28821      &           PI   =TWOPI/TWO,
28822      &           BOG  =TWOPI/360.0D0)
28823
28824 * event history
28825       PARAMETER (NMXHKK=200000)
28826       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28827      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28828      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28829 * extended event history
28830       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28831      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28832      &                IHIST(2,NMXHKK)
28833 * particle properties (BAMJET index convention)
28834       CHARACTER*8  ANAME
28835       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28836      &                IICH(210),IIBAR(210),K1(210),K2(210)
28837 * Lorentz-parameters of the current interaction
28838       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28839      &                UMO,PPCM,EPROJ,PPROJ
28840 * flags for input different options
28841       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28842       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28843      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28844 * (original name: PAREVT)
28845       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
28846      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
28847       PARAMETER ( NALLWP = 39   )
28848       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
28849      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
28850      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
28851      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
28852 * temporary storage for one final state particle
28853       LOGICAL LFRAG,LGREY,LBLACK
28854       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28855      &                SINTHE,COSTHE,THETA,THECMS,
28856      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28857      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28858      &                LFRAG,LGREY,LBLACK
28859
28860       LOGICAL LFSP,LRNL
28861
28862       LFSP = .FALSE.
28863       LRNL = .FALSE.
28864       ISTRNL = 1000
28865       MULDEF = 1
28866       IF (LEVPRT) ISTRNL = 1001
28867
28868       IF (ABS(ISTHKK(IDX)).EQ.1) THEN
28869          IST    = ISTHKK(IDX)
28870          IDPDG  = IDHKK(IDX)
28871          LFRAG  = .FALSE.
28872          IF (IDHKK(IDX).LT.80000) THEN
28873             IDBJT  = IDBAM(IDX)
28874             IBARY  = IIBAR(IDBJT)
28875             ICHAR  = IICH(IDBJT)
28876             AMASS  = AAM(IDBJT)
28877          ELSEIF (IDHKK(IDX).EQ.80000) THEN
28878             IDBJT  = 0
28879             IBARY  = IDRES(IDX)
28880             ICHAR  = IDXRES(IDX)
28881             AMASS  = PHKK(5,IDX)
28882             INUT   = IBARY-ICHAR
28883             IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
28884             IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
28885             IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
28886             IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
28887             IF (IDBJT.EQ.0) LFRAG = .TRUE.
28888          ELSE
28889             GOTO 9999
28890          ENDIF
28891          PE     = PHKK(4,IDX)
28892          PX     = PHKK(1,IDX)
28893          PY     = PHKK(2,IDX)
28894          PZ     = PHKK(3,IDX)
28895          PT2    = PX**2+PY**2
28896          PT     = SQRT(PT2)
28897          PTOT   = SQRT(PT2+PZ**2)
28898          SINTHE = PT/MAX(PTOT,TINY14)
28899          COSTHE = PZ/MAX(PTOT,TINY14)
28900          IF (COSTHE.GT.ONE) THEN
28901             THETA = ZERO
28902          ELSEIF (COSTHE.LT.-ONE) THEN
28903             THETA = TWOPI/2.0D0
28904          ELSE
28905             THETA = ACOS(COSTHE)
28906          ENDIF
28907          EKIN   = PE-AMASS
28908 **sr 15.4.96 new E_t-definition
28909          IF (IBARY.GT.0) THEN
28910             ET = EKIN*SINTHE
28911          ELSEIF (IBARY.LT.0) THEN
28912             ET = (EKIN+TWO*AMASS)*SINTHE
28913          ELSE
28914             ET = PE*SINTHE
28915          ENDIF
28916 **
28917          XLAB   = PZ/MAX(PPROJ,TINY14)
28918 C        XLAB   = PE/MAX(EPROJ,TINY14)
28919          BETA   = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
28920      &                     *(ONE+AMASS/MAX(PE,TINY14)) ))
28921          PPLUS  = PE+PZ
28922          PMINUS = PE-PZ
28923          IF (PMINUS.GT.TINY14) THEN
28924             YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28925          ELSE
28926             YY = 100.0D0
28927          ENDIF
28928          IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28929             ETA = -LOG(TAN(THETA/TWO))
28930          ELSE
28931             ETA = 100.0D0
28932          ENDIF
28933          IF (IFRAME.EQ.1) THEN
28934             CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
28935             PPLUS  = EECMS+PZCMS
28936             PMINUS = EECMS-PZCMS
28937             IF ((PPLUS*PMINUS).GT.TINY14) THEN
28938                YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28939             ELSE
28940                YYCMS = 100.0D0
28941             ENDIF
28942             PTOTCM = SQRT(PT2+PZCMS**2)
28943             COSTH = PZCMS/MAX(PTOTCM,TINY14)
28944             IF (COSTH.GT.ONE) THEN
28945                THECMS = ZERO
28946             ELSEIF (COSTH.LT.-ONE) THEN
28947                THECMS = TWOPI/2.0D0
28948             ELSE
28949                THECMS = ACOS(COSTH)
28950             ENDIF
28951             IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
28952                ETACMS = -LOG(TAN(THECMS/TWO))
28953             ELSE
28954                ETACMS = 100.0D0
28955             ENDIF
28956             XF = PZCMS/MAX(PPCM,TINY14)
28957             THECMS = THECMS/BOG
28958          ELSE
28959             PZCMS  = PZ
28960             EECMS  = PE
28961             YYCMS  = YY
28962             ETACMS = ETA
28963             XF     = XLAB
28964             THECMS = THETA/BOG
28965          ENDIF
28966          THETA  = THETA/BOG
28967
28968 * set flag for "grey/black"
28969          LGREY  = .FALSE.
28970          LBLACK = .FALSE.
28971          EK     = EKIN
28972          IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
28973          IF (MULDEF.EQ.1) THEN
28974 *  EMU01-Def.
28975             IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
28976      &                              (EK.LE.375.0D-3)      ).OR.
28977      &           ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
28978      &                              (EK.LE. 56.0D-3)      ).OR.
28979      &           ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
28980      &                              (EK.LE. 56.0D-3)      ).OR.
28981      &           ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
28982      &                              (EK.LE.198.0D-3)      ).OR.
28983      &           ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
28984      &                              (EK.LE.198.0D-3)      ).OR.
28985      &           ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28986      &             (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28987      &             (IDBJT.NE.16).AND.
28988      &             (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)    ) )
28989      &         LGREY = .TRUE.
28990             IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
28991      &           ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
28992      &           ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
28993      &           ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
28994      &           ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
28995      &           ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28996      &             (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28997      &             (IDBJT.NE.16).AND.(BETA.LE.0.23D0)  ) )
28998      &         LBLACK = .TRUE.
28999          ELSE
29000 *  common Def.
29001             IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
29002             IF (BETA.LE.0.23D0) LBLACK=.TRUE.
29003          ENDIF
29004          LFSP = .TRUE.
29005       ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
29006          IST    = ISTHKK(IDX)
29007          IDPDG  = IDHKK(IDX)
29008          LFRAG  = .TRUE.
29009          IDBJT  = 0
29010          IBARY  = IDRES(IDX)
29011          ICHAR  = IDXRES(IDX)
29012          AMASS  = PHKK(5,IDX)
29013          PE     = PHKK(4,IDX)
29014          PX     = PHKK(1,IDX)
29015          PY     = PHKK(2,IDX)
29016          PZ     = PHKK(3,IDX)
29017          PT2    = PX**2+PY**2
29018          PT     = SQRT(PT2)
29019          PTOT   = SQRT(PT2+PZ**2)
29020          SINTHE = PT/MAX(PTOT,TINY14)
29021          COSTHE = PZ/MAX(PTOT,TINY14)
29022          IF (COSTHE.GT.ONE) THEN
29023             THETA = ZERO
29024          ELSEIF (COSTHE.LT.-ONE) THEN
29025             THETA = TWOPI/2.0D0
29026          ELSE
29027             THETA  = ACOS(COSTHE)
29028          ENDIF
29029          EKIN   = PE-AMASS
29030 **sr 15.4.96 new E_t-definition
29031 C        ET     = PE*SINTHE
29032          ET     = EKIN*SINTHE
29033 **
29034          IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
29035             ETA = -LOG(TAN(THETA/TWO))
29036          ELSE
29037             ETA = 100.0D0
29038          ENDIF
29039          THETA  = THETA/BOG
29040          LRNL   = .TRUE.
29041       ENDIF
29042
29043  9999 CONTINUE
29044       RETURN
29045       END
29046
29047 *$ CREATE DT_HIMULT.FOR
29048 *COPY DT_HIMULT
29049 *
29050 *===himult=============================================================*
29051 *
29052       SUBROUTINE DT_HIMULT(MODE)
29053
29054 ************************************************************************
29055 * Tables of average energies/multiplicities.                           *
29056 * This version dated 30.08.2000 is written by S. Roesler               *
29057 ************************************************************************
29058
29059       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29060       SAVE
29061       PARAMETER ( LINP = 10 ,
29062      &            LOUT = 6 ,
29063      &            LDAT = 9 )
29064       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29065
29066       PARAMETER (SWMEXP=1.7D0)
29067
29068       CHARACTER*8 ANAMEH(4)
29069
29070 * particle properties (BAMJET index convention)
29071       CHARACTER*8  ANAME
29072       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29073      &                IICH(210),IIBAR(210),K1(210),K2(210)
29074 * temporary storage for one final state particle
29075       LOGICAL LFRAG,LGREY,LBLACK
29076       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29077      &                SINTHE,COSTHE,THETA,THECMS,
29078      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29079      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29080      &                LFRAG,LGREY,LBLACK
29081 * event flag used for histograms
29082       COMMON /DTNORM/ ICEVT,IEVHKK
29083 * Lorentz-parameters of the current interaction
29084       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
29085      &                UMO,PPCM,EPROJ,PPROJ
29086
29087       PARAMETER (NOPART=210)
29088       DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
29089      &          AVPT(4,NOPART),IAVPT(4,NOPART)
29090       DATA ANAMEH /'DEUTERON','3-H     ','3-HE    ','4-HE    '/
29091
29092       GOTO (1,2,3) MODE
29093
29094 *------------------------------------------------------------------
29095 * initialization
29096     1 CONTINUE
29097       DO 10 I=1,NOPART
29098          DO 11 J=1,4
29099             AVMULT(J,I) = ZERO
29100             AVE(J,I)    = ZERO
29101             AVSWM(J,I)  = ZERO
29102             AVPT(J,I)   = ZERO
29103             IAVPT(J,I)  = 0
29104    11    CONTINUE
29105    10 CONTINUE
29106
29107       RETURN
29108
29109 *------------------------------------------------------------------
29110 * filling of histogram with event-record
29111     2 CONTINUE
29112       IF (PE.LT.0.0D0) THEN
29113          WRITE(LOUT,*) ' HIMULT:  PE < 0 ! ',PE
29114          RETURN
29115       ENDIF
29116       IF (.NOT.LFRAG) THEN
29117          IVEL = 2
29118          IF (LGREY)  IVEL = 3
29119          IF (LBLACK) IVEL = 4
29120          AVE(1,IDBJT)       = AVE(1,IDBJT)   +PE
29121          AVE(IVEL,IDBJT)    = AVE(IVEL,IDBJT)+PE
29122          AVPT(1,IDBJT)     = AVPT(1,IDBJT)   +PT
29123          AVPT(IVEL,IDBJT)  = AVPT(IVEL,IDBJT)+PT
29124          IAVPT(1,IDBJT)    = IAVPT(1,IDBJT)   +1
29125          IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
29126          AVSWM(1,IDBJT)     = AVSWM(1,IDBJT)   +PE**SWMEXP
29127          AVSWM(IVEL,IDBJT)  = AVSWM(IVEL,IDBJT)+PE**SWMEXP
29128          AVMULT(1,IDBJT)    = AVMULT(1,IDBJT)   +ONE
29129          AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
29130          IF (IDBJT.LT.116) THEN
29131 *   total energy, multiplicity
29132             AVE(1,30)       = AVE(1,30)   +PE
29133             AVE(IVEL,30)    = AVE(IVEL,30)+PE
29134             AVPT(1,30)     = AVPT(1,30)   +PT
29135             AVPT(IVEL,30)  = AVPT(IVEL,30)+PT
29136             IAVPT(1,30)    = IAVPT(1,30)   +1
29137             IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
29138             AVSWM(1,30)     = AVSWM(1,30)+PE**SWMEXP
29139             AVSWM(IVEL,30)  = AVSWM(IVEL,30)+PE**SWMEXP
29140             AVMULT(1,30)    = AVMULT(1,30)   +ONE
29141             AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
29142 *   charged energy, multiplicity
29143             IF (ICHAR.LT.0) THEN
29144                AVE(1,26)       = AVE(1,26)   +PE
29145                AVE(IVEL,26)    = AVE(IVEL,26)+PE
29146                AVPT(1,26)     = AVPT(1,26)   +PT
29147                AVPT(IVEL,26)  = AVPT(IVEL,26)+PT
29148                IAVPT(1,26)    = IAVPT(1,26)   +1
29149                IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
29150                AVSWM(1,26)     = AVSWM(1,26)   +PE**SWMEXP
29151                AVSWM(IVEL,26)  = AVSWM(IVEL,26)+PE**SWMEXP
29152                AVMULT(1,26)    = AVMULT(1,26)   +ONE
29153                AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
29154             ENDIF
29155             IF (ICHAR.NE.0) THEN
29156                AVE(1,27)       = AVE(1,27)   +PE
29157                AVE(IVEL,27)    = AVE(IVEL,27)+PE
29158                AVPT(1,27)     = AVPT(1,27)   +PT
29159                AVPT(IVEL,27)  = AVPT(IVEL,27)+PT
29160                IAVPT(1,27)    = IAVPT(1,27)   +1
29161                IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
29162                AVSWM(1,27)     = AVSWM(1,27)   +PE**SWMEXP
29163                AVSWM(IVEL,27)  = AVSWM(IVEL,27)+PE**SWMEXP
29164                AVMULT(1,27)    = AVMULT(1,27)   +ONE
29165                AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
29166             ENDIF
29167          ENDIF
29168       ENDIF
29169
29170       RETURN
29171
29172 *------------------------------------------------------------------
29173 * output
29174     3 CONTINUE
29175       WRITE(LOUT,3000)
29176  3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
29177      &       29X,'---------------------',/)
29178       IF (MULDEF.EQ.1) THEN
29179          WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
29180       ELSE
29181          BETGRE = 0.7D0
29182          BETBLC = 0.23D0
29183          WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
29184  3002    FORMAT(1X,'fast:  beta > ',F4.2,'    grey:  ',F4.2,' > beta > '
29185      &          ,F4.2,'    black:  beta < ',F4.2,/)
29186       ENDIF
29187       WRITE(LOUT,3003) SWMEXP
29188  3003 FORMAT(1X,'particle    |',12X,'average multiplicity',/,
29189      &      13X,'|     total         fast',
29190 C    &      '       grey     black      K      f(',F3.1,')',/,1X,
29191      &      '       grey     black    <pt>     f(',F3.1,')',/,1X,
29192      &      '------------+--------------',
29193      &      '-------------------------------------------------')
29194       DO 30 I=1,NOPART
29195          DO 31 J=1,4
29196             AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
29197             AVE(J,I)    = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
29198             AVPT(J,I)   = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
29199             AVSWM(J,I)  = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
29200    31    CONTINUE
29201          IF (I.LE.115) THEN
29202             WRITE(LOUT,3004) ANAME(I),I,
29203      &                       AVMULT(1,I),AVMULT(2,I),
29204      &                       AVMULT(3,I),AVMULT(4,I),
29205 C    &                       AVE(1,I),AVSWM(1,I)
29206      &                       AVPT(1,I),AVSWM(1,I)
29207          ELSEIF (I.LE.119) THEN
29208             WRITE(LOUT,3004) ANAMEH(I-115),I,
29209      &                       AVMULT(1,I),AVMULT(2,I),
29210      &                       AVMULT(3,I),AVMULT(4,I),
29211 C    &                       AVE(1,I),AVSWM(1,I)
29212      &                       AVPT(1,I),AVSWM(1,I)
29213          ENDIF
29214  3004    FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
29215    30 CONTINUE
29216 **temporary
29217 C     WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
29218 C    &               AVMULT(3,27)+AVMULT(4,27)
29219 **
29220
29221       RETURN
29222       END
29223
29224 *$ CREATE DT_HISTAT.FOR
29225 *COPY DT_HISTAT
29226 *
29227 *===histat=============================================================*
29228 *
29229       SUBROUTINE DT_HISTAT(IDX,MODE)
29230
29231 ************************************************************************
29232 * This version dated 26.02.96 is written by S. Roesler                 *
29233 *                                                                      *
29234 * Last change 27.12.2006 by S. Roesler.                                *
29235 ************************************************************************
29236
29237       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29238       SAVE
29239       PARAMETER ( LINP = 10 ,
29240      &            LOUT = 6 ,
29241      &            LDAT = 9 )
29242       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29243       PARAMETER (NDIM=199)
29244
29245 * event history
29246       PARAMETER (NMXHKK=200000)
29247       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
29248      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
29249      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
29250 * extended event history
29251       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
29252      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
29253      &                IHIST(2,NMXHKK)
29254 * particle properties (BAMJET index convention)
29255       CHARACTER*8  ANAME
29256       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29257      &                IICH(210),IIBAR(210),K1(210),K2(210)
29258       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
29259 * Glauber formalism: cross sections
29260       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
29261      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
29262      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
29263      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
29264      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
29265      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
29266      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
29267      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
29268      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
29269      &                BSLOPE,NEBINI,NQBINI
29270 * emulsion treatment
29271       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
29272      &                NCOMPO,IEMUL
29273 * properties of interacting particles
29274       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
29275 * rejection counter
29276       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
29277      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
29278      &                IREXCI(3),IRDIFF(2),IRINC
29279 * statistics: residual nuclei
29280       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
29281      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
29282      &                NINCST(2,4),NINCEV(2),
29283      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
29284      &                NRESPB(2),NRESCH(2),NRESEV(4),
29285      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
29286      &                NEVAFI(2,2)
29287 * parameter for intranuclear cascade
29288       LOGICAL LPAULI
29289       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
29290 * (original name: PAREVT)
29291       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
29292      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
29293       PARAMETER ( NALLWP = 39   )
29294       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
29295      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
29296      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
29297      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
29298 * (original name: FRBKCM)
29299       PARAMETER ( MXFFBK =     6 )
29300       PARAMETER ( MXZFBK =     9 )
29301       PARAMETER ( MXNFBK =    10 )
29302       PARAMETER ( MXAFBK =    16 )
29303       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
29304       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
29305       PARAMETER ( NXAFBK = MXAFBK + 1 )
29306       PARAMETER ( MXPSST =   300 )
29307       PARAMETER ( MXPSFB = 41000 )
29308       LOGICAL LFRMBK, LNCMSS
29309       COMMON /FKFRBK/  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
29310      &          EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
29311      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
29312      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
29313      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
29314      &          IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
29315      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
29316      &          IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
29317      &          IFBFRB, NBUFBK, LFRMBK, LNCMSS
29318 * (original name: INPFLG)
29319       COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
29320 * temporary storage for one final state particle
29321       LOGICAL LFRAG,LGREY,LBLACK
29322       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29323      &                SINTHE,COSTHE,THETA,THECMS,
29324      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29325      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29326      &                LFRAG,LGREY,LBLACK
29327 * event flag used for histograms
29328       COMMON /DTNORM/ ICEVT,IEVHKK
29329 * statistics: double-Pomeron exchange
29330       COMMON /DTFLG2/ INTFLG,IPOPO
29331
29332       DIMENSION EMUSAM(NCOMPX)
29333
29334       CHARACTER*13 CMSG(3)
29335       DATA CMSG /'not requested','not requested','not requested'/
29336
29337       GOTO (1,2,3,4,5) MODE
29338
29339 *------------------------------------------------------------------
29340 * initialization
29341     1 CONTINUE
29342 *  emulsion treatment
29343       IF (NCOMPO.GT.0) THEN
29344          DO 10 I=1,NCOMPX
29345             EMUSAM(I) = ZERO
29346    10    CONTINUE
29347       ENDIF
29348 * common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
29349       NINCGE = 0
29350       DO 11 I=1,2
29351          EXCDPM(I)   = ZERO
29352          EXCDPM(I+2) = ZERO
29353          EXCEVA(I)   = ZERO
29354          NINCWO(I)   = 0
29355          NINCEV(I)   = 0
29356          NRESTO(I)   = 0
29357          NRESPR(I)   = 0
29358          NRESNU(I)   = 0
29359          NRESBA(I)   = 0
29360          NRESPB(I)   = 0
29361          NRESCH(I)   = 0
29362          NRESEV(I)   = 0
29363          NRESEV(I+2) = 0
29364          NEVAGA(I)   = 0
29365          NEVAHT(I)   = 0
29366          NEVAFI(1,I) = 0
29367          NEVAFI(2,I) = 0
29368          DO 12 J=1,6
29369             IF (J.LE.2) NINCHR(I,J) = 0
29370             IF (J.LE.3) NINCCO(I,J) = 0
29371             IF (J.LE.4) NINCST(I,J) = 0
29372             NEVA(I,J) = 0
29373    12    CONTINUE
29374          DO 13 J=1,210
29375             NEVAHY(1,I,J) = 0
29376             NEVAHY(2,I,J) = 0
29377    13    CONTINUE
29378    11 CONTINUE
29379       MAXGEN = 0
29380 **dble Po statistics.
29381       KPOPO = 0
29382
29383       RETURN
29384 *------------------------------------------------------------------
29385 * filling of histogram with event-record
29386     2 CONTINUE
29387       IF (IST.EQ.-1) THEN
29388          IF (.NOT.LFRAG) THEN
29389             IF (IDPDG.EQ.2212) THEN
29390                NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
29391             ELSEIF (IDPDG.EQ.2112) THEN
29392                NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
29393             ELSEIF (IDPDG.EQ.22) THEN
29394                NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
29395             ELSEIF (IDPDG.EQ.80000) THEN
29396                IF (IDBJT.EQ.116) THEN
29397                   NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
29398                ELSEIF (IDBJT.EQ.117) THEN
29399                   NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
29400                ELSEIF (IDBJT.EQ.118) THEN
29401                   NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
29402                ELSEIF (IDBJT.EQ.119) THEN
29403                   NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
29404                ENDIF
29405             ENDIF
29406          ELSE
29407 *   heavy fragments (here: fission products only)
29408             NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
29409             NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
29410             NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29411          ENDIF
29412       ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
29413          IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
29414       ENDIF
29415
29416       RETURN
29417 *------------------------------------------------------------------
29418 * output
29419     3 CONTINUE
29420
29421 **dble Po statistics.
29422 C     WRITE(LOUT,'(1X,A,2I7,2E12.4)')
29423 C    &   '# evts. / # dble-Po. evts / s_in / s_popo :',
29424 C    & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
29425
29426 *  emulsion treatment
29427       IF (NCOMPO.GT.0) THEN
29428          WRITE(LOUT,3000)
29429  3000    FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
29430      &          22X,'----------------------------',/,/,19X,
29431      &          'mass    charge          fraction',/,39X,
29432      &          'input     treated',/)
29433          DO 30 I=1,NCOMPO
29434             WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
29435      &                       EMUSAM(I)/DBLE(ICEVT)
29436  3013       FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
29437    30    CONTINUE
29438       ENDIF
29439
29440 *  i.n.c. statistics: output
29441       WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
29442  3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
29443      &       22X,'---------------------------------',/,/,1X,
29444      &       'no. of events for normalization: (accepted final events,',
29445      &       ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
29446      &       /,1X,'no. of rejected events due to intranuclear',
29447      &       ' cascade',15X,I6,/)
29448       ICEV  = MAX(ICEVT,1)
29449       ICEV1 = ICEV
29450       IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
29451       WRITE(LOUT,3002)
29452      &     (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
29453      &     ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
29454      &     KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
29455      &    (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29456      &     (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
29457      &     (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29458      &     (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
29459  3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
29460      &       5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
29461      &       ' proj./ target (mean per evt)',/,8X,'baryons:  pos. ',
29462      &       F7.3,' /',F7.3,'   neg. ',F7.3,' /',F7.3,/,8X,
29463      &       'mesons:   pos. ',F7.3,' /',F7.3,'   neg. ',F7.3,' /',F7.3,
29464      &       /,1X,'maximum no. of generations treated (maximum allowed:'
29465      &       ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
29466      &       ' interactions in proj./ target (mean per evt1)',
29467      &       F7.3,' /',F7.3,/,8X,'out of which by inelastic',
29468      &       ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
29469      &       'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
29470      &       '(ap, K-, pi- only)     ',F7.3,' /',F7.3,/)
29471       WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
29472      &                 IREXCI(1)+IREXCI(2)+IREXCI(3)
29473  3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
29474      &       'evaporation',/,22X,'-----------------------------',
29475      &       '------------',/,/,1X,'no. of events for normal.: ',
29476      &       '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
29477      &       ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
29478      &       ' rejected events     (',I4,',',I4,',',I4,')',22X,I6,/)
29479
29480       WRITE(LOUT,3004)
29481  3004 FORMAT(/,22X,'1) before evaporation-step:',/)
29482       ICEV  = MAX(NRESEV(2),1)
29483       WRITE(LOUT,3005)
29484      &     (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
29485      &     (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
29486      &     (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
29487      &     (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
29488      &     (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
29489      &     (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
29490      &     (EXCDPM(I)/DBLE(ICEV),I=1,2),
29491      &     (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
29492  3005    FORMAT(1X,'residual nuclei:  (mean values per evt)',12X,
29493      &       'proj. / target',/,/,8X,'total number of particles',15X,
29494      &       2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29495      &       'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
29496      &       'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
29497      &       /,8X,'excitation energy (bef. evap.-step)   ',2E11.3,/,
29498      &       8X,'excitation energy per nucleon         ',2E11.3,/,/)
29499
29500 * evaporation / fission / fragmentation statistics: output
29501       ICEV  = MAX(NRESEV(2),1)
29502       ICEV1 = MAX(NRESEV(4),1)
29503       NTEVA1 =
29504      &   NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
29505       NTEVA2 =
29506      &   NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
29507       IF (LEVPRT) THEN
29508          IF (IFISS.EQ.1) CMSG(1) = 'requested    '
29509          IF (LFRMBK)     CMSG(2) = 'requested    '
29510          IF (LDEEXG)     CMSG(3) = 'requested    '
29511          WRITE(LOUT,3006)
29512      &        CMSG,
29513      &        DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
29514      &        (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
29515      &        (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
29516      &        (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
29517      &        (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
29518      &        (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
29519      &        (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
29520      &        (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
29521      &        (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
29522  3006    FORMAT(22X,'2) after  evaporation-step:',/,/,1X,'Fission:',
29523      &       13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
29524      &       'deexcitation:',2X,A13,/,/,
29525      &       1X,'evaporation/deexcitation:  (mean values per evt1)  ',
29526      &       'proj. / target',/,/,8X,'total number of evap. particles',
29527      &       9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29528      &       'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
29529      &       '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
29530      &       2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
29531      &       'heavy fragments',25X,2F9.3,/)
29532          IF (IFISS.EQ.1) THEN
29533             WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
29534      &                       NEVAFI(2,1),NEVAFI(2,2),
29535      &             DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
29536      &             DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
29537  3007       FORMAT(1X,'Fission:   total number of events',14X,2I9,/
29538      &             12X,'out of which fission occured',8X,2I9,/,
29539      &             50X,'(',F5.2,'%) (',F5.2,'%)',/)
29540          ENDIF
29541 C        IF ((LFRMBK).OR.(IFISS.EQ.1)) THEN
29542 C           WRITE(LOUT,3008)
29543 C3008       FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
29544 C    &             '       proj.   / target',/)
29545 C           DO 31 I=1,210
29546 C              IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
29547 C                 WRITE(LOUT,3009) I,
29548 C    &            (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29549 C3009             FORMAT(38X,I3,3X,2E12.3)
29550 C              ENDIF
29551 C  31       CONTINUE
29552 C           WRITE(LOUT,3010)
29553 C3010       FORMAT(1X,'heavy fragments - statistics:',7X,'mass  ',
29554 C    &             '       proj.   / target',/)
29555 C           DO 32 I=1,210
29556 C              IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
29557 C                 WRITE(LOUT,3011) I,
29558 C    &            (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29559 C3011             FORMAT(38X,I3,3X,2E12.3)
29560 C              ENDIF
29561 C  32       CONTINUE
29562 C           WRITE(LOUT,*)
29563 C        ENDIF
29564       ELSE
29565          WRITE(LOUT,3012)
29566  3012    FORMAT(22X,'2) after  evaporation-step:',/,/,1X,
29567      &       'Evaporation:         not requested',/)
29568       ENDIF
29569
29570       RETURN
29571 *------------------------------------------------------------------
29572 * filling of histogram with event-record
29573     4 CONTINUE
29574 *  emulsion treatment
29575       IF (NCOMPO.GT.0) THEN
29576          DO 40 I=1,NCOMPO
29577             IF (IT.EQ.IEMUMA(I)) THEN
29578                EMUSAM(I) = EMUSAM(I)+ONE
29579             ENDIF
29580    40    CONTINUE
29581       ENDIF
29582       NINCGE = NINCGE+MAXGEN
29583       MAXGEN = 0
29584 **dble Po statistics.
29585       IF (IPOPO.EQ.1) KPOPO = KPOPO+1
29586
29587       RETURN
29588 *------------------------------------------------------------------
29589 * filling of histogram with event-record
29590     5 CONTINUE
29591       IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
29592          IB = IIBAR(IDBAM(IDX))
29593          IC = IICH(IDBAM(IDX))
29594          J  = ISTHKK(IDX)-14
29595          IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
29596             NINCST(J,1) = NINCST(J,1)+1
29597          ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
29598             NINCST(J,2) = NINCST(J,2)+1
29599          ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
29600             NINCST(J,3) = NINCST(J,3)+1
29601          ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
29602             NINCST(J,4) = NINCST(J,4)+1
29603          ENDIF
29604       ELSEIF (ISTHKK(IDX).EQ.17) THEN
29605          NINCWO(1) = NINCWO(1)+1
29606       ELSEIF (ISTHKK(IDX).EQ.18) THEN
29607          NINCWO(2) = NINCWO(2)+1
29608       ELSEIF (ISTHKK(IDX).EQ.1001) THEN
29609          IB = IDRES(IDX)
29610          IC = IDXRES(IDX)
29611          IF (IC.GT.0) THEN
29612             NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
29613             NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
29614          ENDIF
29615          NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29616       ENDIF
29617
29618       RETURN
29619       END
29620
29621 *$ CREATE DT_NEWHGR.FOR
29622 *COPY DT_NEWHGR
29623 *
29624 *===newhgr=============================================================*
29625 *
29626       SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
29627
29628 ************************************************************************
29629 *                                                                      *
29630 *     Histogram initialization.                                        *
29631 *                                                                      *
29632 *     input:  XLIM1/XLIM2  lower/upper edge of histogram-window        *
29633 *             XLIM3        bin size                                    *
29634 *             IBIN    > 0  number of bins in equidistant lin. binning  *
29635 *                     = -1 reset histograms                            *
29636 *                     < -1 |IBIN| number of bins in equidistant log.   *
29637 *                          binning or log. binning in user def. struc. *
29638 *             XLIMB(*)     user defined bin structure                  *
29639 *                                                                      *
29640 *     The bin structure is sensitive to                                *
29641 *             XLIM1, XLIM3, IBIN     if     XLIM3 > 0   (lin.)         *
29642 *             XLIM1, XLIM2, IBIN     if     XLIM3 = 0   (lin. & log.)  *
29643 *             XLIMB, IBIN            if     XLIM3 < 0                  *
29644 *                                                                      *
29645 *                                                                      *
29646 *     output: IREFN        histogram index                             *
29647 *                          (= -1 for inconsistent histogr. request)    *
29648 *                                                                      *
29649 * This subroutine is based on a original version by R. Engel.          *
29650 * This version dated 22.4.95 is written  by S. Roesler.                *
29651 ************************************************************************
29652
29653       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29654       SAVE
29655       PARAMETER ( LINP = 10 ,
29656      &            LOUT = 6 ,
29657      &            LDAT = 9 )
29658
29659       LOGICAL LSTART
29660
29661       PARAMETER (ZERO   =  0.0D0,
29662      &           TINY   =  1.0D-10)
29663
29664       DIMENSION XLIMB(*)
29665
29666 * histograms
29667       PARAMETER (NHIS=150, NDIM=250)
29668       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29669      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29670 * auxiliary common for histograms
29671       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29672
29673       DATA LSTART /.TRUE./
29674
29675 * reset histogram counter
29676       IF (LSTART.OR.(IBIN.EQ.-1)) THEN
29677          IHISL  = 0
29678          IF (IBIN.EQ.-1) RETURN
29679          LSTART = .FALSE.
29680       ENDIF
29681
29682       IHIS  = IHISL+1
29683 * check for maximum number of allowed histograms
29684       IF (IHIS.GT.NHIS) THEN
29685          WRITE(LOUT,1003) IHIS,NHIS,IHIS
29686  1003    FORMAT(1X,'NEWHGR:   warning!  number of histograms (',
29687      &          I4,') exceeds array size (',I4,')',/,21X,
29688      &          'histogram',I3,' skipped!')
29689          GOTO 9999
29690       ENDIF
29691
29692       IREFN = IHIS
29693       IBINS(IHIS) = ABS(IBIN)
29694 * check requested number of bins
29695       IF (IBINS(IHIS).GE.NDIM) THEN
29696          WRITE(LOUT,1000) IBIN,NDIM,NDIM
29697  1000    FORMAT(1X,'NEWHGR:   warning!  number of bins (',
29698      &          I3,') exceeds array size (',I3,')',/,21X,
29699      &          'and will be reset to ',I3)
29700          IBINS(IHIS) = NDIM
29701       ENDIF
29702       IF (IBINS(IHIS).EQ.0) THEN
29703          WRITE(LOUT,1001) IBIN,IHIS
29704  1001    FORMAT(1X,'NEWHGR:   warning!  inconsistent number of',
29705      &          ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
29706          GOTO 9999
29707       ENDIF
29708
29709 * initialize arrays
29710       DO 1 I=1,NDIM
29711          DO 2 K=1,3
29712             HIST(K,IHIS,I)   = ZERO
29713             HIST(K+3,IHIS,I) = ZERO
29714             TMPHIS(K,IHIS,I) = ZERO
29715     2    CONTINUE
29716          HIST(7,IHIS,I)   = ZERO
29717     1 CONTINUE
29718       DENTRY(1,IHIS)= ZERO
29719       DENTRY(2,IHIS)= ZERO
29720       OVERF(IHIS)   = ZERO
29721       UNDERF(IHIS)  = ZERO
29722       TMPUFL(IHIS)  = ZERO
29723       TMPOFL(IHIS)  = ZERO
29724
29725 * bin str. sensitive to lower edge, bin size, and numb. of bins
29726       IF (XLIM3.GT.ZERO) THEN
29727          DO 3 K=1,IBINS(IHIS)+1
29728             HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
29729     3    CONTINUE
29730          ISWI(IHIS) = 1
29731 * bin str. sensitive to lower/upper edge and numb. of bins
29732       ELSEIF (XLIM3.EQ.ZERO) THEN
29733 *   linear binning
29734          IF (IBIN.GT.0) THEN
29735             XLOW = XLIM1
29736             XHI  = XLIM2
29737             IF (XLIM2.LE.XLIM1) THEN
29738                WRITE(LOUT,1002) XLIM1,XLIM2
29739  1002          FORMAT(1X,'NEWHGR:   warning!  inconsistent x-range',
29740      &                /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29741                GOTO 9999
29742             ENDIF
29743             ISWI(IHIS) = 1
29744          ELSEIF (IBIN.LT.-1) THEN
29745 *   logarithmic binning
29746             IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
29747                WRITE(LOUT,1004) XLIM1,XLIM2
29748  1004          FORMAT(1X,'NEWHGR:   warning!  inconsistent log. ',
29749      &                'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29750                GOTO 9999
29751             ENDIF
29752             IF (XLIM2.LE.XLIM1) THEN
29753                WRITE(LOUT,1005) XLIM1,XLIM2
29754  1005          FORMAT(1X,'NEWHGR:   warning!  inconsistent x-range',
29755      &                /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29756                GOTO 9999
29757             ENDIF
29758             XLOW = LOG10(XLIM1)
29759             XHI  = LOG10(XLIM2)
29760             ISWI(IHIS) = 3
29761          ENDIF
29762          DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
29763          DO 4 K=1,IBINS(IHIS)+1
29764             HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
29765     4    CONTINUE
29766       ELSE
29767 * user defined bin structure
29768          DO 5 K=1,IBINS(IHIS)+1
29769             IF (IBIN.GT.0) THEN
29770                HIST(1,IHIS,K) = XLIMB(K)
29771                ISWI(IHIS) = 2
29772             ELSEIF (IBIN.LT.-1) THEN
29773                HIST(1,IHIS,K) = LOG10(XLIMB(K))
29774                ISWI(IHIS) = 4
29775             ENDIF
29776     5    CONTINUE
29777       ENDIF
29778
29779 * histogram accepted
29780       IHISL = IHIS
29781
29782       RETURN
29783
29784  9999 CONTINUE
29785       IREFN = -1
29786       RETURN
29787       END
29788
29789 *$ CREATE DT_FILHGR.FOR
29790 *COPY DT_FILHGR
29791 *
29792 *===filhgr=============================================================*
29793 *
29794       SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
29795
29796 ************************************************************************
29797 *                                                                      *
29798 *     Scoring for histogram IHIS.                                      *
29799 *                                                                      *
29800 * This subroutine is based on a original version by R. Engel.          *
29801 * This version dated 23.4.95 is written  by S. Roesler.                *
29802 ************************************************************************
29803
29804       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29805       SAVE
29806       PARAMETER ( LINP = 10 ,
29807      &            LOUT = 6 ,
29808      &            LDAT = 9 )
29809
29810       PARAMETER (ZERO = 0.0D0,
29811      &           ONE  = 1.0D0,
29812      &           TINY = 1.0D-10)
29813
29814 * histograms
29815       PARAMETER (NHIS=150, NDIM=250)
29816       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29817      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29818 * auxiliary common for histograms
29819       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29820
29821       DATA NCEVT /1/
29822
29823       X = XI
29824       Y = YI
29825
29826 * dump content of temorary arrays into histograms
29827       IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
29828          CALL DT_EVTHIS(IDUM)
29829          NCEVT = NEVT
29830       ENDIF
29831
29832 * check histogram index
29833       IF (IHIS.EQ.-1) RETURN
29834       IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
29835 C        WRITE(LOUT,1000) IHIS,IHISL
29836  1000    FORMAT(1X,'FILHGR:   warning!  histogram index',I4,
29837      &          ' out of range (1..',I3,')')
29838          RETURN
29839       ENDIF
29840
29841       IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
29842 * bin structure not explicitly given
29843          IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
29844          DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
29845          IF (X.LT.HIST(1,IHIS,1)) THEN
29846             I1 = 0
29847          ELSE
29848             I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
29849          ENDIF
29850
29851       ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
29852 * user defined bin structure
29853          IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
29854          IF (X.LT.HIST(1,IHIS,1)) THEN
29855             I1 = 0
29856          ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
29857             I1 = IBINS(IHIS)+1
29858          ELSE
29859 *   binary sort algorithm
29860             KMIN = 0
29861             KMAX = IBINS(IHIS)+1
29862     1       CONTINUE
29863             IF ((KMAX-KMIN).EQ.1) GOTO 2
29864             KK = (KMAX+KMIN)/2
29865             IF (X.LE.HIST(1,IHIS,KK)) THEN
29866                KMAX=KK
29867             ELSE
29868                KMIN=KK
29869             ENDIF
29870             GOTO 1
29871     2       CONTINUE
29872             I1 = KMIN
29873          ENDIF
29874
29875       ELSE
29876          WRITE(LOUT,1001)
29877  1001    FORMAT(1X,'FILHGR:   warning!  histogram not initialized')
29878          RETURN
29879       ENDIF
29880
29881 * scoring
29882       IF (I1.LE.0) THEN
29883          TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
29884       ELSEIF (I1.LE.IBINS(IHIS)) THEN
29885          TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
29886          IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
29887             TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
29888          ELSE
29889             TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
29890          ENDIF
29891          TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
29892       ELSE
29893          TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
29894       ENDIF
29895
29896       RETURN
29897       END
29898
29899 *$ CREATE DT_EVTHIS.FOR
29900 *COPY DT_EVTHIS
29901 *
29902 *===evthis=============================================================*
29903 *
29904       SUBROUTINE DT_EVTHIS(NEVT)
29905
29906 ************************************************************************
29907 * Dump content of temorary histograms into /DTHIS1/. This subroutine   *
29908 * is called after each event and for the last event before any call    *
29909 * to OUTHGR.                                                           *
29910 *         NEVT   number of events dumped, this is only needed to       *
29911 *                get the normalization after the last event            *
29912 * This version dated 23.4.95 is written  by S. Roesler.                *
29913 ************************************************************************
29914
29915       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29916       SAVE
29917       PARAMETER ( LINP = 10 ,
29918      &            LOUT = 6 ,
29919      &            LDAT = 9 )
29920
29921       LOGICAL LNOETY
29922
29923       PARAMETER (ZERO = 0.0D0,
29924      &           ONE  = 1.0D0,
29925      &           TINY = 1.0D-10)
29926
29927 * histograms
29928       PARAMETER (NHIS=150, NDIM=250)
29929       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29930      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29931 * auxiliary common for histograms
29932       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29933
29934       DATA NCEVT /0/
29935
29936       NCEVT = NCEVT+1
29937       NEVT  = NCEVT
29938
29939       DO 1 I=1,IHISL
29940          LNOETY = .TRUE.
29941          DO 2 J=1,IBINS(I)
29942             IF (TMPHIS(1,I,J).GT.ZERO) THEN
29943                LNOETY = .FALSE.
29944                HIST(2,I,J)   = HIST(2,I,J)+ONE
29945                HIST(7,I,J)   = HIST(7,I,J)+TMPHIS(1,I,J)
29946                DENTRY(2,I)   = DENTRY(2,I)+TMPHIS(1,I,J)
29947                AVX           = TMPHIS(2,I,J)/TMPHIS(1,I,J)
29948                HIST(3,I,J)   = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
29949                HIST(4,I,J)   = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
29950                HIST(5,I,J)   = HIST(5,I,J)+TMPHIS(3,I,J)
29951                HIST(6,I,J)   = HIST(6,I,J)+TMPHIS(3,I,J)**2
29952                TMPHIS(1,I,J) = ZERO
29953                TMPHIS(2,I,J) = ZERO
29954                TMPHIS(3,I,J) = ZERO
29955             ENDIF
29956     2    CONTINUE
29957          IF (LNOETY) THEN
29958             IF (TMPUFL(I).GT.ZERO) THEN
29959                UNDERF(I) = UNDERF(I)+ONE
29960                TMPUFL(I) = ZERO
29961             ELSEIF (TMPOFL(I).GT.ZERO) THEN
29962                OVERF(I)  = OVERF(I)+ONE
29963                TMPOFL(I) = ZERO
29964             ENDIF
29965          ELSE
29966             DENTRY(1,I) = DENTRY(1,I)+ONE
29967          ENDIF
29968     1 CONTINUE
29969
29970       RETURN
29971       END
29972
29973 *$ CREATE DT_OUTHGR.FOR
29974 *COPY DT_OUTHGR
29975 *
29976 *===outhgr=============================================================*
29977 *
29978       SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
29979      &                  ILOGY,INORM,NMODE)
29980
29981 ************************************************************************
29982 *                                                                      *
29983 *     Plot histogram(s) to standard output unit                        *
29984 *                                                                      *
29985 *         I1..6         indices of histograms to be plotted            *
29986 *         CHEAD,IHEAD   header string,integer                          *
29987 *         NEVTS         number of events                               *
29988 *         FAC           scaling factor                                 *
29989 *         ILOGY   = 1   logarithmic y-axis                             *
29990 *         INORM         normalization                                  *
29991 *                 = 0   no further normalization (FAC is obsolete)     *
29992 *                 = 1   per event and bin width                        *
29993 *                 = 2   per entry and bin width                        *
29994 *                 = 3   per bin entry                                  *
29995 *                 = 4   per event and "bin width" x1^2...x2^2          *
29996 *                 = 5   per event and "log. bin width" ln x1..ln x2    *
29997 *                 = 6   per event                                      *
29998 *         MODE    = 0   no output but normalization applied            *
29999 *                 = 1   all valid histograms separately (small frame)  *
30000 *                       all valid histograms separately (small frame)  *
30001 *                 = -1  and tables as histograms                       *
30002 *                 = 2   all valid histograms (one plot, wide frame)    *
30003 *                       all valid histograms (one plot, wide frame)    *
30004 *                 = -2  and tables as histograms                       *
30005 *                                                                      *
30006 *                                                                      *
30007 *     Note: All histograms to be plotted with one call to this         *
30008 *           subroutine and |MODE|=2 must have the same bin structure!  *
30009 *           There is no test included ensuring this fact.              *
30010 *                                                                      *
30011 * This version dated 23.4.95 is written  by S. Roesler.                *
30012 ************************************************************************
30013
30014       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30015       SAVE
30016       PARAMETER ( LINP = 10 ,
30017      &            LOUT = 6 ,
30018      &            LDAT = 9 )
30019
30020       CHARACTER*72 CHEAD
30021
30022       PARAMETER (ZERO   =  0.0D0,
30023      &           IZERO  =  0,
30024      &           ONE    =  1.0D0,
30025      &           TWO    =  2.0D0,
30026      &           OHALF  =  0.5D0,
30027      &           EPS    =  1.0D-5,
30028      &           TINY   =  1.0D-8,
30029      &           SMALL  =  -1.0D8,
30030      &           RLARGE =  1.0D8 )
30031
30032 * histograms
30033       PARAMETER (NHIS=150, NDIM=250)
30034       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30035      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30036
30037       PARAMETER (NDIM2 = 2*NDIM)
30038       DIMENSION XX(NDIM2),YY(NDIM2)
30039
30040       PARAMETER (NHISTO = 6)
30041       DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
30042      &          IDX(NHISTO)
30043
30044       CHARACTER*43 CNORM(0:8)
30045       DATA CNORM /'no further normalization                   ',
30046      &            'per event and bin width                    ',
30047      &            'per entry1 and bin width                   ',
30048      &            'per bin entry                              ',
30049      &            'per event and "bin width" x1^2...x2^2      ',
30050      &            'per event and "log. bin width" ln x1..ln x2',
30051      &            'per event                                  ',
30052      &            'per bin entry1                             ',
30053      &            'per entry2 and bin width                   '/
30054
30055       IDX1(1) = I1
30056       IDX1(2) = I2
30057       IDX1(3) = I3
30058       IDX1(4) = I4
30059       IDX1(5) = I5
30060       IDX1(6) = I6
30061
30062       MODE = NMODE
30063
30064 * initialization if "wide frame" is requested
30065       IF (ABS(MODE).EQ.2) THEN
30066          DO 1 I=1,NHISTO
30067             DO 2 J=1,NDIM
30068                XX1(J,I) = ZERO
30069                YY1(J,I) = ZERO
30070     2       CONTINUE
30071     1    CONTINUE
30072       ENDIF
30073
30074 * plot header
30075       WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
30076
30077 * check histogram indices
30078       NHI = 0
30079       DO 3 I=1,NHISTO
30080          IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
30081             IF (ISWI(IDX1(I)).NE.0) THEN
30082                IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
30083                   WRITE(LOUT,1000)
30084      &                 IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
30085  1000             FORMAT(/,1X,'OUTHGR:   warning!  no entries in',
30086      &                   ' histogram ',I3,/,21X,'underflows:',F10.0,
30087      &                   '   overflows:  ',F10.0)
30088                ELSE
30089                   NHI = NHI+1
30090                   IDX(NHI) = IDX1(I)
30091                ENDIF
30092             ENDIF
30093          ENDIF
30094     3 CONTINUE
30095       IF (NHI.EQ.0) THEN
30096          WRITE(LOUT,1001)
30097  1001    FORMAT(/,1X,'OUTHGR:   warning!  histogram indices not valid')
30098          RETURN
30099       ENDIF
30100
30101 * check normalization request
30102       IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
30103      &     ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
30104      &                        (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
30105      &     (INORM.LT.0).OR.(INORM.GT.8) ) THEN
30106          WRITE(LOUT,1002) NEVTS,INORM,FAC
30107  1002    FORMAT(/,1X,'OUTHGR:   warning!  normalization request not ',
30108      &          'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
30109      &          'FAC = ',E11.4)
30110          RETURN
30111       ENDIF
30112
30113       WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
30114
30115 * apply normalization
30116       DO 4 N=1,NHI
30117
30118          I = IDX(N)
30119
30120          IF (ISWI(I).EQ.1) THEN
30121             WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30122  1003       FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
30123      &             ' to',2X,E10.4,',',2X,I3,' bins')
30124          ELSEIF (ISWI(I).EQ.2) THEN
30125             WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30126             WRITE(LOUT,1007)
30127  1007       FORMAT(1X,'user defined bin structure')
30128          ELSEIF (ISWI(I).EQ.3) THEN
30129             WRITE(LOUT,1004)
30130      &         I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30131  1004       FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
30132      &             ' to',2X,E10.4,',',2X,I3,' bins')
30133          ELSEIF (ISWI(I).EQ.4) THEN
30134             WRITE(LOUT,1004)
30135      &         I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30136             WRITE(LOUT,1007)
30137          ELSE
30138             WRITE(LOUT,1008) ISWI(I)
30139  1008       FORMAT(/,1X,'warning!  inconsistent bin structure flag ',I4)
30140          ENDIF
30141          WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
30142  1005    FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
30143      &          ' overfl.:',F8.0)
30144          WRITE(LOUT,1009) CNORM(INORM)
30145  1009    FORMAT(1X,'normalization: ',A,/)
30146
30147          DO 5 K=1,IBINS(I)
30148             CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
30149             YMEAN = FAC*YMEAN
30150             YERR  = FAC*YERR
30151             WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
30152             WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
30153  1006       FORMAT(1X,5E11.3)
30154 *    small frame
30155             II = 2*K
30156             XX(II-1) = HIST(1,I,K)
30157             XX(II)   = HIST(1,I,K+1)
30158             YY(II-1) = YMEAN
30159             YY(II)   = YMEAN
30160 *    wide frame
30161             XX1(K,N) = XMEAN
30162             IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
30163      &         XX1(K,N) = LOG10(XMEAN)
30164             YY1(K,N) = YMEAN
30165     5    CONTINUE
30166
30167 * plot small frame
30168          IF (ABS(MODE).EQ.1) THEN
30169             IBIN2 = 2*IBINS(I)
30170             WRITE(LOUT,'(/,1X,A)') 'Preview:'
30171             IF(ILOGY.EQ.1) THEN
30172               CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30173             ELSE
30174               CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30175             ENDIF
30176          ENDIF
30177
30178     4 CONTINUE
30179
30180 * plot wide frame
30181       IF (ABS(MODE).EQ.2) THEN
30182          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30183          NSIZE = NDIM*NHISTO
30184          DXLOW = HIST(1,IDX(1),1)
30185          DDX   = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
30186          YLOW  = RLARGE
30187          YHI   = SMALL
30188          DO 6 I=1,NHISTO
30189             DO 7 J=1,NDIM
30190                IF (YY1(J,I).LT.YLOW) THEN
30191                   IF (ILOGY.EQ.1) THEN
30192                      IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
30193                   ELSE
30194                      YLOW = YY1(J,I)
30195                   ENDIF
30196                ENDIF
30197                IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
30198     7       CONTINUE
30199     6    CONTINUE
30200          DY = (YHI-YLOW)/DBLE(NDIM)
30201          IF (DY.LE.ZERO) THEN
30202             WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
30203      &         'OUTHGR:   warning! zero bin width for histograms ',
30204      &         IDX,': ',YLOW,YHI
30205             RETURN
30206          ENDIF
30207          IF (ILOGY.EQ.1) THEN
30208             YLOW = LOG10(YLOW)
30209             DY   = (LOG10(YHI)-YLOW)/100.0D0
30210             DO 8 I=1,NHISTO
30211                DO 9 J=1,NDIM
30212                   IF (YY1(J,I).LE.ZERO) THEN
30213                      YY1(J,I) = YLOW
30214                   ELSE
30215                      YY1(J,I) = LOG10(YY1(J,I))
30216                   ENDIF
30217     9          CONTINUE
30218     8       CONTINUE
30219          ENDIF
30220          CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
30221       ENDIF
30222
30223       RETURN
30224       END
30225
30226 *$ CREATE DT_GETBIN.FOR
30227 *COPY DT_GETBIN
30228 *
30229 *===getbin=============================================================*
30230 *
30231       SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
30232      &                  XMEAN,YMEAN,YERR)
30233
30234 ************************************************************************
30235 * This version dated 23.4.95 is written  by S. Roesler.                *
30236 ************************************************************************
30237
30238       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30239       SAVE
30240       PARAMETER ( LINP = 10 ,
30241      &            LOUT = 6 ,
30242      &            LDAT = 9 )
30243
30244       PARAMETER (ZERO   = 0.0D0,
30245      &           ONE    = 1.0D0,
30246      &           TINY35 = 1.0D-35)
30247
30248 * histograms
30249       PARAMETER (NHIS=150, NDIM=250)
30250       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30251      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30252
30253       XLOW = HIST(1,IHIS,IBIN)
30254       XHI  = HIST(1,IHIS,IBIN+1)
30255       IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
30256          XLOW = 10**XLOW
30257          XHI  = 10**XHI
30258       ENDIF
30259       IF (NORM.EQ.2) THEN
30260          DX   = XHI-XLOW
30261          NEVT = INT(DENTRY(1,IHIS))
30262       ELSEIF (NORM.EQ.3) THEN
30263          DX   = ONE
30264          NEVT = INT(HIST(2,IHIS,IBIN))
30265       ELSEIF (NORM.EQ.4) THEN
30266          DX   = XHI**2-XLOW**2
30267          NEVT = KEVT
30268       ELSEIF (NORM.EQ.5) THEN
30269          DX   = LOG(ABS(XHI))-LOG(ABS(XLOW))
30270          NEVT = KEVT
30271       ELSEIF (NORM.EQ.6) THEN
30272          DX   = ONE
30273          NEVT = KEVT
30274       ELSEIF (NORM.EQ.7) THEN
30275          DX   = ONE
30276          NEVT = INT(HIST(7,IHIS,IBIN))
30277       ELSEIF (NORM.EQ.8) THEN
30278          DX   = XHI-XLOW
30279          NEVT = INT(DENTRY(2,IHIS))
30280       ELSE
30281          DX   = ABS(XHI-XLOW)
30282          NEVT = KEVT
30283       ENDIF
30284       IF (ABS(DX).LT.TINY35) DX = ONE
30285       NEVT   = MAX(NEVT,1)
30286       YMEAN  = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
30287       YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
30288       YERR   = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
30289       YSUM   = HIST(5,IHIS,IBIN)
30290       IF (ABS(YSUM).LT.TINY35) YSUM = ONE
30291 C     XMEAN  = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
30292       XMEAN  = HIST(3,IHIS,IBIN)/YSUM
30293       IF (XMEAN.EQ.ZERO) XMEAN = XLOW
30294
30295       RETURN
30296       END
30297
30298 *$ CREATE DT_JOIHIS.FOR
30299 *COPY DT_JOIHIS
30300 *
30301 *===joihis=============================================================*
30302 *
30303       SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
30304
30305 ************************************************************************
30306 *                                                                      *
30307 *     Operation on histograms.                                         *
30308 *                                                                      *
30309 *     input:  IH1,IH2      histogram indices to be joined              *
30310 *             COPER        character defining the requested operation, *
30311 *                          i.e. '+', '-', '*', '/'                     *
30312 *             FAC1,FAC2    factors for joining, i.e.                   *
30313 *                          FAC1*histo1 COPER FAC2*histo2               *
30314 *                                                                      *
30315 * This version dated 23.4.95 is written  by S. Roesler.                *
30316 ************************************************************************
30317
30318       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30319       SAVE
30320       PARAMETER ( LINP = 10 ,
30321      &            LOUT = 6 ,
30322      &            LDAT = 9 )
30323
30324       CHARACTER COPER*1
30325
30326       PARAMETER (ZERO   =  0.0D0,
30327      &           ONE    =  1.0D0,
30328      &           OHALF  =  0.5D0,
30329      &           TINY8  =  1.0D-8,
30330      &           SMALL  =  -1.0D8,
30331      &           RLARGE =  1.0D8 )
30332
30333 * histograms
30334       PARAMETER (NHIS=150, NDIM=250)
30335       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30336      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30337
30338       PARAMETER (NDIM2 = 2*NDIM)
30339       DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
30340
30341       CHARACTER*43 CNORM(0:6)
30342       DATA CNORM /'no further normalization                   ',
30343      &            'per event and bin width                    ',
30344      &            'per entry and bin width                    ',
30345      &            'per bin entry                              ',
30346      &            'per event and "bin width" x1^2...x2^2      ',
30347      &            'per event and "log. bin width" ln x1..ln x2',
30348      &            'per event                                  '/
30349
30350 * check histogram indices
30351       IF ((IH1.LT.    1).OR.(IH2.LT.    1).OR.
30352      &    (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
30353          WRITE(LOUT,1000) IH1,IH2,IHISL
30354  1000    FORMAT(1X,'JOIHIS:   warning!  inconsistent histogram ',
30355      &          'indices (',I3,',',I3,'),',/,21X,'valid range:  1,',I3)
30356          GOTO 9999
30357       ENDIF
30358
30359 * check bin structure of histograms to be joined
30360       IF (IBINS(IH1).NE.IBINS(IH2)) THEN
30361          WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
30362  1001    FORMAT(1X,'JOIHIS:   warning!  joining histograms ',I3,
30363      &          ' and ',I3,' failed',/,21X,
30364      &          'due to different numbers of bins (',I3,',',I3,')')
30365          GOTO 9999
30366       ENDIF
30367       DO 1 K=1,IBINS(IH1)+1
30368          IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
30369             WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
30370  1002       FORMAT(1X,'JOIHIS:   warning!  joining histograms ',I3,
30371      &             ' and ',I3,' failed at bin edge ',I3,/,21X,
30372      &             'X1,X2 = ',2E11.4)
30373             GOTO 9999
30374          ENDIF
30375     1 CONTINUE
30376
30377       WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
30378  1003 FORMAT(1X,'JOIHIS:   joining histograms ',I3,',',I3,' with ',
30379      &       'operation ',A,/,11X,'and factors ',2E11.4)
30380       WRITE(LOUT,1004) CNORM(NORM)
30381  1004 FORMAT(1X,'normalization: ',A,/)
30382
30383       DO 2 K=1,IBINS(IH1)
30384          CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
30385          CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
30386          XLOW  = XLOW1
30387          XHI   = XHI1
30388          XMEAN = OHALF*(XMEAN1+XMEAN2)
30389          IF (COPER.EQ.'+') THEN
30390             YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
30391          ELSEIF (COPER.EQ.'*') THEN
30392             YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
30393          ELSEIF (COPER.EQ.'/') THEN
30394             IF (YMEAN2.EQ.ZERO) THEN
30395                YMEAN = ZERO
30396             ELSE
30397                IF (FAC2.EQ.ZERO) FAC2 = ONE
30398                YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
30399             ENDIF
30400          ELSE
30401             GOTO 9998
30402          ENDIF
30403          WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30404          WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30405  1006    FORMAT(1X,5E11.3)
30406 *    small frame
30407          II = 2*K
30408          XX(II-1) = HIST(1,IH1,K)
30409          XX(II)   = HIST(1,IH1,K+1)
30410          YY(II-1) = YMEAN
30411          YY(II)   = YMEAN
30412 *    wide frame
30413          XX1(K) = XMEAN
30414          IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
30415          YY1(K) = YMEAN
30416     2 CONTINUE
30417
30418 * plot small frame
30419       IF (ABS(MODE).EQ.1) THEN
30420          IBIN2 = 2*IBINS(IH1)
30421          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30422          IF(ILOGY.EQ.1) THEN
30423            CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30424          ELSE
30425            CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30426          ENDIF
30427       ENDIF
30428
30429 * plot wide frame
30430       IF (ABS(MODE).EQ.2) THEN
30431          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30432          NSIZE = NDIM
30433          DXLOW = HIST(1,IH1,1)
30434          DDX   = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
30435          YLOW  = RLARGE
30436          YHI   = SMALL
30437          DO 3 I=1,NDIM
30438             IF (YY1(I).LT.YLOW) THEN
30439                IF (ILOGY.EQ.1) THEN
30440                   IF (YY1(I).GT.ZERO) YLOW = YY1(I)
30441                ELSE
30442                   YLOW = YY1(I)
30443                ENDIF
30444             ENDIF
30445             IF (YY1(I).GT.YHI) YHI = YY1(I)
30446     3    CONTINUE
30447          DY = (YHI-YLOW)/DBLE(NDIM)
30448          IF (DY.LE.ZERO) THEN
30449             WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
30450      &         'JOIHIS:   warning! zero bin width for histograms ',
30451      &         IH1,IH2,': ',YLOW,YHI
30452             RETURN
30453          ENDIF
30454          IF (ILOGY.EQ.1) THEN
30455             YLOW = LOG10(YLOW)
30456             DY   = (LOG10(YHI)-YLOW)/100.0D0
30457             DO 4 I=1,NDIM
30458                IF (YY1(I).LE.ZERO) THEN
30459                   YY1(I) = YLOW
30460                ELSE
30461                   YY1(I) = LOG10(YY1(I))
30462                ENDIF
30463     4       CONTINUE
30464          ENDIF
30465          CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
30466       ENDIF
30467
30468       RETURN
30469
30470  9998 CONTINUE
30471       WRITE(LOUT,1005) COPER
30472  1005 FORMAT(1X,'JOIHIS:   unknown operation ',A)
30473
30474  9999 CONTINUE
30475       RETURN
30476       END
30477
30478 *$ CREATE DT_XGRAPH.FOR
30479 *COPY DT_XGRAPH
30480 *
30481 *===qgraph=============================================================*
30482 *
30483       SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
30484 C***********************************************************************
30485 C
30486 C     calculate quasi graphic picture with 25 lines and 79 columns
30487 C     ranges will be chosen automatically
30488 C
30489 C     input     N          dimension of input fields
30490 C               IARG       number of curves (fields) to plot
30491 C               X          field of X
30492 C               Y1         field of Y1
30493 C               Y2         field of Y2
30494 C
30495 C This subroutine is written by R. Engel.
30496 C***********************************************************************
30497       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30498       SAVE
30499
30500       PARAMETER ( LINP = 10 ,
30501      &            LOUT = 6 ,
30502      &            LDAT = 9 )
30503 C
30504       DIMENSION X(N),Y1(N),Y2(N)
30505       PARAMETER (EPS=1.D-30)
30506       PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30507       CHARACTER SYMB(5)
30508       CHARACTER COL(0:149,0:49)
30509 C
30510       DATA SYMB /'0','e','z','#','x'/
30511 C
30512       ISPALT=IBREIT-10
30513 C
30514 C***  automatic range fitting
30515 C
30516       XMAX=X(1)
30517       XMIN=X(1)
30518       DO 600 I=1,N
30519          XMAX=MAX(X(I),XMAX)
30520          XMIN=MIN(X(I),XMIN)
30521  600  CONTINUE
30522       XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30523 C
30524       ITEST=0
30525       DO 1100 K=0,IZEIL-1
30526          ITEST=ITEST+1
30527          IF (ITEST.EQ.IYRAST) THEN
30528             DO 1010 L=1,ISPALT-1
30529                COL(L,K)='-'
30530 1010        CONTINUE
30531             COL(ISPALT,K)='+'
30532             ITEST=0
30533             DO 1020 L=0,ISPALT-1,IXRAST
30534                COL(L,K)='+'
30535 1020        CONTINUE
30536          ELSE
30537             DO 1030 L=1,ISPALT-1
30538                COL(L,K)=' '
30539 1030        CONTINUE
30540             DO 1040 L=0,ISPALT-1,IXRAST
30541                COL(L,K)='|'
30542 1040        CONTINUE
30543             COL(ISPALT,K)='|'
30544          ENDIF
30545 1100  CONTINUE
30546 C
30547 C***  plot curve Y1
30548 C
30549       YMAX=Y1(1)
30550       YMIN=Y1(1)
30551       DO 500 I=1,N
30552          YMAX=MAX(Y1(I),YMAX)
30553          YMIN=MIN(Y1(I),YMIN)
30554 500   CONTINUE
30555       IF(IARG.GT.1) THEN
30556         DO 550 I=1,N
30557            YMAX=MAX(Y2(I),YMAX)
30558            YMIN=MIN(Y2(I),YMIN)
30559 550     CONTINUE
30560       ENDIF
30561       YMAX=(YMAX-YMIN)/40.0D0+YMAX
30562       YMIN=YMIN-(YMAX-YMIN)/40.0D0
30563       YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
30564       IF(YZOOM.LT.EPS) THEN
30565         WRITE(LOUT,'(1X,A)')
30566      &    'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30567         RETURN
30568       ENDIF
30569 C
30570 C***  plot curve Y1
30571 C
30572       ILAST=-1
30573       LLAST=-1
30574       DO 1200 K=1,N
30575          L=NINT((X(K)-XMIN)/XZOOM)
30576          I=NINT((YMAX-Y1(K))/YZOOM)
30577          IF(ILAST.GE.0) THEN
30578            LD = L-LLAST
30579            ID = I-ILAST
30580            DO 55 II=0,LD,SIGN(1,LD)
30581              DO 66 KK=0,ID,SIGN(1,ID)
30582                COL(II+LLAST,KK+ILAST)=SYMB(1)
30583  66          CONTINUE
30584  55        CONTINUE
30585          ELSE
30586            COL(L,I)=SYMB(1)
30587          ENDIF
30588          ILAST = I
30589          LLAST = L
30590 1200  CONTINUE
30591 C
30592       IF(IARG.GT.1) THEN
30593 C
30594 C***  plot curve Y2
30595 C
30596         DO 1250 K=1,N
30597            L=NINT((X(K)-XMIN)/XZOOM)
30598            I=NINT((YMAX-Y2(K))/YZOOM)
30599            COL(L,I)=SYMB(2)
30600 1250    CONTINUE
30601       ENDIF
30602 C
30603 C***  write it
30604 C
30605       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30606 C
30607 C***  write range of X
30608 C
30609       XZOOM = (XMAX-XMIN)/DBLE(7)
30610       WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30611 C
30612       DO 1300 K=0,IZEIL-1
30613          YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
30614          WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30615  110     FORMAT(1X,1PE9.2,70A1)
30616 1300  CONTINUE
30617 C
30618 C***  write range of X
30619 C
30620       XZOOM = (XMAX-XMIN)/DBLE(7)
30621       WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30622       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30623  120  FORMAT(6X,7(1PE10.3))
30624       END
30625
30626 *$ CREATE DT_XGLOGY.FOR
30627 *COPY DT_XGLOGY
30628 *
30629 *===qglogy=============================================================*
30630 *
30631       SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
30632 C***********************************************************************
30633 C
30634 C     calculate quasi graphic picture with 25 lines and 79 columns
30635 C     logarithmic y axis
30636 C     ranges will be chosen automatically
30637 C
30638 C     input     N          dimension of input fields
30639 C               IARG       number of curves (fields) to plot
30640 C               X          field of X
30641 C               Y1         field of Y1
30642 C               Y2         field of Y2
30643 C
30644 C This subroutine is written by R. Engel.
30645 C***********************************************************************
30646 C
30647       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30648       SAVE
30649
30650       PARAMETER ( LINP = 10 ,
30651      &            LOUT = 6 ,
30652      &            LDAT = 9 )
30653       DIMENSION X(N),Y1(N),Y2(N)
30654       PARAMETER (EPS=1.D-30)
30655       PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30656       CHARACTER SYMB(5)
30657       CHARACTER COL(0:149,0:49)
30658       PARAMETER (DEPS = 1.D-10)
30659 C
30660       DATA SYMB /'0','e','z','#','x'/
30661 C
30662       ISPALT=IBREIT-10
30663 C
30664 C***  automatic range fitting
30665 C
30666       XMAX=X(1)
30667       XMIN=X(1)
30668       DO 600 I=1,N
30669          XMAX=MAX(X(I),XMAX)
30670          XMIN=MIN(X(I),XMIN)
30671  600  CONTINUE
30672       XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30673 C
30674       ITEST=0
30675       DO 1100 K=0,IZEIL-1
30676          ITEST=ITEST+1
30677          IF (ITEST.EQ.IYRAST) THEN
30678             DO 1010 L=1,ISPALT-1
30679                COL(L,K)='-'
30680 1010        CONTINUE
30681             COL(ISPALT,K)='+'
30682             ITEST=0
30683             DO 1020 L=0,ISPALT-1,IXRAST
30684                COL(L,K)='+'
30685 1020        CONTINUE
30686          ELSE
30687             DO 1030 L=1,ISPALT-1
30688                COL(L,K)=' '
30689 1030        CONTINUE
30690             DO 1040 L=0,ISPALT-1,IXRAST
30691                COL(L,K)='|'
30692 1040        CONTINUE
30693             COL(ISPALT,K)='|'
30694          ENDIF
30695 1100  CONTINUE
30696 C
30697 C***  plot curve Y1
30698 C
30699       YMAX=Y1(1)
30700       YMIN=MAX(Y1(1),EPS)
30701       DO 500 I=1,N
30702          YMAX =MAX(Y1(I),YMAX)
30703          IF(Y1(I).GT.EPS) THEN
30704            IF(YMIN.EQ.EPS) THEN
30705              YMIN = Y1(I)/10.D0
30706            ELSE
30707              YMIN = MIN(Y1(I),YMIN)
30708            ENDIF
30709          ENDIF
30710 500   CONTINUE
30711       IF(IARG.GT.1) THEN
30712         DO 550 I=1,N
30713            YMAX=MAX(Y2(I),YMAX)
30714            IF(Y2(I).GT.EPS) THEN
30715              IF(YMIN.EQ.EPS) THEN
30716                YMIN = Y2(I)
30717              ELSE
30718                YMIN = MIN(Y2(I),YMIN)
30719              ENDIF
30720            ENDIF
30721 550     CONTINUE
30722       ENDIF
30723 C
30724       DO 560 I=1,N
30725         Y1(I) = MAX(Y1(I),YMIN)
30726  560  CONTINUE
30727       IF(IARG.GT.1) THEN
30728         DO 570 I=1,N
30729           Y2(I) = MAX(Y2(I),YMIN)
30730  570    CONTINUE
30731       ENDIF
30732 C
30733       IF(YMAX.LE.YMIN) THEN
30734         WRITE(LOUT,'(/1X,A,2E12.3,/)')
30735      &     'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
30736         WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
30737         RETURN
30738       ENDIF
30739 C
30740       YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
30741       YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
30742       YZOOM=(YMA-YMI)/DBLE(IZEIL)
30743       IF(YZOOM.LT.EPS) THEN
30744         WRITE(LOUT,'(1X,A)')
30745      &    'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30746         RETURN
30747       ENDIF
30748 C
30749 C***  plot curve Y1
30750 C
30751       ILAST=-1
30752       LLAST=-1
30753       DO 1200 K=1,N
30754          L=NINT((X(K)-XMIN)/XZOOM)
30755          I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
30756          IF(ILAST.GE.0) THEN
30757            LD = L-LLAST
30758            ID = I-ILAST
30759            DO 55 II=0,LD,SIGN(1,LD)
30760              DO 66 KK=0,ID,SIGN(1,ID)
30761                COL(II+LLAST,KK+ILAST)=SYMB(1)
30762  66          CONTINUE
30763  55        CONTINUE
30764          ELSE
30765            COL(L,I)=SYMB(1)
30766          ENDIF
30767          ILAST = I
30768          LLAST = L
30769 1200  CONTINUE
30770 C
30771       IF(IARG.GT.1) THEN
30772 C
30773 C***  plot curve Y2
30774 C
30775         DO 1250 K=1,N
30776            L=NINT((X(K)-XMIN)/XZOOM)
30777            I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
30778            COL(L,I)=SYMB(2)
30779 1250    CONTINUE
30780       ENDIF
30781 C
30782 C***  write it
30783 C
30784       WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
30785       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30786 C
30787 C***  write range of X
30788 C
30789       XZOOM1 = (XMAX-XMIN)/DBLE(7)
30790       WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30791 C
30792       DO 1300 K=0,IZEIL-1
30793          YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
30794          WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30795  110     FORMAT(1X,1PE9.2,70A1)
30796 1300  CONTINUE
30797 C
30798 C***  write range of X
30799 C
30800       WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30801       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30802  120  FORMAT(6X,7(1PE10.3))
30803 C
30804       END
30805
30806 *$ CREATE DT_SRPLOT.FOR
30807 *COPY DT_SRPLOT
30808 *
30809 *===plot===============================================================*
30810 *
30811       SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
30812
30813       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30814       SAVE
30815
30816       PARAMETER ( LINP = 10 ,
30817      &            LOUT = 6 ,
30818      &            LDAT = 9 )
30819 *
30820 *     initial version
30821 *     J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
30822 *     This is a subroutine of fluka to plot Y across the page
30823 *     as a function of X down the page. Up to 37 curves can be
30824 *     plotted in the same picture with different plotting characters.
30825 *     Output of first 10 overprinted characters addad by FB 88
30826 *  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
30827 *
30828 *     Input Variables:
30829 *        X   = array containing the values of X
30830 *        Y   = array containing the values of Y
30831 *        N   = number of values in X and in Y
30832 *              can exceed the fixed number of lines
30833 *        M   = number of different curves X,Y are containing
30834 *        MM  = number of points in each curve i.e. N=M*MM
30835 *        XO  = smallest value of X to be plotted
30836 *        DX  = increment of X between subsequent lines
30837 *        YO  = smallest value of Y to be plotted
30838 *        DY  = increment of Y between subsequent character spaces
30839 *
30840 *        other variables used inside:
30841 *        XX  = numbers along the X-coordinate axis
30842 *        YY  = numbers along the Y-coordinate axis
30843 *        LL  = ten lines temporary storage for the plot
30844 *        L   = character set used to plot different curves
30845 *        LOV = memorizes overprinted symbols
30846 *              the first 10 overprinted symbols are printed on
30847 *              the end of the line to avoid ambiguities
30848 *              (added by FB as considered quite helpful)
30849 *
30850 *********************************************************************
30851 *
30852       DIMENSION XX(61),YY(61),LL(101,10)
30853       DIMENSION X(N),Y(N),L(40),LOV(40,10)
30854       INTEGER*4 LL, L, LOV
30855       DATA  L/
30856      11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
30857      21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
30858      31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
30859      41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H  /
30860 *
30861 *
30862       MN=51
30863       DO 10 I=1,MN
30864         AI=I-1
30865    10 XX(I)=XO+AI*DX
30866       DO 20 I=1,11
30867         AI=I-1
30868    20 YY(I)=YO+10.0D0*AI*DY
30869       WRITE(LOUT, 500) (YY(I),I=1,11)
30870       MMN=MN-1
30871 *
30872 *
30873       DO 90 JJ=1,MMN,10
30874         JJJ=JJ-1
30875         DO 30 I=1,101
30876           DO 30 J=1,10
30877    30   LL(I,J)=L(40)
30878         DO 40 I=1,101
30879    40   LL(I,1)=L(39)
30880         DO 50 I=1,101,10
30881           DO 50 J=1,10
30882    50   LL(I,J)=L(38)
30883         DO 60 I=1,40
30884           DO 60 J=1,10
30885    60   LOV(I,J)=L(40)
30886 *
30887 *
30888         DO 70 I=1,M
30889           DO 70 J=1,MM
30890             II=J+(I-1)*MM
30891             AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
30892             AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
30893             AIX=AIX-DBLE(JJJ)
30894 *           changed Sept.88 by FB to avoid INTEGER OVERFLOW
30895             IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
30896      +      . AIY .LT. 102.D0) THEN
30897               IX=INT(AIX)
30898               IY=INT(AIY)
30899               IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
30900      +        THEN
30901                 IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
30902      +          =LL(IY,IX)
30903                 LL(IY,IX)=L(I)
30904               ENDIF
30905             ENDIF
30906    70   CONTINUE
30907 *
30908 *
30909         DO 80 I=1,10
30910           II=I+JJJ
30911           III=II+1
30912           WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
30913      &                    (LOV(J,I),J=1,10)
30914    80   CONTINUE
30915    90 CONTINUE
30916 *
30917 *
30918       WRITE(LOUT, 520)
30919       WRITE(LOUT, 500) (YY(I),I=1,11)
30920       RETURN
30921 *
30922   500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
30923   510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
30924   520 FORMAT(20X,10('1---------'),'1')
30925       END
30926
30927 *$ CREATE DT_DEFSET.FOR
30928 *COPY DT_DEFSET
30929 *
30930 *===defset=============================================================*
30931 *
30932       BLOCK DATA DT_DEFSET
30933
30934       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30935       SAVE
30936
30937 * flags for input different options
30938       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
30939       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
30940      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
30941       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
30942 * emulsion treatment
30943       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
30944      &                NCOMPO,IEMUL
30945
30946 * / DTFLG1 /
30947       DATA IFRAG  / 2, 1 /
30948       DATA IRESCO / 1 /
30949       DATA IMSHL  / 1 /
30950       DATA IRESRJ / 0 /
30951       DATA IOULEV / -1, -1, -1, -1, -1, -1 /
30952       DATA LEMCCK / .FALSE. /
30953       DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
30954      &              .TRUE.,.TRUE.,.TRUE./
30955       DATA LSEADI / .TRUE. /
30956       DATA LEVAPO / .TRUE. /
30957       DATA IFRAME / 1 /
30958       DATA ITRSPT / 0 /
30959
30960 * / DTCOMP /
30961       DATA EMUFRA / NCOMPX*0.0D0 /
30962       DATA IEMUMA / NCOMPX*1 /
30963       DATA IEMUCH / NCOMPX*1 /
30964       DATA NCOMPO / 0 /
30965       DATA IEMUL  / 0 /
30966
30967       END
30968
30969 *$ CREATE DT_HADPRP.FOR
30970 *COPY DT_HADPRP
30971 *
30972 *===hadprp=============================================================*
30973 *
30974       BLOCK DATA DT_HADPRP
30975
30976       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30977       SAVE
30978
30979 * auxiliary common for reggeon exchange (DTUNUC 1.x)
30980       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
30981      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
30982      &                IQTCHR(-6:6),MQUARK(3,39)
30983 * hadron index conversion (BAMJET <--> PDG)
30984       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
30985      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
30986      &                IAMCIN(210)
30987 * names of hadrons used in input-cards
30988       CHARACTER*8 BTYPE
30989       COMMON /DTPAIN/ BTYPE(30)
30990
30991 * / DTQUAR /
30992 *----------------------------------------------------------------------*
30993 *                                                                      *
30994 *     Quark content of particles:                                      *
30995 *          index   quark   el. charge  bar. charge  isospin  isospin3  *
30996 *              1 = u          2/3          1/3        1/2       1/2    *
30997 *             -1 = ubar      -2/3         -1/3        1/2      -1/2    *
30998 *              2 = d         -1/3          1/3        1/2      -1/2    *
30999 *             -2 = dbar       1/3         -1/3        1/2       1/2    *
31000 *              3 = s         -1/3          1/3         0         0     *
31001 *             -3 = sbar       1/3         -1/3         0         0     *
31002 *              4 = c          2/3          1/3         0         0     *
31003 *             -4 = cbar      -2/3         -1/3         0         0     *
31004 *              5 = b         -1/3          1/3         0         0     *
31005 *             -5 = bbar       1/3         -1/3         0         0     *
31006 *              6 = t          2/3          1/3         0         0     *
31007 *             -6 = tbar      -2/3         -1/3         0         0     *
31008 *                                                                      *
31009 *         Mquark = particle quark composition (Paprop numbering)       *
31010 *         Iqechr = electric charge ( in 1/3 unit )                     *
31011 *         Iqbchr = baryonic charge ( in 1/3 unit )                     *
31012 *         Iqichr = isospin ( in 1/2 unit ), z component                *
31013 *         Iqschr = strangeness                                         *
31014 *         Iqcchr = charm                                               *
31015 *         Iquchr = beauty                                              *
31016 *         Iqtchr = ......                                              *
31017 *                                                                      *
31018 *----------------------------------------------------------------------*
31019       DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
31020       DATA IQBCHR / 6*-1, 0, 6*1 /
31021       DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
31022       DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
31023       DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
31024       DATA IQUCHR / 0, 1, 9*0, -1, 0 /
31025       DATA IQTCHR / -1, 11*0, 1 /
31026       DATA MQUARK /
31027      &   2, 1, 1,   -2,-1,-1,    0, 0, 0,    0, 0, 0,    0, 0, 0,
31028      &   0, 0, 0,    0, 0, 0,    2, 2, 1,   -2,-2,-1,    0, 0, 0,
31029      &   0, 0, 0,    0, 0, 0,    1,-2, 0,    2,-1, 0,    1,-3, 0,
31030      &   3,-1, 0,    1, 2, 3,   -1,-2,-3,    0, 0, 0,    2, 2, 3,
31031      &   1, 1, 3,    1, 2, 3,    1,-1, 0,    2,-3, 0,    3,-2, 0,
31032      &   2,-2, 0,    3,-3, 0,    0, 0, 0,    0, 0, 0,    0, 0, 0,
31033      &  -1,-1,-3,   -1,-2,-3,   -2,-2,-3,    1, 3, 3,   -1,-3,-3,
31034      &   2, 3, 3,   -2,-3,-3,    3, 3, 3,   -3,-3,-3 /
31035
31036 * / DTHAIC /
31037 * (renamed) (HAdron InDex COnversion)
31038 * translation table version filled up by r.e. 25.01.94                 *
31039       DATA IAMCIN /
31040      &2212,-2212,11,-11,12,              -12,22,2112,-2112,-13,
31041      &13,130,211,-211,321,               -321,3122,-3122,310,3112,
31042      &3222,3212,111,311,-311,            0,0,0,0,0,
31043      &221,213,113,-213,223,              323,313,-323,-313,10323,
31044      &10313,-10323,-10313,30323,30313,   -30323,-30313,3224,3214,3114,
31045      &3216,3218,2224,2214,2114,          1114,12224,12214,12114,11114,
31046      &99999,99999,22212,22112,32124,     31214,-2224,-2214,-2114,-1114,
31047      &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
31048      &5*99999,                           5*99999,
31049      &4*99999,331,                       333,3322,3312,-3222,-3212,
31050      &-3112,-3322,-3312,3224,3214,       3114,3324,3314,3334,-3224,
31051      &-3214,-3114,-3324,-3314,-3334,     421,411,-411,-421,431,
31052      &-431,441,423,413,-413,             -423,433,-433,20443,443,
31053      &-15,15,16,-16,14,                  -14,4122,4232,4132,4222,
31054      &4212,4112,3*99999,                 3*99999,-4122,-4232,
31055      &-4132,-4222,-4212,-4112,99999,     5*99999,
31056      &5*99999,                           5*99999,
31057      &10*99999,
31058      &5*99999 , 20211,20111,-20211,99999,20321,
31059      &-20321,20311,-20311,7*99999 ,
31060      &7*99999,12212,12112,99999/
31061
31062 * / DTHAIC /
31063 * (HAdron InDex COnversion)
31064       DATA (IPDG2(1,K),K=1,7)
31065      &   /   -11,   -12,   -13,   -15,   -16,   -14,     0/
31066       DATA (IBAM2(1,K),K=1,7)
31067      &   /     4,     6,    10,   131,   134,   136,     0/
31068       DATA (IPDG2(2,K),K=1,7)
31069      &   /    11,    12,    22,    13,    15,    16,    14/
31070       DATA (IBAM2(2,K),K=1,7)
31071      &   /     3,     5,     7,    11,   132,   133,   135/
31072       DATA (IPDG3(1,K),K=1,22)
31073      &   /  -211,  -321,  -311,  -213,  -323,  -313,  -411,  -421,
31074      &      -431,  -413,  -423,  -433,     0,     0,     0,     0,
31075      &         0,     0,     0,     0,     0,     0/
31076       DATA (IBAM3(1,K),K=1,22)
31077      &   /    14,    16,    25,    34,    38,    39,   118,   119,
31078      &       121,   125,   126,   128,     0,     0,     0,     0,
31079      &         0,     0,     0,     0,     0,     0/
31080       DATA (IPDG3(2,K),K=1,22)
31081      &   /   130,   211,   321,   310,   111,   311,   221,   213,
31082      &       113,   223,   323,   313,   331,   333,   421,   411,
31083      &       431,   441,   423,   413,   433,   443/
31084       DATA (IBAM3(2,K),K=1,22)
31085      &   /    12,    13,    15,    19,    23,    24,    31,    32,
31086      &        33,    35,    36,    37,    95,    96,   116,   117,
31087      &       120,   122,   123,   124,   127,   130/
31088       DATA (IPDG4(1,K),K=1,29)
31089      &   / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
31090      &     -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
31091      &     -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
31092      &     -4212, -4112,     0,     0,     0/
31093       DATA (IBAM4(1,K),K=1,29)
31094      &   /     2,     9,    18,    67,    68,    69,    70,    75,
31095      &        76,    99,   100,   101,   102,   103,   110,   111,
31096      &       112,   113,   114,   115,   149,   150,   151,   152,
31097      &       153,   154,     0,     0,     0/
31098       DATA (IPDG4(2,K),K=1,29)
31099      &   /  2212,  2112,  3122,  3112,  3222,  3212,  3224,  3214,
31100      &      3114,  3216,  3218,  2224,  2214,  2114,  1114,  3322,
31101      &      3312,  3224,  3214,  3114,  3324,  3314,  3334,  4122,
31102      &      4232,  4132,  4222,  4212,  4112/
31103       DATA (IBAM4(2,K),K=1,29)
31104      &   /     1,     8,    17,    20,    21,    22,    48,    49,
31105      &        50,    51,    52,    53,    54,    55,    56,    97,
31106      &        98,   104,   105,   106,   107,   108,   109,   137,
31107      &       138,   139,   140,   141,   142/
31108       DATA (IPDG5(1,K),K=1,19)
31109      &   /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
31110      &    -20211,-20321,-20311,     0,     0,     0,     0,     0,
31111      &         0,     0,     0/
31112       DATA (IBAM5(1,K),K=1,19)
31113      &   /    42,    43,    46,    47,    71,    72,    73,    74,
31114      &       188,   191,   193,     0,     0,     0,     0,     0,
31115      &         0,     0,     0/
31116       DATA (IPDG5(2,K),K=1,19)
31117      &   / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
31118      &     22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
31119      &     20311, 12212, 12112/
31120       DATA (IBAM5(2,K),K=1,19)
31121      &   /    40,    41,    44,    45,    57,    58,    59,    60,
31122      &        63,    64,    65,    66,   129,   186,   187,   190,
31123      &       192,   208,   209/
31124
31125 * / DTPAIN /
31126 * internal particle names
31127       DATA BTYPE / 'PROTON  ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
31128      &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON  ' , 'NEUTRON ' , 'ANEUTRON' ,
31129      &'MUON+   ' , 'MUON-   ' , 'KAONLONG' , 'PION+   ' , 'PION-   ' ,
31130      &'KAON+   ' , 'KAON-   ' , 'LAMBDA  ' , 'ALAMBDA ' , 'KAONSHRT' ,
31131      &'SIGMA-  ' , 'SIGMA+  ' , 'SIGMAZER' , 'PIZERO  ' , 'KAONZERO' ,
31132      &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
31133      &'BLANK   ' /
31134
31135       END
31136
31137 *$ CREATE DT_BLKD46.FOR
31138 *COPY DT_BLKD46
31139 *
31140 *===blkd46=============================================================*
31141 *
31142       BLOCK DATA DT_BLKD46
31143
31144       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31145       SAVE
31146
31147       PARAMETER ( AMELCT = 0.51099906         D-03 )
31148       PARAMETER ( AMMUON = 0.105658389        D+00 )
31149
31150 * particle properties (BAMJET index convention)
31151       CHARACTER*8  ANAME
31152       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31153      &                IICH(210),IIBAR(210),K1(210),K2(210)
31154
31155 * / DTPART /
31156 * Particle  masses Engel version JETSET compatible
31157 C     DATA (AAM(K),K=1,85) /
31158 C    &   .9383D+00, .9383D+00,  AMELCT  ,  AMELCT  , .0000D+00,
31159 C    &   .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON   ,
31160 C    &   AMMUON   , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
31161 C    &   .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
31162 C    &   .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
31163 C    &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31164 C    &   .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
31165 C    &   .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
31166 C    &   .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
31167 C    &   .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
31168 C    &   .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31169 C    &   .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31170 C    &   .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31171 C    &   .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31172 C    &   .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31173 C    &   .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31174 C    &   .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01  /
31175 C     DATA (AAM(K),K=86,183) /
31176 C    &   .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31177 C    &   .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
31178 C    &   .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
31179 C    &   .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
31180 C    &   .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
31181 C    &   .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
31182 C    &   .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
31183 C    &   .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
31184 C    &   .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
31185 C    &   .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
31186 C    &   .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
31187 C    &   .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
31188 C    &   .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
31189 C    &   .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
31190 C    &   .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31191 C    &   .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31192 C    &   .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31193 C    &   .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31194 C    &   .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31195 C    &   .1250D+01, .1250D+01, .1250D+01  /
31196 C     DATA (AAM ( I ), I = 184,210 ) /
31197 C    & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31198 C    & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31199 C    & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31200 C    & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31201 C    & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31202 C    & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31203 C    & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31204 C    & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31205 C    & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31206 * sr 25.1.06: particle masses adjusted to Pythia
31207       DATA (AAM(K),K=1,85) /
31208      &   .938270E+00,.938270E+00, AMELCT    , AMELCT    ,.000000E+00,
31209      &   .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON    ,
31210      &    AMMUON    ,.497670E+00,.139570E+00,.139570E+00,.493600E+00,
31211      &   .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01,
31212      &   .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00,
31213      &     .0000D+00,  .0000D+00,  .0000D+00 , .0000D+00,  .0000D+00,
31214      &   .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00,
31215      &   .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01,
31216      &   .129000E+01,.129000E+01,.129000E+01,  .1421D+01,  .1421D+01,
31217      &     .1421D+01,  .1421D+01,.138280E+01,.138370E+01,.138720E+01,
31218      &     .1820D+01,  .2030D+01,  .1231D+01,  .1232D+01,  .1233D+01,
31219      &     .1234D+01,  .1675D+01,  .1675D+01,  .1675D+01,  .1675D+01,
31220      &     .1500D+01,  .1500D+01,  .1515D+01,  .1515D+01,  .1775D+01,
31221      &     .1775D+01,  .1231D+01,  .1232D+01,  .1233D+01,  .1234D+01,
31222      &     .1675D+01,  .1675D+01,  .1675D+01,  .1675D+01,  .1515D+01,
31223      &     .1515D+01,  .2500D+01,  .4890D+00,  .4890D+00,  .4890D+00,
31224      &     .1300D+01,  .1300D+01,  .1300D+01,  .1300D+01,  .2200D+01  /
31225       DATA (AAM(K),K=86,183) /
31226      &     .2200D+01,  .2200D+01,  .2200D+01,  .1700D+01,  .1700D+01,
31227      &     .1700D+01,  .1700D+01,  .1820D+01,  .2030D+01,.957770E+00,
31228      &   .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01,
31229      &   .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01,
31230      &   .138720E+01,.153180E+01,  .1535D+01,.167245E+01,.138280E+01,
31231      &   .138370E+01,.138720E+01,.153180E+01,  .1535D+01,.167245E+01,
31232      &   .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01,
31233      &   .196850E+01,.297980E+01,.200670E+01,  .2010D+01,  .2010D+01,
31234      &   .200670E+01,.211240E+01,.211240E+01,  .3686D+01,.309688E+01,
31235      &   .177700E+01,.177700E+01,  .0000D+00,  .0000D+00,  .0000D+00,
31236      &     .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01,
31237      &   .245350E+01,.245210E+01,  .2560D+01,  .2560D+01,  .2730D+01,
31238      &     .3610D+01,  .3610D+01,  .3790D+01,.228490E+01,.246560E+01,
31239      &     .2460D+01,.245290E+01,.245350E+01,.245210E+01,  .2560D+01,
31240      &     .2560D+01,  .2730D+01,  .3610D+01,  .3610D+01,  .3790D+01,
31241      &     .2490D+01,  .2490D+01,  .2490D+01,  .2610D+01,  .2610D+01,
31242      &     .2770D+01,  .3670D+01,  .3670D+01,  .3850D+01,  .4890D+01,
31243      &     .2490D+01,  .2490D+01,  .2490D+01,  .2610D+01,  .2610D+01,
31244      &     .2770D+01,  .3670D+01,  .3670D+01,  .3850D+01,  .4890D+01,
31245      &     .1250D+01,  .1250D+01,  .1250D+01  /
31246       DATA (AAM ( I ), I = 184,210 ) /
31247      & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31248      & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31249      & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31250      & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31251      & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31252      & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31253      & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31254      & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31255      & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31256 * Particle  mean lives
31257       DATA (TAU(K),K=1,183) /
31258      &   .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
31259      &   .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
31260      &   .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
31261      &   .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
31262      &   .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
31263      &   70*.0000D+00,
31264      &   .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
31265      &   .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
31266      &   .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
31267      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
31268      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31269      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31270      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31271      &   .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
31272      &   .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31273      &   40*.0000D+00,
31274      &   .0000D+00, .0000D+00, .0000D+00  /
31275       DATA ( TAU ( I ), I = 184,210 ) /
31276      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31277      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31278      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31279      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31280      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31281      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31282      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31283      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31284      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/
31285 * Resonance width Gamma in GeV
31286       DATA (GA(K),K=  1,85) /
31287      &    30*.0000D+00,
31288      &   .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
31289      &   .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
31290      &   .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
31291      &   .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
31292      &   .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
31293      &   .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
31294      &   .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
31295      &   .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
31296      &   .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
31297      &   .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
31298      &   .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00  /
31299       DATA (GA(K),K= 86,183) /
31300      &   .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
31301      &   .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
31302      &   .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31303      &   .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
31304      &   .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
31305      &   .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
31306      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31307      &   .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
31308      &   .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
31309      &   50*.0000D+00,
31310      &   .3000D+00, .3000D+00, .3000D+00  /
31311       DATA ( GA ( I ), I = 184,210 ) /
31312      & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
31313      & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
31314      & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
31315      & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
31316      & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31317      & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31318      & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
31319      & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
31320      & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
31321 * Particle  names
31322 * S+1385+Sigma+(1385)    L02030+Lambda0(2030)
31323 * Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
31324 * designation N*@@ means N*@1(@2)
31325       DATA (ANAME(K),K=1,85) /
31326      &  'P       ','AP      ','E-      ','E+      ','NUE     ',
31327      &  'ANUE    ','GAM     ','NEU     ','ANEU    ','MUE+    ',
31328      &  'MUE-    ','K0L     ','PI+     ','PI-     ','K+      ',
31329      &  'K-      ','LAM     ','ALAM    ','K0S     ','SIGM-   ',
31330      &  'SIGM+   ','SIGM0   ','PI0     ','K0      ','AK0     ',
31331      &  'BLANK   ','BLANK   ','BLANK   ','BLANK   ','BLANK   ',
31332      &  'ETA550  ','RHO+77  ','RHO077  ','RHO-77  ','OM0783  ',
31333      &  'K*+892  ','K*0892  ','K*-892  ','AK*089  ','KA+125  ',
31334      &  'KA0125  ','KA-125  ','AKA012  ','K*+142  ','K*0142  ',
31335      &  'K*-142  ','AK*014  ','S+1385  ','S01385  ','S-1385  ',
31336      &  'L01820  ','L02030  ','N*++12  ','N*+ 12  ','N*012   ',
31337      &  'N*-12   ','N*++16  ','N*+16   ','N*016   ','N*-16   ',
31338      &  'N*+14   ','N*014   ','N*+15   ','N*015   ','N*+18   ',
31339      &  'N*018   ','AN--12  ','AN*-12  ','AN*012  ','AN*+12  ',
31340      &  'AN--16  ','AN*-16  ','AN*016  ','AN*+16  ','AN*-15  ',
31341      &  'AN*015  ','DE*=24  ','RPI+49  ','RPI049  ','RPI-49  ',
31342      &  'PIN++   ','PIN+0   ','PIN+-   ','PIN-0   ','PPPI    ' /
31343       DATA (ANAME(K),K=86,183) /
31344      &  'PNPI    ','APPPI   ','APNPI   ','K+PPI   ','K-PPI   ',
31345      &  'K+NPI   ','K-NPI   ','S+1820  ','S-2030  ','ETA*    ',
31346      &  'PHI     ','TETA0   ','TETA-   ','ASIG-   ','ASIG0   ',
31347      &  'ASIG+   ','ATETA0  ','ATETA+  ','SIG*+   ','SIG*0   ',
31348      &  'SIG*-   ','TETA*0  ','TETA*   ','OMEGA-  ','ASIG*-  ',
31349      &  'ASIG*0  ','ASIG*+  ','ATET*0  ','ATET*+  ','OMEGA+  ',
31350      &  'D0      ','D+      ','D-      ','AD0     ','F+      ',
31351      &  'F-      ','ETAC    ','D*0     ','D*+     ','D*-     ',
31352      &  'AD*0    ','F*+     ','F*-     ','PSI     ','JPSI    ',
31353      &  'TAU+    ','TAU-    ','NUET    ','ANUET   ','NUEM    ',
31354      &  'ANUEM   ','C0+     ','A+      ','A0      ','C1++    ',
31355      &  'C1+     ','C10     ','S+      ','S0      ','T0      ',
31356      &  'XU++    ','XD+     ','XS+     ','AC0-    ','AA-     ',
31357      &  'AA0     ','AC1--   ','AC1-    ','AC10    ','AS-     ',
31358      &  'AS0     ','AT0     ','AXU--   ','AXD-    ','AXS     ',
31359      &  'C1*++   ','C1*+    ','C1*0    ','S*+     ','S*0     ',
31360      &  'T*0     ','XU*++   ','XD*+    ','XS*+    ','TETA++  ',
31361      &  'AC1*--  ','AC1*-   ','AC1*0   ','AS*-    ','AS*0    ',
31362      &  'AT*0    ','AXU*--  ','AXD*-   ','AXS*-   ','ATET--  ',
31363      &  'RO      ','R+      ','R-      '  /
31364       DATA (    ANAME ( I ), I = 184,210 ) /
31365      &'AN*-14  ','AN*014  ','PI+130  ','PI0130  ','PI-130  ','F01400  ',
31366      &'K*+146  ','K*-146  ','K*0146  ','AK0146  ','L01600  ','AL0160  ',
31367      &'S+1660  ','S01660  ','S-1660  ','AS-166  ','AS0166  ','AS+166  ',
31368      &'X01950  ','X-1950  ','AX0195  ','AX+195  ','OM-225  ','AOM+22  ',
31369      &'N*+14   ','N*014   ','BLANK   '/
31370 * Charge of particles and resonances
31371       DATA (IICH ( I ), I =   1,210 ) /
31372      &  1, -1, -1,  1,  0,  0,  0,  0,  0,  1, -1,  0,  1, -1,  1,
31373      & -1,  0,  0,  0, -1,  1,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31374      &  0,  1,  0, -1,  0,  1,  0, -1,  0,  1,  0, -1,  0,  1,  0,
31375      & -1,  0,  1,  0, -1,  0,  0,  2,  1,  0, -1,  2,  1,  0, -1,
31376      &  1,  0,  1,  0,  1,  0, -2, -1,  0,  1, -2, -1,  0,  1, -1,
31377      &  0,  1,  1,  0, -1,  2,  1,  0, -1,  2,  1,  0, -1,  2,  0,
31378      &  1, -1,  1, -1,  0,  0,  0, -1, -1,  0,  1,  0,  1,  1,  0,
31379      & -1,  0, -1, -1, -1,  0,  1,  0,  1,  1,  0,  1, -1,  0,  1,
31380      & -1,  0,  0,  1, -1,  0,  1, -1,  0,  0,  1, -1,  0,  0,  0,
31381      &  0,  1,  1,  0,  2,  1,  0,  1,  0,  0,  2,  1,  1, -1, -1,
31382      &  0, -2, -1,  0, -1,  0,  0, -2, -1, -1,  2,  1,  0,  1,  0,
31383      &  0,  2,  1,  1,  2, -2, -1,  0, -1,  0,  0, -2, -1, -1, -2,
31384      &  0,  1, -1, -1,  0,  1,  0, -1,  0,  1, -1,  0,  0,  0,  0,
31385      &  1,  0, -1, -1,  0,  1,  0, -1,  0,  1, -1,  1,  1,  0,  0/
31386 * Particle  baryonic charges
31387       DATA (IIBAR ( I ), I =   1,210 ) /
31388      &  1, -1,  0,  0,  0,  0,  0,  1, -1,  0,  0,  0,  0,  0,  0,
31389      &  0,  1, -1,  0,  1,  1,  1,  0,  0,  0,  0,  0,  0,  0,  0,
31390      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31391      &  0,  0,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,
31392      &  1,  1,  1,  1,  1,  1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31393      & -1,  2,  0,  0,  0,  1,  1,  1,  1,  2,  2,  0,  0,  1,  1,
31394      &  1,  1,  1,  1,  0,  0,  1,  1, -1, -1, -1, -1, -1,  1,  1,
31395      &  1,  1,  1,  1, -1, -1, -1, -1, -1, -1,  0,  0,  0,  0,  0,
31396      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31397      &  0,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1, -1, -1,
31398      & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,  1,  1,  1,  1,  1,
31399      &  1,  1,  1,  1,  1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31400      &  0,  0,  0, -1, -1,  0,  0,  0,  0,  0,  0,  0,  0,  1, -1,
31401      &  1,  1,  1, -1, -1, -1,  1,  1, -1, -1,  1, -1,  1,  1,  0/
31402 * First number of decay channels used for resonances
31403 * and decaying particles
31404       DATA K1/   1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 16, 17,
31405      &  18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
31406      &   2*330, 46, 51, 52, 54, 55, 58,
31407 *                                                             50
31408      &  60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
31409      & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
31410      & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
31411 *                                         85
31412      & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
31413      & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
31414      & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
31415      & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
31416      & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
31417      & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
31418      & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
31419      & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
31420      & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
31421      & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
31422      & 590, 596, 602 /
31423 * Last number of decay channels used for resonances
31424 * and decaying particles
31425       DATA K2/   1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 15, 16, 17,
31426      & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
31427      & 2* 330, 50, 51, 53, 54, 57,
31428 *                                                                 50
31429      & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
31430      & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
31431      & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
31432 *                                              85
31433      & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
31434      & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
31435      & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
31436      & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
31437      & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
31438      & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
31439      & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
31440      & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
31441      & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
31442      & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
31443      & 589, 595, 601, 602 /
31444
31445        END
31446
31447 *$ CREATE DT_BLKD47.FOR
31448 *COPY DT_BLKD47
31449 *
31450 *===blkd47=============================================================*
31451 *
31452       BLOCK DATA DT_BLKD47
31453
31454       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31455       SAVE
31456
31457 * HADRIN: decay channel information
31458       PARAMETER (IDMAX9=602)
31459       CHARACTER*8 ZKNAME
31460       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
31461
31462 * Name of decay channel
31463 * Designation N*@ means N*@1(1236)
31464 * @1=# means ++,  @1 = = means --
31465 * Designation  P+/0/- means Pi+/Pi0/Pi- , respectively
31466       DATA (ZKNAME(K),K=  1, 85) /
31467      &  'P       ','AP      ','E-      ','E+      ','NUE     ',
31468      &  'ANUE    ','GAM     ','PE-NUE  ','APEANU  ','EANUNU  ',
31469      &  'E-NUAN  ','3PI0    ','PI+-0   ','PIMUNU  ','PIE-NU  ',
31470      &  'MU+NUE  ','MU-NUE  ','MU+NUE  ','PI+PI0  ','PI++-   ',
31471      &  'PI+00   ','M+P0NU  ','E+P0NU  ','MU-NU   ','PI-0    ',
31472      &  'PI+--   ','PI-00   ','M-P0NU  ','E-P0NU  ','PPI-    ',
31473      &  'NPI0    ','PD-NUE  ','PM-NUE  ','APPI+   ','ANPI0   ',
31474      &  'APE+NU  ','APM+NU  ','PI+PI-  ','PI0PI0  ','NPI-    ',
31475      &  'PPI0    ','NPI+    ','LAGA    ','GAGA    ','GAE+E-  ',
31476      &  'GAGA    ','GAGAP0  ','PI000   ','PI+-0   ','PI+-GA  ',
31477      &  'PI+0    ','PI+-    ','PI00    ','PI-0    ','PI+-0   ',
31478      &  'PI+-    ','PI0GA   ','K+PI0   ','K0PI+   ','KOPI0   ',
31479      &  'K+PI-   ','K-PI0   ','AK0PI-  ','AK0PI0  ','K-PI+   ',
31480      &  'K+PI0   ','K0PI+   ','K0PI0   ','K+PI-   ','K-PI0   ',
31481      &  'K0PI-   ','AK0PI0  ','K-PI+   ','K+PI0   ','K0PI+   ',
31482      &  'K+89P0  ','K08PI+  ','K+RO77  ','K0RO+7  ','K+OM07  ',
31483      &  'K+E055  ','K0PI0   ','K+PI+   ','K089P0  ','K+8PI-  '  /
31484       DATA (ZKNAME(K),K= 86,170) /
31485      &  'K0R077  ','K+R-77  ','K+R-77  ','K0OM07  ','K0E055  ',
31486      &  'K-PI0   ','K0PI-   ','K-89P0  ','AK08P-  ','K-R077  ',
31487      &  'AK0R-7  ','K-OM07  ','K-E055  ','AK0PI0  ','K-PI+   ',
31488      &  'AK08P0  ','K-8PI+  ','AK0R07  ','AK0OM7  ','AK0E05  ',
31489      &  'LA0PI+  ','SI0PI+  ','SI+PI0  ','LA0PI0  ','SI+PI-  ',
31490      &  'SI-PI+  ','LA0PI-  ','SI0PI-  ','NEUAK0  ','PK-     ',
31491      &  'SI+PI-  ','SI0PI0  ','SI-PI+  ','LA0ET0  ','S+1PI-  ',
31492      &  'S-1PI+  ','SO1PI0  ','NEUAK0  ','PK-     ','LA0PI0  ',
31493      &  'LA0OM0  ','LA0RO0  ','SI+RO-  ','SI-RO+  ','SI0RO0  ',
31494      &  'LA0ET0  ','SI0ET0  ','SI+PI-  ','SI-PI+  ','SI0PI0  ',
31495      &  'K0S     ','K0L     ','K0S     ','K0L     ','P PI+   ',
31496      &  'P PI0   ','N PI+   ','P PI-   ','N PI0   ','N PI-   ',
31497      &  'P PI+   ','N*#PI0  ','N*+PI+  ','PRHO+   ','P PI0   ',
31498      &  'N PI+   ','N*#PI-  ','N*+PI0  ','N*0PI+  ','PRHO0   ',
31499      &  'NRHO+   ','P PI-   ','N PI0   ','N*+PI-  ','N*0PI0  ',
31500      &  'N*-PI+  ','PRHO-   ','NRHO0   ','N PI-   ','N*0PI-  ',
31501      &  'N*-PI0  ','NRHO-   ','PETA0   ','N*#PI-  ','N*+PI0  '  /
31502       DATA (ZKNAME(K),K=171,255) /
31503      &  'N*0PI+  ','PRHO0   ','NRHO+   ','NETA0   ','N*+PI-  ',
31504      &  'N*0PI0  ','N*-PI+  ','PRHO-   ','NRHO0   ','P PI0   ',
31505      &  'N PI+   ','N*#PI-  ','N*+PI0  ','N*0PI+  ','PRHO0   ',
31506      &  'NRHO+   ','P PI-   ','N PI0   ','N*+PI-  ','N*0PI0  ',
31507      &  'N*-PI+  ','PRHO-   ','NRHO0   ','P PI0   ','N PI+   ',
31508      &  'PRHO0   ','NRHO+   ','LAMK+   ','S+ K0   ','S0 K+   ',
31509      &  'PETA0   ','P PI-   ','N PI0   ','PRHO-   ','NRHO0   ',
31510      &  'LAMK0   ','S0 K0   ','S- K+   ','NETA/   ','APPI-   ',
31511      &  'APPI0   ','ANPI-   ','APPI+   ','ANPI0   ','ANPI+   ',
31512      &  'APPI-   ','AN*=P0  ','AN*-P-  ','APRHO-  ','APPI0   ',
31513      &  'ANPI-   ','AN*=P+  ','AN*-P0  ','AN*0P-  ','APRHO0  ',
31514      &  'ANRHO-  ','APPI+   ','ANPI0   ','AN*-P+  ','AN*0P0  ',
31515      &  'AN*+P-  ','APRHO+  ','ANRHO0  ','ANPI+   ','AN*0P+  ',
31516      &  'AN*+P0  ','ANRHO+  ','APPI0   ','ANPI-   ','AN*=P+  ',
31517      &  'AN*-P0  ','AN*0P-  ','APRHO0  ','ANRHO-  ','APPI+,  ',
31518      &  'ANPI0   ','AN*-P+  ','AN*0P0  ','AN*+P-  ','APRHO+  ',
31519      &  'ANRHO0  ','PN*014  ','NN*=14  ','PI+0    ','PI+-    '  /
31520       DATA (ZKNAME(K),K=256,340) /
31521      &  'PI-0    ','P+0     ','N++     ','P+-     ','P00     ',
31522      &  'N+0     ','N+-     ','N00     ','P-0     ','N-0     ',
31523      &  'P--     ','PPPI0   ','PNPI+   ','PNPI0   ','PPPI-   ',
31524      &  'NNPI+   ','APPPI0  ','APNPI+  ','ANNPI0  ','ANPPI-  ',
31525      &  'APNPI0  ','APPPI-  ','ANNPI-  ','K+PPI0  ','K+NPI+  ',
31526      &  'K0PPI0  ','K-PPI0  ','K-NPI+  ','AKPPI-  ','AKNPI0  ',
31527      &  'K+NPI0  ','K+PPI-  ','K0PPI0  ','K0NPI+  ','K-NPI0  ',
31528      &  'K-PPI-  ','AKNPI-  ','PAK0    ','SI+PI0  ','SI0PI+  ',
31529      &  'SI+ETA  ','S+1PI0  ','S01PI+  ','NEUK-   ','LA0PI-  ',
31530      &  'SI-OM0  ','LA0RO-  ','SI0RO-  ','SI-RO0  ','SI-ET0  ',
31531      &  'SI0PI-  ','SI-0    ','BLANC   ','BLANC   ','BLANC   ',
31532      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31533      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31534      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31535      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31536      &  'EPI+-   ','EPI00   ','GAPI+-  ','GAGA*   ','K+-     ',
31537      &  'KLKS    ','PI+-0   ','EGA     ','LPI0    ','LPI     '  /
31538       DATA (ZKNAME(K),K=341,425) /
31539      &  'APPI0   ','ANPI-   ','ALAGA   ','ANPI    ','ALPI0   ',
31540      &  'ALPI+   ','LAPI+   ','SI+PI0  ','SI0PI+  ','LAPI0   ',
31541      &  'SI+PI-  ','SI-PI+  ','LAPI-   ','SI-PI0  ','SI0PI-  ',
31542      &  'TE0PI0  ','TE-PI+  ','TE0PI-  ','TE-PI0  ','TE0PI   ',
31543      &  'TE-PI   ','LAK-    ','ALPI-   ','AS-PI0  ','AS0PI-  ',
31544      &  'ALPI0   ','AS+PI-  ','AS-PI+  ','ALPI+   ','AS+PI0  ',
31545      &  'AS0PI+  ','AT0PI0  ','AT+PI-  ','AT0PI+  ','AT+PI0  ',
31546      &  'AT0PI   ','AT+PI   ','ALK+    ','K-PI+   ','K-PI+0  ',
31547      &  'K0PI+-  ','K0PI0   ','K-PI++  ','AK0PI+  ','K+PI--  ',
31548      &  'K0PI-   ','K+PI-   ','K+PI-0  ','AKPI-+  ','AK0PI0  ',
31549      &  'ETAPIF  ','K++-    ','K+AK0   ','ETAPI-  ','K--+    ',
31550      &  'K-K0    ','PI00    ','PI+-    ','GAGA    ','D0PI0   ',
31551      &  'D0GA    ','D0PI+   ','D+PI0   ','DFGA    ','AD0PI-  ',
31552      &  'D-PI0   ','D-GA    ','AD0PI0  ','AD0GA   ','F+GA    ',
31553      &  'F+GA    ','F-GA    ','F-GA    ','PSPI+-  ','PSPI00  ',
31554      &  'PSETA   ','E+E-    ','MUE+-   ','PI+-0   ','M+NN    ',
31555      &  'E+NN    ','RHO+NT  ','PI+ANT  ','K*+ANT  ','M-NN    '  /
31556       DATA (ZKNAME(K),K=426,510) /
31557      &  'E-NN    ','RHO-NT  ','PI-NT   ','K*-NT   ','NUET    ',
31558      &  'ANUET   ','NUEM    ','ANUEM   ','SI+ETA  ','SI+ET*  ',
31559      &  'PAK0    ','TET0K+  ','SI*+ET  ','N*+AK0  ','N*++K-  ',
31560      &  'LAMRO+  ','SI0RO+  ','SI+RO0  ','SI+OME  ','PAK*0   ',
31561      &  'N*+AK*  ','N*++K*  ','SI+AK0  ','TET0PI  ','SI+AK*  ',
31562      &  'TET0RO  ','SI0AK*  ','SI+K*-  ','TET0OM  ','TET-RO  ',
31563      &  'SI*0AK  ','C0+PI+  ','C0+PI0  ','C0+PI-  ','A+GAM   ',
31564      &  'A0GAM   ','TET0AK  ','TET0K*  ','OM-RO+  ','OM-PI+  ',
31565      &  'C1++AK  ','A+PI+   ','C0+AK0  ','A0PI+   ','A+AK0   ',
31566      &  'T0PI+   ','ASI-ET  ','ASI-E*  ','APK0    ','ATET0K  ',
31567      &  'ASI*-E  ','AN*-K0  ','AN*--K  ','ALAMRO  ','ASI0RO  ',
31568      &  'ASI-RO  ','ASI-OM  ','APK*0   ','AN*-K*  ','AN*--K  ',
31569      &  'ASI-K0  ','ATETPI  ','ASI-K*  ','ATETRO  ','ASI0K*  ',
31570      &  'ASI-K*  ','ATE0OM  ','ATE+RO  ','ASI*0K  ','AC-PI-  ',
31571      &  'AC-PI0  ','AC-PI+  ','AA-GAM  ','AA0GAM  ','ATET0K  ',
31572      &  'ATE0K*  ','AOM+RO  ','AOM+PI  ','AC1--K  ','AA-PI-  ',
31573      &  'AC0-K0  ','AA0PI-  ','AA-K0   ','AT0PI-  ','C1++GA  '  /
31574       DATA (ZKNAME(K),K=511,540) /
31575      &  'C1++GA  ','C10GAM  ','S+GAM   ','S0GAM   ','T0GAM   ',
31576      &  'XU++GA  ','XD+GAM  ','XS+GAM  ','A+AKPI  ','T02PI+  ',
31577      &  'C1++2K  ','AC1--G  ','AC1-GA  ','AC10GA  ','AS-GAM  ',
31578      &  'AS0GAM  ','AT0GAM  ','AXU--G  ','AXD-GA  ','AXS-GA  ',
31579      &  'AA-KPI  ','AT02PI  ','AC1--K  ','RH-PI+  ','RH+PI-  ',
31580      &  'RH3PI0  ','RH0PI+  ','RH+PI0  ','RH0PI-  ','RH-PI0  '  /
31581       DATA (ZKNAME(I),I=541,602)/
31582      & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
31583      & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
31584      & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
31585      & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
31586      & 'PI+PI-','K+K-  ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
31587      & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
31588      & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
31589      & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
31590      & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
31591 * Weight of decay channel
31592       DATA (WT(K),K=  1, 85) /
31593      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31594      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31595      &   .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
31596      &   .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
31597      &   .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
31598      &   .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
31599      &   .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
31600      &   .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
31601      &   .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
31602      &   .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
31603      &   .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
31604      &   .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
31605      &   .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
31606      &   .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
31607      &   .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
31608      &   .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
31609      &   .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00  /
31610       DATA (WT(K),K= 86,170) /
31611      &   .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
31612      &   .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
31613      &   .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
31614      &   .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
31615      &   .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
31616      &   .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
31617      &   .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
31618      &   .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
31619      &   .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
31620      &   .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
31621      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
31622      &   .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31623      &   .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31624      &   .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31625      &   .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31626      &   .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31627      &   .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00  /
31628       DATA (WT(K),K=171,255) /
31629      &   .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
31630      &   .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
31631      &   .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
31632      &   .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
31633      &   .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
31634      &   .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
31635      &   .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
31636      &   .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
31637      &   .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31638      &   .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31639      &   .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31640      &   .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31641      &   .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31642      &   .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
31643      &   .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
31644      &   .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
31645      &   .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01  /
31646       DATA (WT(K),K=256,340) /
31647      &   .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
31648      &   .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
31649      &   .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
31650      &   .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
31651      &   .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
31652      &   .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
31653      &   .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
31654      &   .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
31655      &   .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
31656      &   .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
31657      &   .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01,
31658      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31659      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31660      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31661      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31662      &   .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
31663      &   .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01  /
31664       DATA (WT(K),K=341,425) /
31665      &   .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
31666      &   .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
31667      &   .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
31668      &   .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
31669      &   .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
31670      &   .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
31671      &   .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
31672      &   .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
31673      &   .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
31674      &   .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
31675      &   .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
31676      &   .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
31677      &   .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
31678      &   .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
31679      &   .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
31680      &   .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
31681      &   .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00  /
31682       DATA (WT(K),K=426,510) /
31683      &   .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
31684      &   .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
31685      &   .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
31686      &   .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
31687      &   .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
31688      &   .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
31689      &   .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31690      &   .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
31691      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
31692      &   .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
31693      &   .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
31694      &   .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
31695      &   .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
31696      &   .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
31697      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
31698      &   .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
31699      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01  /
31700       DATA (WT(K),K=511,540) /
31701      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31702      &   .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
31703      &   .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31704      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31705      &   .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
31706      &   .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00  /
31707 C
31708       DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
31709      & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
31710      & .125D+00,  0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
31711      & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
31712      & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
31713      & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
31714      & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
31715 * Particle numbers in decay channel
31716       DATA (NZK(K,1),K=  1,170) /
31717      &     1,   2,   3,   4,   5,   6,   7,   1,   2,   4,
31718      &     3,  23,  13,  13,  13,  10,  11,  10,  13,  13,
31719      &    13,  10,   4,  11,  14,  14,  14,  11,   3,   1,
31720      &     8,   1,   1,   2,   9,   2,   2,  13,  23,   8,
31721      &     1,   8,  17,   7,   7,   7,  23,  23,  13,  13,
31722      &    13,  13,  23,  14,  13,  13,  23,  15,  24,  24,
31723      &    15,  16,  25,  25,  16,  15,  24,  24,  15,  16,
31724      &    24,  25,  16,  15,  24,  36,  37,  15,  24,  15,
31725      &    15,  24,  15,  37,  36,  24,  15,  24,  24,  16,
31726      &    24,  38,  39,  16,  25,  16,  16,  25,  16,  39,
31727      &    38,  25,  16,  25,  25,  17,  22,  21,  17,  21,
31728      &    20,  17,  22,   8,   1,  21,  22,  20,  17,  48,
31729      &    50,  49,   8,   1,  17,  17,  17,  21,  20,  22,
31730      &    17,  22,  21,  20,  22,  19,  12,  19,  12,   1,
31731      &     1,   8,   1,   8,   8,   1,  53,  54,   1,   1,
31732      &     8,  53,  54,  55,   1,   8,   1,   8,  54,  55,
31733      &    56,   1,   8,   8,  55,  56,   8,   1,  53,  54  /
31734       DATA (NZK(K,1),K=171,340) /
31735      &    55,   1,   8,   8,  54,  55,  56,   1,   8,   1,
31736      &     8,  53,  54,  55,   1,   8,   1,   8,  54,  55,
31737      &    56,   1,   8,   1,   8,   1,   8,  17,  21,  22,
31738      &     1,   1,   8,   1,   8,  17,  22,  20,   8,   2,
31739      &     2,   9,   2,   9,   9,   2,  67,  68,   2,   2,
31740      &     9,  67,  68,  69,   2,   9,   2,   9,  68,  69,
31741      &    70,   2,   9,   9,  69,  70,   9,   2,   9,  67,
31742      &    68,  69,   2,   9,   2,   9,  68,  69,  70,   2,
31743      &     9,   1,   8,  13,  13,  14,   1,   8,   1,   1,
31744      &     8,   8,   8,   1,   8,   1,   1,   1,   1,   1,
31745      &     8,   2,   2,   9,   9,   2,   2,   9,  15,  15,
31746      &    24,  16,  16,  25,  25,  15,  15,  24,  24,  16,
31747      &    16,  25,   1,  21,  22,  21,  48,  49,   8,  17,
31748      &    20,  17,  22,  20,  20,  22,  20,   0,   0,   0,
31749      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31750      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31751      &    31,  31,  13,   7,  15,  12,  13,  31,  17,  17  /
31752       DATA (NZK(K,1),K=341,510) /
31753      &     2,   9,  18,   9,  18,  18,  17,  21,  22,  17,
31754      &    21,  20,  17,  20,  22,  97,  98,  97,  98,  97,
31755      &    98,  17,  18,  99, 100,  18, 101,  99,  18, 101,
31756      &   100, 102, 103, 102, 103, 102, 103,  18,  16,  16,
31757      &    24,  24,  16,  25,  15,  24,  15,  15,  25,  25,
31758      &    31,  15,  15,  31,  16,  16,  23,  13,   7, 116,
31759      &   116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
31760      &   120, 121, 121, 130, 130, 130,   4,  10,  13,  10,
31761      &     4,  32,  13,  36,  11,   3,  34,  14,  38, 133,
31762      &   134, 135, 136,  21,  21,   1,  97, 104,  54,  53,
31763      &    17,  22,  21,  21,   1,  54,  53,  21,  97,  21,
31764      &    97,  22,  21,  97,  98, 105, 137, 137, 137, 138,
31765      &   139,  97,  97, 109, 109, 140, 138, 137, 139, 138,
31766      &   145,  99,  99,   2, 102, 110,  68,  67,  18, 100,
31767      &    99,  99,   2,  68,  67,  99, 102,  99, 102, 100,
31768      &    99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
31769      &   113, 115, 115, 152, 150, 149, 151, 150, 157, 140  /
31770       DATA (NZK(K,1),K=511,540) /
31771      &   141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
31772      &   140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
31773      &   150, 157, 152,  34,  32,  33,  33,  32,  33,  34  /
31774       DATA (NZK(I,1),I=541,602) /  2, 67, 68, 69,  2,  9,  9, 68, 69,
31775      & 70,  2,  9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
31776      & 14, 189, 23, 13, 15, 24,  36,  38,  37,  39, 194, 195, 196, 197,
31777      & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
31778      & 55, 8, 1, 8, 8, 54, 55, 210/
31779       DATA (NZK(K,2),K=  1,170) /
31780      &     0,   0,   0,   0,   0,   0,   0,   3,   4,   6,
31781      &     5,  23,  14,  11,   3,   5,   5,   5,  23,  13,
31782      &    23,  23,  23,   5,  23,  13,  23,  23,  23,  14,
31783      &    23,   3,  11,  13,  23,   4,  10,  14,  23,  14,
31784      &    23,  13,   7,   7,   4,   7,   7,  23,  14,  14,
31785      &    23,  14,  23,  23,  14,  14,   7,  23,  13,  23,
31786      &    14,  23,  14,  23,  13,  23,  13,  23,  14,  23,
31787      &    14,  23,  13,  23,  13,  23,  13,  33,  32,  35,
31788      &    31,  23,  14,  23,  14,  33,  34,  35,  31,  23,
31789      &    14,  23,  14,  33,  34,  35,  31,  23,  13,  23,
31790      &    13,  33,  32,  35,  31,  13,  13,  23,  23,  14,
31791      &    13,  14,  14,  25,  16,  14,  23,  13,  31,  14,
31792      &    13,  23,  25,  16,  23,  35,  33,  34,  32,  33,
31793      &    31,  31,  14,  13,  23,   0,   0,   0,   0,  13,
31794      &    23,  13,  14,  23,  14,  13,  23,  13,  78,  23,
31795      &    13,  14,  23,  13,  79,  78,  14,  23,  14,  23,
31796      &    13,  80,  79,  14,  14,  23,  80,  31,  14,  23  /
31797       DATA (NZK(K,2),K=171,340) /
31798      &    13,  79,  78,  31,  14,  23,  13,  80,  79,  23,
31799      &    13,  14,  23,  13,  79,  78,  14,  23,  14,  23,
31800      &    13,  80,  79,  23,  13,  33,  32,  15,  24,  15,
31801      &    31,  14,  23,  34,  33,  24,  24,  15,  31,  14,
31802      &    23,  14,  13,  23,  13,  14,  23,  14,  80,  23,
31803      &    14,  13,  23,  14,  79,  80,  13,  23,  13,  23,
31804      &    14,  78,  79,  13,  13,  23,  78,  23,  14,  13,
31805      &    23,  14,  79,  80,  13,  23,  13,  23,  14,  78,
31806      &    79,  62,  61,  23,  14,  23,  13,  13,  13,  23,
31807      &    13,  13,  23,  14,  14,  14,   1,   8,   8,   1,
31808      &     8,   1,   8,   8,   1,   8,   1,   8,   1,   8,
31809      &     1,   1,   8,   1,   8,   8,   1,   1,   8,   8,
31810      &     1,   8,  25,  23,  13,  31,  23,  13,  16,  14,
31811      &    35,  34,  34,  33,  31,  14,  23,   0,   0,   0,
31812      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31813      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31814      &    13,  23,  14,   7,  16,  19,  14,   7,  23,  14  /
31815       DATA (NZK(K,2),K=341,510) /
31816      &    23,  14,   7,  13,  23,  13,  13,  23,  13,  23,
31817      &    14,  13,  14,  23,  14,  23,  13,  14,  23,  14,
31818      &    23,  16,  14,  23,  14,  23,  14,  13,  13,  23,
31819      &    13,  23,  14,  13,  23,  13,  23,  15,  13,  13,
31820      &    13,  23,  13,  13,  14,  14,  14,  14,  14,  23,
31821      &    13,  16,  25,  14,  15,  24,  23,  14,   7,  23,
31822      &     7,  13,  23,   7,  14,  23,   7,  23,   7,   7,
31823      &     7,   7,   7,  13,  23,  31,   3,  11,  14, 135,
31824      &     5, 134, 134, 134, 136,   6, 133, 133, 133,   0,
31825      &     0,   0,   0,  31,  95,  25,  15,  31,  95,  16,
31826      &    32,  32,  33,  35,  39,  39,  38,  25,  13,  39,
31827      &    32,  39,  38,  35,  32,  39,  13,  23,  14,   7,
31828      &     7,  25,  37,  32,  13,  25,  13,  25,  13,  25,
31829      &    13,  31,  95,  24,  16,  31,  24,  15,  34,  34,
31830      &    33,  35,  37,  37,  36,  24,  14,  37,  34,  37,
31831      &    36,  35,  34,  37,  14,  23,  13,   7,   7,  24,
31832      &    39,  34,  14,  24,  14,  24,  14,  24,  14,   7  /
31833       DATA (NZK(K,2),K=511,540) /
31834      &     7,   7,   7,   7,   7,   7,   7,   7,  25,  13,
31835      &    25,   7,   7,   7,   7,   7,   7,   7,   7,   7,
31836      &    24,  14,  24,  13,  14,  23,  13,  23,  14,  23  /
31837       DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
31838      & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
31839      & 14, 14, 23, 14, 16, 25,
31840      & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
31841      & 23, 13, 14, 23,  0 /
31842       DATA (NZK(K,3),K=  1,170) /
31843      &     0,   0,   0,   0,   0,   0,   0,   5,   6,   5,
31844      &     6,  23,  23,   5,   5,   0,   0,   0,   0,  14,
31845      &    23,   5,   5,   0,   0,  14,  23,   5,   5,   0,
31846      &     0,   5,   5,   0,   0,   5,   5,   0,   0,   0,
31847      &     0,   0,   0,   0,   3,   0,   7,  23,  23,   7,
31848      &     0,   0,   0,   0,  23,   0,   0,   0,   0,   0,
31849      &     110*0   /
31850       DATA (NZK(K,3),K=171,340) /
31851      &     80*0,
31852      &     0,   0,   0,   0,   0,   0,  23,  13,  14,  23,
31853      &    23,  14,  23,  23,  23,  14,  23,  13,  23,  14,
31854      &    13,  23,  13,  23,  14,  23,  14,  14,  23,  13,
31855      &    13,  23,  13,  14,  23,  23,  14,  23,  13,  23,
31856      &    14,  14,   0,   0,   0,   0,   0,   0,   0,   0,
31857      &     30*0,
31858      &    14,  23,   7,   0,   0,   0,  23,   0,   0,   0  /
31859       DATA (NZK(K,3),K=341,510) /
31860      &     30*0,
31861      &     0,   0,   0,   0,   0,   0,   0,   0,   0,  23,
31862      &    14,   0,  13,   0,  14,   0,   0,  23,  13,   0,
31863      &     0,  15,   0,   0,  16,   0,   0,   0,   0,   0,
31864      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31865      &     0,   0,   0,  14,  23,   0,   0,   0,  23, 134,
31866      &   134,   0,   0,   0, 133, 133,   0,   0,   0,   0,
31867      &     80*0  /
31868       DATA (NZK(K,3),K=511,540) /
31869      &     0,   0,   0,   0,   0,   0,   0,   0,  13,  13,
31870      &    25,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31871      &    14,  14,  24,   0,   0,   0,   0,   0,   0,   0  /
31872       DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
31873      & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
31874
31875       END
31876
31877 *$ CREATE DT_BDEVAP.FOR
31878 *COPY DT_BDEVAP
31879 *
31880 *=== bdevap ===========================================================*
31881 *
31882       BLOCK DATA DT_BDEVAP
31883
31884 C     INCLUDE '(DBLPRC)'
31885 * DBLPRC.ADD
31886       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31887       SAVE
31888 * (original name: GLOBAL)
31889       PARAMETER ( KALGNM = 2 )
31890       PARAMETER ( ANGLGB = 5.0D-16 )
31891       PARAMETER ( ANGLSQ = 2.5D-31 )
31892       PARAMETER ( AXCSSV = 0.2D+16 )
31893       PARAMETER ( ANDRFL = 1.0D-38 )
31894       PARAMETER ( AVRFLW = 1.0D+38 )
31895       PARAMETER ( AINFNT = 1.0D+30 )
31896       PARAMETER ( AZRZRZ = 1.0D-30 )
31897       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
31898       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
31899       PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
31900       PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
31901       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
31902       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
31903       PARAMETER ( CSNNRM = 2.0D-15 )
31904       PARAMETER ( DMXTRN = 1.0D+08 )
31905       PARAMETER ( ZERZER = 0.D+00 )
31906       PARAMETER ( ONEONE = 1.D+00 )
31907       PARAMETER ( TWOTWO = 2.D+00 )
31908       PARAMETER ( THRTHR = 3.D+00 )
31909       PARAMETER ( FOUFOU = 4.D+00 )
31910       PARAMETER ( FIVFIV = 5.D+00 )
31911       PARAMETER ( SIXSIX = 6.D+00 )
31912       PARAMETER ( SEVSEV = 7.D+00 )
31913       PARAMETER ( EIGEIG = 8.D+00 )
31914       PARAMETER ( ANINEN = 9.D+00 )
31915       PARAMETER ( TENTEN = 10.D+00 )
31916       PARAMETER ( HLFHLF = 0.5D+00 )
31917       PARAMETER ( ONETHI = ONEONE / THRTHR )
31918       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
31919       PARAMETER ( ONEFOU = ONEONE / FOUFOU )
31920       PARAMETER ( THRTWO = THRTHR / TWOTWO )
31921       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
31922       PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
31923       PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
31924       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
31925       PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
31926       PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
31927       PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
31928       PARAMETER ( EULERO = 0.577215664901532860606512      D+00 )
31929       PARAMETER ( EULEXP = 1.781072417990197985236504      D+00 )
31930       PARAMETER ( EULLOG =-0.5495393129816448223376619     D+00 )
31931       PARAMETER ( E1M2EU = 0.8569023337737540831433017     D+00 )
31932       PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
31933       PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
31934       PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
31935       PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
31936       PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
31937       PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
31938       PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
31939       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
31940       PARAMETER ( CLIGHT = 2.99792458         D+10 )
31941       PARAMETER ( AVOGAD = 6.0221367          D+23 )
31942       PARAMETER ( BOLTZM = 1.380658           D-23 )
31943       PARAMETER ( AMELGR = 9.1093897          D-28 )
31944       PARAMETER ( PLCKBR = 1.05457266         D-27 )
31945       PARAMETER ( ELCCGS = 4.8032068          D-10 )
31946       PARAMETER ( ELCMKS = 1.60217733         D-19 )
31947       PARAMETER ( AMUGRM = 1.6605402          D-24 )
31948       PARAMETER ( AMMUMU = 0.113428913        D+00 )
31949       PARAMETER ( AMPRMU = 1.007276470        D+00 )
31950       PARAMETER ( AMNEMU = 1.008664904        D+00 )
31951       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
31952       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
31953       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
31954       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
31955       PARAMETER ( PLABRC = 0.197327053        D+00 )
31956       PARAMETER ( AMELCT = 0.51099906         D-03 )
31957       PARAMETER ( AMUGEV = 0.93149432         D+00 )
31958       PARAMETER ( AMMUON = 0.105658389        D+00 )
31959       PARAMETER ( AMPRTN = 0.93827231         D+00 )
31960       PARAMETER ( AMNTRN = 0.93956563         D+00 )
31961       PARAMETER ( AMDEUT = 1.87561339         D+00 )
31962       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
31963      &                   * 1.D-09 )
31964       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
31965       PARAMETER ( BLTZMN = 8.617385           D-14 )
31966       PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
31967       PARAMETER ( GFOHB3 = 1.16639            D-05 )
31968       PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
31969       PARAMETER ( SIN2TW = 0.2319             D+00 )
31970       PARAMETER ( GEVMEV = 1.0                D+03 )
31971       PARAMETER ( EMVGEV = 1.0                D-03 )
31972       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
31973       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
31974       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
31975       LOGICAL LGBIAS, LGBANA
31976       COMMON /FKGLOB/ LGBIAS, LGBANA
31977 C     INCLUDE '(DIMPAR)'
31978 * DIMPAR.ADD
31979       PARAMETER ( MXXRGN = 5000 )
31980       PARAMETER ( MXXMDF = 82   )
31981       PARAMETER ( MXXMDE = 54   )
31982       PARAMETER ( MFSTCK = 1000 )
31983       PARAMETER ( MESTCK = 100  )
31984       PARAMETER ( NELEMX = 80   )
31985       PARAMETER ( MPDPDX = 8    )
31986       PARAMETER ( ICOMAX = 180  )
31987       PARAMETER ( NSTBIS = 304  )
31988       PARAMETER ( IDMAXP = 220  )
31989       PARAMETER ( IDMXDC = 640  )
31990       PARAMETER ( MKBMX1 = 1    )
31991       PARAMETER ( MKBMX2 = 1    )
31992 C     INCLUDE '(IOUNIT)'
31993 * IOUNIT.ADD
31994       PARAMETER ( LUNIN  =  5 )
31995       PARAMETER ( LUNOUT =  6 )
31996 **sr 19.5. set error output-unit from 15 to 6
31997       PARAMETER ( LUNERR = 6  )
31998       PARAMETER ( LUNBER = 14 )
31999       PARAMETER ( LUNECH =  8 )
32000       PARAMETER ( LUNFLU = 13 )
32001       PARAMETER ( LUNGEO = 16 )
32002       PARAMETER ( LUNPMF = 12 )
32003       PARAMETER ( LUNRAN =  2 )
32004       PARAMETER ( LUNXSC =  9 )
32005       PARAMETER ( LUNDET = 17 )
32006       PARAMETER ( LUNRAY = 10 )
32007       PARAMETER ( LUNRDB =  1 )
32008       PARAMETER ( LUNPGO =  7 )
32009       PARAMETER ( LUNPGS =  4 )
32010       PARAMETER ( LUNSCR =  3 )
32011 *
32012 *----------------------------------------------------------------------*
32013 *                                                                      *
32014 *     Block Data for the EVAPoration routines:                         *
32015 *                                                                      *
32016 *     Created on    20 may 1990    by    Alfredo Ferrari & Paola Sala  *
32017 *                                                   Infn - Milan       *
32018 *                                                                      *
32019 *     Modified from the original version of J.M.Zazula                 *
32020 *     and, for cookcm, from a LAHET block data kindly provided by      *
32021 *     R.E.Prael-LANL                                                   *
32022 *                                                                      *
32023 *     Last change on  20-feb-95    by    Alfredo Ferrari               *
32024 *                                                                      *
32025 *                                                                      *
32026 *----------------------------------------------------------------------*
32027 *
32028 * (original name: COOKCM)
32029       PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 )
32030       LOGICAL LDEFOZ, LDEFON
32031       PARAMETER ( INCOOK = 150, IZCOOK = 98 )
32032       COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN,
32033      &                SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK),
32034      &                PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK)
32035 * (original name: EVA0)
32036       COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
32037      *                FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
32038      *                CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
32039      *                T (4,7), RMASS (297), ALPH (297), BET (297),
32040      *                APRIME (250), IA (6), IZ (6)
32041 * (original name: HETTP)
32042       COMMON /FKHETP/  NHSTP,NBERTP,IOSUB,INSRS
32043 * (original name: HETC7)
32044       COMMON /FKHET7/ COSKS,SINKS, COSTH,SINTH, COSPHI,SINPHI
32045 * (original name: INPFLG)
32046       COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
32047 *
32048       DATA B0   / 8.D+00 /, Y0 / 1.5D+00 /
32049       DATA IANG / 1 /, IFISS / 1 /,  IB0 / 2 /, IGEOM / 0 /
32050       DATA ISTRAG /0/, KEYDK /0/
32051       DATA NBERTP /LUNBER/
32052       DATA COSTH /ONEONE/, SINTH /ZERZER/, COSPHI /ONEONE/,
32053      &     SINPHI/ZERZER/
32054 *  /cookcm/
32055        DATA ( PZCOOK(I),I =  1, IZCOOK ) /
32056      & 0.000D+00, 5.440D+00, 0.000D+00, 2.760D+00, 0.000D+00, 3.340D+00,
32057      & 0.000D+00, 2.700D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.460D+00,
32058      & 0.000D+00, 2.090D+00, 0.000D+00, 1.620D+00, 0.000D+00, 1.620D+00,
32059      & 0.000D+00, 1.830D+00, 0.000D+00, 1.730D+00, 0.000D+00, 1.350D+00,
32060      & 0.000D+00, 1.540D+00, 0.000D+00, 1.280D+00, 2.600D-01, 8.800D-01,
32061      & 1.900D-01, 1.350D+00,-5.000D-02, 1.520D+00,-9.000D-02, 1.170D+00,
32062      & 4.000D-02, 1.240D+00, 2.900D-01, 1.090D+00, 2.600D-01, 1.170D+00,
32063      & 2.300D-01, 1.150D+00,-8.000D-02, 1.350D+00, 3.400D-01, 1.050D+00,
32064      & 2.800D-01, 1.270D+00, 0.000D+00, 1.050D+00, 0.000D+00, 1.000D+00,
32065      & 9.000D-02, 1.200D+00, 2.000D-01, 1.400D+00, 9.300D-01, 1.000D+00,
32066      &-2.000D-01, 1.190D+00, 9.000D-02, 9.700D-01, 0.000D+00, 9.200D-01,
32067      & 1.100D-01, 6.800D-01, 5.000D-02, 6.800D-01,-2.200D-01, 7.900D-01,
32068      & 9.000D-02, 6.900D-01, 1.000D-02, 7.200D-01, 0.000D+00, 4.000D-01,
32069      & 1.600D-01, 7.300D-01, 0.000D+00, 4.600D-01, 1.700D-01, 8.900D-01,
32070      & 0.000D+00, 7.900D-01, 0.000D+00, 8.900D-01, 0.000D+00, 8.100D-01,
32071      &-6.000D-02, 6.900D-01,-2.000D-01, 7.100D-01,-1.200D-01, 7.200D-01,
32072      & 0.000D+00, 7.700D-01/
32073        DATA ( PNCOOK(I),I =  1, 90 ) /
32074      & 0.000D+00, 5.980D+00, 0.000D+00, 2.770D+00, 0.000D+00, 3.160D+00,
32075      & 0.000D+00, 3.010D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.670D+00,
32076      & 0.000D+00, 1.800D+00, 0.000D+00, 1.670D+00, 0.000D+00, 1.860D+00,
32077      & 0.000D+00, 2.040D+00, 0.000D+00, 1.640D+00, 0.000D+00, 1.440D+00,
32078      & 0.000D+00, 1.540D+00, 0.000D+00, 1.300D+00, 0.000D+00, 1.270D+00,
32079      & 0.000D+00, 1.290D+00, 8.000D-02, 1.410D+00,-8.000D-02, 1.500D+00,
32080      &-5.000D-02, 2.240D+00,-4.700D-01, 1.430D+00,-1.500D-01, 1.440D+00,
32081      & 6.000D-02, 1.560D+00, 2.500D-01, 1.570D+00,-1.600D-01, 1.460D+00,
32082      & 0.000D+00, 9.300D-01, 1.000D-02, 6.200D-01,-5.000D-01, 1.420D+00,
32083      & 1.300D-01, 1.520D+00,-6.500D-01, 8.000D-01,-8.000D-02, 1.290D+00,
32084      &-4.700D-01, 1.250D+00,-4.400D-01, 9.700D-01, 8.000D-02, 1.650D+00,
32085      &-1.100D-01, 1.260D+00,-4.600D-01, 1.060D+00, 2.200D-01, 1.550D+00,
32086      &-7.000D-02, 1.370D+00, 1.000D-01, 1.200D+00,-2.700D-01, 9.200D-01,
32087      &-3.500D-01, 1.190D+00, 0.000D+00, 1.050D+00,-2.500D-01, 1.610D+00,
32088      &-2.100D-01, 9.000D-01,-2.100D-01, 7.400D-01,-3.800D-01, 7.200D-01/
32089        DATA ( PNCOOK(I),I = 91, INCOOK ) /
32090      &-3.400D-01, 9.200D-01,-2.600D-01, 9.400D-01, 1.000D-02, 6.500D-01,
32091      &-3.600D-01, 8.300D-01, 1.100D-01, 6.700D-01, 5.000D-02, 1.000D+00,
32092      & 5.100D-01, 1.040D+00, 3.300D-01, 6.800D-01,-2.700D-01, 8.100D-01,
32093      & 9.000D-02, 7.500D-01, 1.700D-01, 8.600D-01, 1.400D-01, 1.100D+00,
32094      &-2.200D-01, 8.400D-01,-4.700D-01, 4.800D-01, 2.000D-02, 8.800D-01,
32095      & 2.400D-01, 5.200D-01, 2.700D-01, 4.100D-01,-5.000D-02, 3.800D-01,
32096      & 1.500D-01, 6.700D-01, 0.000D+00, 6.100D-01, 0.000D+00, 7.800D-01,
32097      & 0.000D+00, 6.700D-01, 0.000D+00, 6.700D-01, 0.000D+00, 7.900D-01,
32098      & 0.000D+00, 6.000D-01, 4.000D-02, 6.400D-01,-6.000D-02, 4.500D-01,
32099      & 5.000D-02, 2.600D-01,-2.200D-01, 3.900D-01, 0.000D+00, 3.900D-01/
32100        DATA ( SZCOOK(I),I =  1, 98) /
32101      & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
32102      & 0.000D+00, 0.000D+00,-1.100D-01,-8.100D-01,-2.910D+00,-4.170D+00,
32103      &-5.720D+00,-7.800D+00,-8.970D+00,-9.700D+00,-1.010D+01,-1.070D+01,
32104      &-1.138D+01,-1.207D+01,-1.255D+01,-1.324D+01,-1.393D+01,-1.471D+01,
32105      &-1.553D+01,-1.637D+01,-1.736D+01,-1.860D+01,-1.870D+01,-1.801D+01,
32106      &-1.787D+01,-1.708D+01,-1.660D+01,-1.675D+01,-1.650D+01,-1.635D+01,
32107      &-1.622D+01,-1.641D+01,-1.689D+01,-1.643D+01,-1.668D+01,-1.673D+01,
32108      &-1.745D+01,-1.729D+01,-1.744D+01,-1.782D+01,-1.862D+01,-1.827D+01,
32109      &-1.939D+01,-1.991D+01,-1.914D+01,-1.826D+01,-1.740D+01,-1.642D+01,
32110      &-1.577D+01,-1.437D+01,-1.391D+01,-1.310D+01,-1.311D+01,-1.143D+01,
32111      &-1.089D+01,-1.075D+01,-1.062D+01,-1.041D+01,-1.021D+01,-9.850D+00,
32112      &-9.470D+00,-9.030D+00,-8.610D+00,-8.130D+00,-7.460D+00,-7.480D+00,
32113      &-7.200D+00,-7.130D+00,-7.060D+00,-6.780D+00,-6.640D+00,-6.640D+00,
32114      &-7.680D+00,-7.890D+00,-8.410D+00,-8.490D+00,-7.880D+00,-6.300D+00,
32115      &-5.470D+00,-4.780D+00,-4.370D+00,-4.170D+00,-4.130D+00,-4.320D+00,
32116      &-4.550D+00,-5.040D+00,-5.280D+00,-6.060D+00,-6.280D+00,-6.870D+00,
32117      &-7.200D+00,-7.740D+00/
32118        DATA ( SNCOOK(I),I =  1, 90 ) /
32119      & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
32120      & 0.000D+00, 0.000D+00, 1.030D+01, 5.660D+00, 6.800D+00, 7.530D+00,
32121      & 7.550D+00, 7.210D+00, 7.440D+00, 8.070D+00, 8.940D+00, 9.810D+00,
32122      & 1.060D+01, 1.139D+01, 1.254D+01, 1.368D+01, 1.434D+01, 1.419D+01,
32123      & 1.383D+01, 1.350D+01, 1.300D+01, 1.213D+01, 1.260D+01, 1.326D+01,
32124      & 1.413D+01, 1.492D+01, 1.552D+01, 1.638D+01, 1.716D+01, 1.755D+01,
32125      & 1.803D+01, 1.759D+01, 1.903D+01, 1.871D+01, 1.880D+01, 1.899D+01,
32126      & 1.846D+01, 1.825D+01, 1.776D+01, 1.738D+01, 1.672D+01, 1.562D+01,
32127      & 1.438D+01, 1.288D+01, 1.323D+01, 1.381D+01, 1.490D+01, 1.486D+01,
32128      & 1.576D+01, 1.620D+01, 1.762D+01, 1.773D+01, 1.816D+01, 1.867D+01,
32129      & 1.969D+01, 1.951D+01, 2.017D+01, 1.948D+01, 1.998D+01, 1.983D+01,
32130      & 2.020D+01, 1.972D+01, 1.987D+01, 1.924D+01, 1.844D+01, 1.761D+01,
32131      & 1.710D+01, 1.616D+01, 1.590D+01, 1.533D+01, 1.476D+01, 1.354D+01,
32132      & 1.263D+01, 1.065D+01, 1.010D+01, 8.890D+00, 1.025D+01, 9.790D+00,
32133      & 1.139D+01, 1.172D+01, 1.243D+01, 1.296D+01, 1.343D+01, 1.337D+01/
32134        DATA ( SNCOOK(I),I = 91, INCOOK ) /
32135      & 1.296D+01, 1.211D+01, 1.192D+01, 1.100D+01, 1.080D+01, 1.042D+01,
32136      & 1.039D+01, 9.690D+00, 9.270D+00, 8.930D+00, 8.570D+00, 8.020D+00,
32137      & 7.590D+00, 7.330D+00, 7.230D+00, 7.050D+00, 7.420D+00, 6.750D+00,
32138      & 6.600D+00, 6.380D+00, 6.360D+00, 6.490D+00, 6.250D+00, 5.850D+00,
32139      & 5.480D+00, 4.530D+00, 4.300D+00, 3.390D+00, 2.350D+00, 1.660D+00,
32140      & 8.100D-01, 4.600D-01,-9.600D-01,-1.690D+00,-2.530D+00,-3.160D+00,
32141      &-1.870D+00,-4.100D-01, 7.100D-01, 1.660D+00, 2.620D+00, 3.220D+00,
32142      & 3.760D+00, 4.100D+00, 4.460D+00, 4.830D+00, 5.090D+00, 5.180D+00,
32143      & 5.170D+00, 5.100D+00, 5.010D+00, 4.970D+00, 5.090D+00, 5.030D+00,
32144      & 4.930D+00, 5.280D+00, 5.490D+00, 5.500D+00, 5.370D+00, 5.300D+00/
32145       DATA LDEFOZ / 53*.FALSE.,25*.TRUE.,7*.FALSE.,13*.TRUE. /
32146       DATA LDEFON / 85*.FALSE.,37*.TRUE.,7*.FALSE.,21*.TRUE. /
32147 *=== End of Block Data Bdevap =========================================*
32148       END
32149
32150 *$ CREATE DT_BDNOPT.FOR
32151 *COPY DT_BDNOPT
32152 *
32153 *=== bdnopt ===========================================================*
32154 *==                                                                    *
32155       BLOCK DATA DT_BDNOPT
32156
32157 C     INCLUDE '(DBLPRC)'
32158 * DBLPRC.ADD
32159       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32160       SAVE
32161 * (original name: GLOBAL)
32162       PARAMETER ( KALGNM = 2 )
32163       PARAMETER ( ANGLGB = 5.0D-16 )
32164       PARAMETER ( ANGLSQ = 2.5D-31 )
32165       PARAMETER ( AXCSSV = 0.2D+16 )
32166       PARAMETER ( ANDRFL = 1.0D-38 )
32167       PARAMETER ( AVRFLW = 1.0D+38 )
32168       PARAMETER ( AINFNT = 1.0D+30 )
32169       PARAMETER ( AZRZRZ = 1.0D-30 )
32170       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
32171       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
32172       PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
32173       PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
32174       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
32175       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
32176       PARAMETER ( CSNNRM = 2.0D-15 )
32177       PARAMETER ( DMXTRN = 1.0D+08 )
32178       PARAMETER ( ZERZER = 0.D+00 )
32179       PARAMETER ( ONEONE = 1.D+00 )
32180       PARAMETER ( TWOTWO = 2.D+00 )
32181       PARAMETER ( THRTHR = 3.D+00 )
32182       PARAMETER ( FOUFOU = 4.D+00 )
32183       PARAMETER ( FIVFIV = 5.D+00 )
32184       PARAMETER ( SIXSIX = 6.D+00 )
32185       PARAMETER ( SEVSEV = 7.D+00 )
32186       PARAMETER ( EIGEIG = 8.D+00 )
32187       PARAMETER ( ANINEN = 9.D+00 )
32188       PARAMETER ( TENTEN = 10.D+00 )
32189       PARAMETER ( HLFHLF = 0.5D+00 )
32190       PARAMETER ( ONETHI = ONEONE / THRTHR )
32191       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
32192       PARAMETER ( ONEFOU = ONEONE / FOUFOU )
32193       PARAMETER ( THRTWO = THRTHR / TWOTWO )
32194       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
32195       PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
32196       PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
32197       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
32198       PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
32199       PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
32200       PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
32201       PARAMETER ( EULERO = 0.577215664901532860606512      D+00 )
32202       PARAMETER ( EULEXP = 1.781072417990197985236504      D+00 )
32203       PARAMETER ( EULLOG =-0.5495393129816448223376619     D+00 )
32204       PARAMETER ( E1M2EU = 0.8569023337737540831433017     D+00 )
32205       PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
32206       PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
32207       PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
32208       PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
32209       PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
32210       PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
32211       PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
32212       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
32213       PARAMETER ( CLIGHT = 2.99792458         D+10 )
32214       PARAMETER ( AVOGAD = 6.0221367          D+23 )
32215       PARAMETER ( BOLTZM = 1.380658           D-23 )
32216       PARAMETER ( AMELGR = 9.1093897          D-28 )
32217       PARAMETER ( PLCKBR = 1.05457266         D-27 )
32218       PARAMETER ( ELCCGS = 4.8032068          D-10 )
32219       PARAMETER ( ELCMKS = 1.60217733         D-19 )
32220       PARAMETER ( AMUGRM = 1.6605402          D-24 )
32221       PARAMETER ( AMMUMU = 0.113428913        D+00 )
32222       PARAMETER ( AMPRMU = 1.007276470        D+00 )
32223       PARAMETER ( AMNEMU = 1.008664904        D+00 )
32224       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
32225       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
32226       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
32227       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
32228       PARAMETER ( PLABRC = 0.197327053        D+00 )
32229       PARAMETER ( AMELCT = 0.51099906         D-03 )
32230       PARAMETER ( AMUGEV = 0.93149432         D+00 )
32231       PARAMETER ( AMMUON = 0.105658389        D+00 )
32232       PARAMETER ( AMPRTN = 0.93827231         D+00 )
32233       PARAMETER ( AMNTRN = 0.93956563         D+00 )
32234       PARAMETER ( AMDEUT = 1.87561339         D+00 )
32235       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
32236      &                   * 1.D-09 )
32237       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
32238       PARAMETER ( BLTZMN = 8.617385           D-14 )
32239       PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
32240       PARAMETER ( GFOHB3 = 1.16639            D-05 )
32241       PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
32242       PARAMETER ( SIN2TW = 0.2319             D+00 )
32243       PARAMETER ( GEVMEV = 1.0                D+03 )
32244       PARAMETER ( EMVGEV = 1.0                D-03 )
32245       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
32246       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
32247       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
32248       LOGICAL LGBIAS, LGBANA
32249       COMMON /FKGLOB/ LGBIAS, LGBANA
32250 C     INCLUDE '(DIMPAR)'
32251 * DIMPAR.ADD
32252       PARAMETER ( MXXRGN = 5000 )
32253       PARAMETER ( MXXMDF = 82   )
32254       PARAMETER ( MXXMDE = 54   )
32255       PARAMETER ( MFSTCK = 1000 )
32256       PARAMETER ( MESTCK = 100  )
32257       PARAMETER ( NELEMX = 80   )
32258       PARAMETER ( MPDPDX = 8    )
32259       PARAMETER ( ICOMAX = 180  )
32260       PARAMETER ( NSTBIS = 304  )
32261       PARAMETER ( IDMAXP = 220  )
32262       PARAMETER ( IDMXDC = 640  )
32263       PARAMETER ( MKBMX1 = 1    )
32264       PARAMETER ( MKBMX2 = 1    )
32265 C     INCLUDE '(IOUNIT)'
32266 * IOUNIT.ADD
32267       PARAMETER ( LUNIN  =  5 )
32268       PARAMETER ( LUNOUT =  6 )
32269 **sr 19.5. set error output-unit from 15 to 6
32270       PARAMETER ( LUNERR = 6  )
32271       PARAMETER ( LUNBER = 14 )
32272       PARAMETER ( LUNECH =  8 )
32273       PARAMETER ( LUNFLU = 13 )
32274       PARAMETER ( LUNGEO = 16 )
32275       PARAMETER ( LUNPMF = 12 )
32276       PARAMETER ( LUNRAN =  2 )
32277       PARAMETER ( LUNXSC =  9 )
32278       PARAMETER ( LUNDET = 17 )
32279       PARAMETER ( LUNRAY = 10 )
32280       PARAMETER ( LUNRDB =  1 )
32281       PARAMETER ( LUNPGO =  7 )
32282       PARAMETER ( LUNPGS =  4 )
32283       PARAMETER ( LUNSCR =  3 )
32284 *
32285 *----------------------------------------------------------------------*
32286 *                                                                      *
32287 *   Created on  20 september 1989    by  Alfredo Ferrari - Infn Milan  *
32288 *                                                                      *
32289 *         Last change on 20-apr-95   by  Alfredo Ferrari               *
32290 *                                                                      *
32291 *----------------------------------------------------------------------*
32292 *
32293 C     INCLUDE '(BLNKCM)'
32294 * BLNKCM.ADD
32295 **sr 17.5. commented since not used here
32296 C     PARAMETER ( NBLNMX = 1100000 )
32297 C     DIMENSION GMSTOR ( NBLNMX ), BRMBRR ( NBLNMX ), BRMEXP ( NBLNMX ),
32298 C    &          BRMSIG ( NBLNMX ), SIGGTT ( KALGNM*NBLNMX ),
32299 C    &          COMSCO ( NBLNMX ), LBSTOR ( KALGNM*NBLNMX )
32300 C     REAL SIGGTT
32301 C     LOGICAL LBSTOR
32302 C     COMMON   NSTOR  ( KALGNM*NBLNMX )
32303 **
32304 **sr 18.5. commented since not used for evap.
32305 C     COMMON / ADDRCM / MBLNMX, KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST,
32306 C    &                  KISBGN, KISLST, KDTBGN, KDTLST, KUBBGN, KUBLST,
32307 C    &                  KUXBGN, KUXLST, KTCBGN, KTCLST, KRNBGN, KRNLST,
32308 C    &                  KYLBGN, KYLLST, KXSBGN, KXSLST, KIHBGN, KIHLST,
32309 C    &                  KINBGN, KINLST, KIEBGN, KIELST, KETBGN, KETLST,
32310 C    &                  KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST,
32311 C    &                  KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST,
32312 C    &                  KWLBGN, KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST,
32313 C    &                  KWSBGN, KWSLST, KNDBGN, KNDLST, KDPBGN, KDPLST,
32314 C    &                  KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN, KBRLST,
32315 C    &                  KTMBGN
32316 **
32317
32318 C     EQUIVALENCE ( NSTOR (1), GMSTOR (1) )
32319 C     EQUIVALENCE ( NSTOR (1), BRMBRR (1) )
32320 C     EQUIVALENCE ( NSTOR (1), BRMEXP (1) )
32321 C     EQUIVALENCE ( NSTOR (1), BRMSIG (1) )
32322 C     EQUIVALENCE ( NSTOR (1), COMSCO (1) )
32323 C     EQUIVALENCE ( NSTOR (1), SIGGTT (1) )
32324 C     EQUIVALENCE ( NSTOR (1), LBSTOR (1) )
32325 C     INCLUDE '(BLNTMP)'
32326 * BLNTMP.ADD
32327 **sr 18.5. commented since not used for evap.
32328 C     COMMON / BLNTMP / KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM,
32329 C    &                  KGCBTM, KGDWTM, KBDWTM, KWLOTM, KWHITM, KWMUTM,
32330 C    &                  KWSHTM, KEXTTM, KSTXTM, KSTNTM, KECTTM, KPCTTM,
32331 C    &                  KLPBTM, NXXRGN
32332 **
32333 C     INCLUDE '(CMMDNR)'
32334 * CMMDNR.ADD
32335 **sr 18.5. commented since not used for evap.
32336 C     LOGICAL LFLDNR
32337 C     COMMON / CMMDNR / DDNEAR, LFLDNR
32338 **
32339 C     INCLUDE '(CTITLE)'
32340 * CTITLE.ADD
32341 **sr 18.5. commented since not used for evap.
32342 C     CHARACTER RUNTIT*80, RUNTIM*32, RUNKEY*10
32343 C     COMMON / CTITLE / RUNTIT, RUNTIM, RUNKEY
32344 C     COMMON / CEXPCK / ITEXPI, ITEXMX
32345 **
32346 C     INCLUDE '(DETECT)'
32347 * DETECT.ADD
32348 **sr 18.5. commented since not used for evap.
32349 C     PARAMETER (NRGNMX = 10)
32350 C     PARAMETER (NDTCMX = 10)
32351 C     PARAMETER (NSCRMX = 10)
32352 C     PARAMETER (NDTBIN = 1024)
32353 C     CHARACTER*10 TITDET,TITSCO
32354 C     LOGICAL LDTCTR
32355 C     COMMON /DETCT/  EDTMIN(NDTCMX), EDTBIN(NDTCMX), EDTCUT(NDTCMX),
32356 C    &                KDTREG(NRGNMX,NDTCMX), KDTDET(NDTCMX,NSCRMX),
32357 C    &                NDTSCO, NDTDET, LDTCTR, IDTREG(MXXRGN),
32358 C    &                KDTSCD(NSCRMX)
32359 C     COMMON /DETCH/  TITDET(NDTCMX), TITSCO(NSCRMX)
32360 **
32361 C     INCLUDE '(DETLOC)'
32362 * DETLOC.ADD
32363 **sr 18.5. commented since not used for evap.
32364 C     PARAMETER (NDTCM2 = 10)
32365 C     COMMON /DETLOC/ ACCUMP (NDTCM2), ACCUMN (NDTCM2),
32366 C    &                ICOINC(NDTCM2), NCLAS
32367 **
32368 C     INCLUDE '(EMGTRN)'
32369 * EMGTRN.ADD
32370 **sr 18.5. commented since not used for evap.
32371 C     LOGICAL LMCSMG
32372 C     COMMON / EMGTRN / UMCSMG, VMCSMG, WMCSMG, LMCSMG
32373 **
32374 C     INCLUDE '(EMSHO)'
32375 * EMSHO.ADD
32376 **sr 18.5. commented since not used for evap.
32377 C     LOGICAL EMFLO, EMFHLO, EMFELO, LIMPRE, LEXPTE
32378 C     COMMON /EMSHO/ EMFETH, EMFPTH, EMFHET, EMFHPT, EMFBIA, EMFLO,
32379 C    &               EMFHLO, EMFELO, LIMPRE, LEXPTE
32380 **
32381 C     INCLUDE '(EPISOR)'
32382 * EPISOR.ADD
32383 **sr 18.5. commented since not used for evap.
32384 C     LOGICAL LUSSRC
32385 C     COMMON/EPISOR/TKESUM,LUSSRC
32386 **
32387 * (original name: FHEAVY,FHEAVC)
32388       PARAMETER ( MXHEAV = 100 )
32389       CHARACTER*8 ANHEAV
32390       COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
32391      &                CZHEAV (MXHEAV), TKHEAV (MXHEAV),
32392      &                PHEAVY (MXHEAV), WHEAVY (MXHEAV),
32393      &                AMHEAV  ( 12 ) , AMNHEA  ( 12 ) ,
32394      &                KHEAVY (MXHEAV), ICHEAV  ( 12 ) ,
32395      &                IBHEAV  ( 12 ) , NPHEAV
32396       COMMON /FKFHVC/ ANHEAV  ( 12 )
32397 * (original name: FINUC)
32398       PARAMETER (MXP=999)
32399       COMMON /FKFINU/ CXR    (MXP), CYR    (MXP), CZR    (MXP),
32400      &                CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
32401      &                TKI    (MXP), PLR    (MXP), WEI    (MXP),
32402      &                TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
32403      &                KPART  (MXP)
32404 C     INCLUDE '(GENTHR)'
32405 * GENTHR.ADD
32406 **sr 18.5. commented since not used for evap.
32407 C     COMMON / GENTHR / PEANCT, PEAPIT, PLDNCT, PTHRSH (NALLWP),
32408 C    &                  PTHDFF (NALLWP), IJNUCR (NALLWP)
32409 **
32410 C     INCLUDE '(LOWNEU)'
32411 * LOWNEU.ADD
32412 **sr 18.5. commented since not used for evap.
32413 C     PARAMETER ( MXGTHN =  15 )
32414 C     PARAMETER ( MXGLWN = 200 )
32415 C     PARAMETER ( MXSHPP =   5 )
32416 C     LOGICAL LCOMPN, LIMPRN, LBIASN, LDOWNN, LRECPR, LLOWWW, LLOWET
32417 C     CHARACTER*10 TITLOW
32418 C     COMMON / LOWNEU / ATOLOW (MXXMDF), WSHPLN (MXGLWN,MXSHPP), EXTWWL,
32419 C    &                  SHPIMP (MXGLWN), EXTETL (MXGLWN), WWAMFL,
32420 C    &                  VLLNTH (MXGTHN,MXXMDF), ABLNTH (MXGTHN,MXXMDF),
32421 C    &                  STLNTH (MXGTHN,MXXMDF), TMRTLN (MXXMDF),
32422 C    &                  TMNMLN (MXXMDF), ICHCPT (MXXMDF),
32423 C    &                  IGTMRT (MXXMDF), NEUMED (MXXMDF),
32424 C    &                  ID1MED (MXXMDF), ID2MED (MXXMDF),
32425 C    &                  ID3MED (MXXMDF), MGTMED (MXXMDF),
32426 C    &                  LCOMPN (MXXMDF), LRECPR (MXXMDF), KPRLOW, NMGP,
32427 C    &                  NMTG  , IGRTHN, LIMPRN, LBIASN, LDOWNN, LLOWWW,
32428 C    &                  LLOWET, ICLMED, IKRBGN, INABGN, IDWBGN, IETBGN,
32429 C    &                  I0XSEC, IDXSEC, ISENAV, ISVELN, ISPNAV, IWWLWB,
32430 C    &                  IWWLWT, IPXBGN, NPXSEC
32431 C     COMMON / CHLWNT / TITLOW (MXXMDF)
32432 **
32433 C     INCLUDE '(LTCLCM)'
32434 * LTCLCM.ADD
32435 **sr 18.5. commented since not used for evap.
32436 C     COMMON / LTCLCM / MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1
32437 **
32438 C     INCLUDE '(MULBOU)'
32439 * MULBOU.ADD
32440 **sr 18.5. commented since not used for evap.
32441 C     LOGICAL LLDA  , LAGAIN, LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR
32442 C     COMMON / MULBOU / UOLD  , VOLD  , WOLD  , UMAG  , VMAG  , WMAG  ,
32443 C    &                  UNORML, VNORML, WNORML, USENSE, VSENSE, WSENSE,
32444 C    &                  TSENSE, DDSENS, DSMALL, NSSENS, LLDA  , LAGAIN,
32445 C    &                  LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR
32446 **
32447 C     INCLUDE '(MULHD)'
32448 * MULHD.ADD
32449 **sr 18.5. commented since not used for evap.
32450 C     PARAMETER ( MXXPT1 = 1 )
32451 C     PARAMETER ( TIMESS = 2.00D+00 )
32452 C     PARAMETER ( TMSRLX = 1.50D+00 )
32453 C     PARAMETER ( EPSINS = 0.15D+00 )
32454 C     PARAMETER ( EPSRLX = 0.50D+00 )
32455 C     PARAMETER ( SQEPSN = 0.3872983346207417 D+00 )
32456 C     PARAMETER ( SQEPSR = 0.7071067811865475 D+00 )
32457 C     PARAMETER ( PARNSI = 1.732050807568877 D+00 * SQEPSN )
32458 C     PARAMETER ( PRNSR0 = 1.732050807568877 D+00 * SQEPSR )
32459 C     PARAMETER ( R0NCMS = 1.20 D+00 )
32460 C     LOGICAL LTOPT, LSRCRH, LNSCRH
32461 C     COMMON / MULHD / BLCC   ( MXXMDF ), BLCCRA ( MXXMDF ),
32462 C    &                 XCC    ( MXXMDF ), ZTILDE ( MXXMDF, 0:MXXPT1 ),
32463 C    &                 ALPZTL ( MXXMDF, 0:MXXPT1 ), RLDU   ( MXXMDF ),
32464 C    &                 ALPZT2 ( MXXMDF, 0:MXXPT1 ), TEFF0  ( MXXMDF ),
32465 C    &                 XR0    ( MXXMDF ), ECUTM  ( MXXMDF, 39, 2 ),
32466 C    &                 ESTEPF ( MXXMDF ), HTHNSZ ( MXXMDF, 39 ),
32467 C    &                 AE1O3  ( MXXMDF ), PARNSR ( MXXMDF ),
32468 C    &                 HEESLI ( MXXMDF ), THMSPR, THMSSC, HMSAMP,
32469 C    &                 HMREJE, LSRCRH ( MXXMDF ), LNSCRH ( MXXMDF ),
32470 C    &                 LTOPT  ( MXXMDF ), NFSCAT
32471 **
32472 * (original name: PAREVT)
32473       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
32474      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
32475       PARAMETER ( NALLWP = 39   )
32476       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
32477      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
32478      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
32479      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
32480 * (original name: RESNUC)
32481       LOGICAL LRNFSS, LFRAGM
32482       COMMON /FKRESN/  AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
32483      &                   ANOW,   ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
32484      &                   ERES,  EKRES, AMNRES, AMMRES,  PTRES,  PXRES,
32485      &                  PYRES,  PZRES, PTRES2,  KTARP,  KTARN, IGREYP,
32486      &                 IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
32487      &                  ICRES,  IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
32488      &                 IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
32489      &                  IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
32490      &                 LFRAGM
32491 C     INCLUDE '(SCOHLP)'
32492 * SCOHLP.ADD
32493 **sr 18.5. commented since not used for evap.
32494 C     LOGICAL LSCZER
32495 C     COMMON / SCOHLP / ISCRNG, JSCRNG, LSCZER
32496 **
32497 C     INCLUDE '(TRACKR)'
32498 * TRACKR.ADD
32499 **sr 18.5. commented since not used for evap.
32500 C     PARAMETER ( MXTRCK = 2500 )
32501 C     LOGICAL LFSSSC
32502 C     COMMON / TRACKR /  XTRACK ( 0:MXTRCK ), YTRACK ( 0:MXTRCK ),
32503 C    &                   ZTRACK ( 0:MXTRCK ), TTRACK   ( MXTRCK ),
32504 C    &                   DTRACK   ( MXTRCK ), ETRACK, PTRACK, WTRACK,
32505 C    &                   ATRACK, CTRACK, AKSHRT, AKLONG, WSCRNG,
32506 C    &                   NTRACK, MTRACK, JTRACK, KTRACK, MMTRCK,
32507 C    &                   LT1TRK, LT2TRK, LTRACK, LLOUSE, LFSSSC
32508 **
32509 C     INCLUDE '(USRBDX)'
32510 * USRBDX.ADD
32511 **sr 18.5. commented since not used for evap.
32512 C     PARAMETER ( MXUSBX = 600 )
32513 C     LOGICAL LUSBDX, LFUSBX, LWUSBX, LLNUSX
32514 C     CHARACTER*10 TITUSX
32515 C     COMMON /USRBX/  EBXLOW(MXUSBX), EBXHGH(MXUSBX), ABXLOW(MXUSBX),
32516 C    &                ABXHGH(MXUSBX), DEBXBN(MXUSBX), DABXBN(MXUSBX),
32517 C    &                AUSBDX(MXUSBX),
32518 C    &                NEBXBN(MXUSBX), NABXBN(MXUSBX), NR1USX(MXUSBX),
32519 C    &                NR2USX(MXUSBX), ITUSBX(MXUSBX), IDUSBX(MXUSBX),
32520 C    &                KBUSBX(MXUSBX), IPUSBX(MXUSBX), IGMUSX(MXUSBX),
32521 C    &                LFUSBX(MXUSBX), LWUSBX(MXUSBX), LLNUSX(MXUSBX),
32522 C    &                NUSRBX, LUSBDX
32523 C     COMMON /USXCH/  TITUSX(MXUSBX)
32524 **
32525 C     INCLUDE '(USRBIN)'
32526 * USRBIN.ADD
32527 **sr 18.5. commented since not used for evap.
32528 C     PARAMETER ( MXUSBN = 100 )
32529 C     LOGICAL LUSBIN, LEVTBN, LNTZER, LUSEVT, LUSTKB, LTRKBN
32530 C     CHARACTER*10 TITUSB
32531 C     COMMON /USRBN/  XLOW  (MXUSBN), XHIGH (MXUSBN), YLOW  (MXUSBN),
32532 C    &                YHIGH (MXUSBN), ZLOW  (MXUSBN), ZHIGH (MXUSBN),
32533 C    &                DXUSBN(MXUSBN), DYUSBN(MXUSBN), DZUSBN(MXUSBN),
32534 C    &                TCUSBN(MXUSBN), BKUSBN(MXUSBN), B2USBN(MXUSBN),
32535 C    &                NXBIN (MXUSBN), NYBIN (MXUSBN), NZBIN (MXUSBN),
32536 C    &                ITUSBN(MXUSBN), IDUSBN(MXUSBN), KBUSBN(MXUSBN),
32537 C    &                IPUSBN(MXUSBN), LEVTBN(MXUSBN), LNTZER(MXUSBN),
32538 C    &                LTRKBN(MXUSBN), NUSRBN, LUSBIN, LUSEVT, LUSTKB
32539 C     COMMON /USRCH/  TITUSB(MXUSBN)
32540 **
32541 C     INCLUDE '(USRSNC)'
32542 * USRSNC.ADD
32543 **sr 18.5. commented since not used for evap.
32544 C     PARAMETER ( MXRSNC = 400 )
32545 C     PARAMETER ( NMZMIN =  -5 )
32546 C     LOGICAL LURSNC
32547 C     CHARACTER*10 TIURSN
32548 C     COMMON /USRSNC/  VURSNC(MXRSNC), IZRHGH(MXRSNC), IMRHGH(MXRSNC),
32549 C    &                 NRURSN(MXRSNC), ITURSN(MXRSNC), KBURSN(MXRSNC),
32550 C    &                 IPURSN(MXRSNC), NURSNC, LURSNC
32551 C     COMMON /USRSCH/  TIURSN(MXRSNC)
32552 C     INCLUDE '(USRTRC)'
32553 * USRTRC.ADD
32554 **sr 18.5. commented since not used for evap.
32555 C     PARAMETER ( MXUSTC = 400 )
32556 C     LOGICAL LUSRTC, LUSTRK, LUSCLL, LLNUTC
32557 C     CHARACTER*10 TITUTC
32558 C     COMMON /USRTC/  ETCLOW(MXUSTC), ETCHGH(MXUSTC), DETCBN(MXUSTC),
32559 C    &                VUSRTC(MXUSTC),
32560 C    &                IUSTRK(MXUSTC), IUSCLL(MXUSTC), NETCBN(MXUSTC),
32561 C    &                NRUSTC(MXUSTC), ITUSTC(MXUSTC), IDUSTC(MXUSTC),
32562 C    &                KBUSTC(MXUSTC), IPUSTC(MXUSTC), IGMUTC(MXUSTC),
32563 C    &                LLNUTC(MXUSTC), NUSRTC, NUSTRK, NUSCLL, LUSRTC,
32564 C    &                LUSTRK, LUSCLL
32565 C     COMMON /USTCH/  TITUTC(MXUSTC)
32566 **
32567 C     INCLUDE '(USRYLD)'
32568 * USRYLD.ADD
32569 **sr 18.5. commented since not used for evap.
32570 C     PARAMETER ( MXUSYL = 500 )
32571 C     LOGICAL LUSRYL, LLNUYL, LSCUYL
32572 C     CHARACTER*10 TITUYL
32573 C     COMMON /USRYL/  EYLLOW(MXUSYL), EYLHGH(MXUSYL), DEYLBN(MXUSYL),
32574 C    &                USNRYL(MXUSYL), SGUSYL(MXUSYL), AYLLOW(MXUSYL),
32575 C    &                AYLHGH(MXUSYL), PUSRYL, UUSRYL, VUSRYL, WUSRYL,
32576 C    &                ETXUYL, ETYUYL, ETZUYL, GAMUYL, SQSUYL, UCMUYL,
32577 C    &                VCMUYL, WCMUYL, IJUSYL, JTUSYL,
32578 C    &                NEYLBN(MXUSYL), NR1UYL(MXUSYL), NR2UYL(MXUSYL),
32579 C    &                IXUSYL(MXUSYL), ITUSYL(MXUSYL), IDUSYL(MXUSYL),
32580 C    &                KBUSYL(MXUSYL), IPUSYL(MXUSYL), IGMUYL(MXUSYL),
32581 C    &                IEUSYL(MXUSYL), IAUSYL(MXUSYL), LLNUYL(MXUSYL),
32582 C    &                NUSRYL, LUSRYL, LSCUYL
32583 C     COMMON /USYCH/  TITUYL(MXUSYL)
32584 **
32585 C     INCLUDE '(WWINDW)'
32586 * WWINDW.ADD
32587 **sr 18.5. commented since not used for evap.
32588 C     PARAMETER ( MXWWSP = 3 )
32589 C     PARAMETER ( WWSPMX = 50.D+00 )
32590 C     LOGICAL LWWNDW, LWWPRM
32591 C     COMMON / WWINDW / ETHWW1 (NALLWP), ETHWW2 (NALLWP),
32592 C    &                  WWEXWD (NALLWP), EXTWWN (NALLWP),
32593 C    &                  IWLBGN, IWHBGN, IWMBGN, LWWNDW, LWWPRM
32594 **
32595
32596 * /blnkcm/
32597 * *** If blank common dimension has to be superseded substitute in the
32598 * *** following two lines the new dimension in real*8 units to Nblnmx
32599 **sr 18.5. commented since not used for evap.
32600 C     PARAMETER (MXDUMM = KALGNM * NBLNMX)
32601 C     DATA KTMBGN / NBLNMX /
32602 C     DATA MBLNMX / MXDUMM /
32603 C     DATA KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST, KISBGN, KISLST,
32604 C    &     KDTBGN, KDTLST, KUBBGN, KUBLST, KUXBGN, KUXLST, KTCBGN,
32605 C    &     KTCLST, KRNBGN, KRNLST, KYLBGN, KYLLST, KXSBGN, KXSLST,
32606 C    &     KIHBGN, KIHLST, KINBGN, KINLST, KIEBGN, KIELST, KETBGN,
32607 C    &     KETLST, KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST,
32608 C    &     KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST, KWLBGN,
32609 C    &     KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST, KWSBGN, KWSLST,
32610 C    &     KDPBGN, KDPLST, KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN,
32611 C    &     KBRLST / 57*0 /
32612
32613 * /blntmp/
32614 **sr 18.5. commented since not used for evap.
32615 C     DATA KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM, KGDWTM,
32616 C    &     KBDWTM, KGCBTM, KWLOTM, KWHITM, KWMUTM, KWSHTM, KEXTTM,
32617 C    &     KSTXTM, KSTNTM, KECTTM, KPCTTM, KLPBTM / 19*0 /
32618
32619 * /cmmdnr/
32620 **sr 18.5. commented since not used for evap.
32621 C     DATA DDNEAR / 0.D+00 /, LFLDNR / .FALSE. /
32622
32623 * /ctitle/
32624 **sr 18.5. commented since not used for evap.
32625 C     DATA RUNTIT (1:40) / '****************************************' /
32626 C     DATA RUNTIT(41:80) / '****************************************' /
32627 C     DATA ITEXPI, ITEXMX / 100000000, 150 /
32628 * /detect/
32629 **sr 18.5. commented since not used for evap.
32630 C     PARAMETER (NNN1 = NRGNMX*NDTCMX)
32631 C     PARAMETER (NNN2 = NSCRMX*NDTCMX)
32632 C     DATA LDTCTR /.FALSE./, NDTSCO /0/, NDTDET /0/
32633 C     DATA EDTMIN/NDTCMX*0.D0/, EDTBIN/NDTCMX*0.D0/, EDTCUT/NDTCMX*0.D0/
32634 C     DATA KDTREG/NNN1*0/, KDTDET/NNN2*0/, KDTSCD/NSCRMX*0/
32635 C     DATA TITDET/NDTCMX*'          '/, TITSCO/NSCRMX*'          '/
32636
32637 * /detloc/
32638 **sr 18.5. commented since not used for evap.
32639 C     DATA ACCUMP /NDTCM2*0.D0/, ACCUMN /NDTCM2*0.D0/, ICOINC /NDTCM2*0/
32640 C     DATA NCLAS /0/
32641
32642 * /emgtrn/
32643 **sr 18.5. commented since not used for evap.
32644 C     DATA LMCSMG / .FALSE. /
32645
32646 * /emsho/
32647 **sr 18.5. commented since not used for evap.
32648 C     DATA LIMPRE, LEXPTE / 2 * .FALSE. /
32649
32650 * /episor/
32651 **sr 18.5. commented since not used for evap.
32652 C     DATA TKESUM / 0.D+00 /, LUSSRC / .FALSE. /
32653
32654 * /fheavy/
32655       DATA AMHEAV / 12 * 0.D+00 /
32656       DATA ANHEAV / 'NEUTRON ', 'PROTON  ', 'DEUTERON', '3-H     ',
32657      &              '3-He    ', '4-He    ', 'H-FRAG-1', 'H-FRAG-2',
32658      &              'H-FRAG-3', 'H-FRAG-4', 'H-FRAG-5', 'H-FRAG-6'/
32659       DATA ICHEAV / 0, 1, 1, 1, 2, 2, 6*0 /,
32660      &     IBHEAV / 1, 1, 2, 3, 3, 4, 6*0 /
32661       DATA NPHEAV / 0 /
32662
32663 * /finuc/
32664       DATA NP / 0 /, TV / 0.D+00 /, TVCMS / 0.D+00 /, TVRECL / 0.D+00/,
32665      &     TVHEAV / 0.D+00 /, TVBIND / 0.D+00 /
32666
32667 * /genthr/
32668 * Up to 20-apr-'95
32669 *     DATA PEANCT, PEAPIT / 2*1.D+00 /
32670 *     DATA PTHRSH / 16*5.D+00,2*2.5D+00,5.D+00,3*2.5D+00,8*5.D+00,
32671 *    &              9*2.5D+00 /
32672 *     DATA PTHDFF / 39*5.D+00 /
32673 *    &              9*2.5D+00 /
32674 * New values:
32675 **sr 18.5. commented since not used for evap.
32676 C     DATA PEANCT, PEAPIT / 1.3D+00, 1.1D+00 /
32677 C     DATA PTHRSH / 12*5.D+00, 2*3.5D+00, 2*5.D+00, 2*2.5D+00, 5.D+00,
32678 C    &              3*2.5D+00, 3.5D+00, 2*5.D+00, 3.5D+00, 4*5.D+00,
32679 C    &              9*2.5D+00 /
32680 C     DATA PTHDFF / 12*5.D+00, 2*3.5D+00, 8*5.D+00, 3.5D+00, 2*5.D+00,
32681 C    &              3.5D+00, 13*5.D+00 /
32682 C     DATA PLDNCT / 0.26D+00 /
32683 C     DATA IJNUCR / 16*1, 2*0, 1, 3*0, 8*1, 9*0 /
32684
32685 * /lowneu/
32686 **sr 18.5. commented since not used for evap.
32687 C     DATA WWAMFL / 10.D+00 /, EXTWWL / 1.D+00 /
32688 C     DATA IWWLWB, IWWLWT / 2 * 100000000 /
32689 C     DATA ICLMED, INABGN, IDWBGN, IETBGN / 4*0 /
32690 C     DATA IGRTHN / 1 /
32691 C     DATA LIMPRN / .FALSE. /, LBIASN / .FALSE. /, LDOWNN / .FALSE. /,
32692 C    &     LLOWWW / .FALSE. /, LLOWET / .FALSE. /
32693
32694 * /ltclcm/
32695 **sr 18.5. commented since not used for evap.
32696 C     DATA MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1 / 6*0 /
32697
32698 * /mulbou/
32699 **sr 18.5. commented since not used for evap.
32700 C     DATA LLDA, LAGAIN, LSTNEW, LARTEF, LSENSE, LNORML, LMGNOR
32701 C    &     / 7 * .FALSE. /
32702 C     DATA TSENSE / AINFNT /, NSSENS / -1 /
32703 C     DATA DSMALL / ANGLGB /
32704
32705 * /mulhd/
32706 **sr 18.5. commented since not used for evap.
32707 C     DATA LTOPT  / MXXMDF * .FALSE. /, NFSCAT / 0 /
32708 C     DATA ESTEPF / MXXMDF * 0.1D+00 /
32709 C     DATA LSRCRH / MXXMDF * .FALSE. /, LNSCRH / MXXMDF * .FALSE. /
32710 C     DATA THMSPR / 0.02D+00 /, THMSSC / 1.D+00 /
32711
32712 * /parevt/
32713       DATA DPOWER /-13.D+00 /, FSPRD0 / 0.6D+00 /, FSHPFN / 0.0D+00 /,
32714      &     RN1GSC /-1.0D+00 /, RN2GSC /-1.0D+00 /
32715       DATA LDIFFR /  .TRUE., .TRUE., 6 * .TRUE., .TRUE., 8 * .TRUE.,
32716      &               .TRUE., 4 * .TRUE., .TRUE., 3 * .TRUE.,
32717      &              4 * .FALSE., 9 * .TRUE./
32718 **sr 17.5.95
32719 * default value for LEVPRT changed (reset sr 25.7.97)
32720 * default value for LHEAVY changed 25.7.97
32721 C     DATA LPOWER / .TRUE.  /, LINCTV / .TRUE.  /, LEVPRT / .TRUE.  /,
32722 C    &     LHEAVY / .FALSE. /, LDEEXG / .TRUE.  /, LGDHPR / .TRUE.  /,
32723 C    &     LPREEX / .TRUE.  /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /,
32724 C    &     LPARWV / .TRUE.  /, LSNGCH / .TRUE.  /, LSCHDF / .TRUE.  /
32725       DATA LPOWER / .TRUE.  /, LINCTV / .TRUE.  /, LEVPRT / .TRUE.  /,
32726      &     LHEAVY / .TRUE.  /, LDEEXG / .TRUE.  /, LGDHPR / .TRUE.  /,
32727      &     LPREEX / .TRUE.  /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /,
32728      &     LPARWV / .TRUE.  /, LSNGCH / .TRUE.  /, LSCHDF / .TRUE.  /
32729 **
32730 **sr 27.5.97
32731 * default value for ILVMOD changed
32732 C     DATA ILVMOD / 0 /, JLVMOD / 1 /, LLVMOD / .TRUE. /
32733       DATA ILVMOD / 1 /, JLVMOD / 1 /, LLVMOD / .TRUE. /
32734 **
32735
32736 * /resnuc/
32737       DATA IPREEH / 0 /, IPRTRI / 0 /, IPRDEU / 0 /, IPR3HE / 0 /,
32738      &     IPR4HE / 0 /
32739       DATA IEVAPL / 0 /, IEVAPH / 0 /, IEVNEU / 0 /, IEVPRO / 0 /,
32740      &     IEVTRI / 0 /, IEVDEU / 0 /, IEV3HE / 0 /, IEV4HE / 0 /,
32741      &     IDEEXG / 0 /
32742       DATA LRNFSS / .FALSE. /
32743
32744 * /scohlp/
32745 **sr 18.5. commented since not used for evap.
32746 C     DATA ISCRNG, JSCRNG / 2*0 /, LSCZER / .FALSE. /
32747
32748 * /trackr/
32749 **sr 18.5. commented since not used for evap.
32750 C     DATA ETRACK /0.D+00/, WTRACK /0.D+00/, ATRACK /0.D+00/,
32751 C    &     CTRACK /0.D+00/, NTRACK /0/, MTRACK /0/, JTRACK /0/
32752
32753 * /usrbin/
32754 **sr 18.5. commented since not used for evap.
32755 C     DATA LUSBIN, LUSEVT, LUSTKB /3*.FALSE./, NUSRBN /0/
32756
32757 * /usrbdx/
32758 **sr 18.5. commented since not used for evap.
32759 C     DATA LUSBDX /.FALSE./, NUSRBX /0/
32760
32761 * /usrsnc/
32762 **sr 18.5. commented since not used for evap.
32763 C     DATA LURSNC /.FALSE./, NURSNC /0/
32764
32765 * /usrtrc/
32766 **sr 18.5. commented since not used for evap.
32767 C     DATA LUSRTC, LUSTRK, LUSCLL / 3*.FALSE. /
32768 C     DATA NUSRTC, NUSTRK, NUSCLL / 3*0 /
32769
32770 * /usryld/
32771 **sr 18.5. commented since not used for evap.
32772 C     DATA LUSRYL / .FALSE./, LSCUYL / .FALSE. /, NUSRYL /0/,
32773 C    &     IJUSYL /0/, JTUSYL /0/
32774 C     DATA PUSRYL, UUSRYL, VUSRYL, WUSRYL / 4*ZERZER /
32775
32776 * /wwindw/
32777 **sr 18.5. commented since not used for evap.
32778 C     DATA IWLBGN, IWHBGN, IWMBGN / 3*0 /
32779 C     DATA LWWPRM / .TRUE. /
32780
32781 *=                                               end*block.bdnopt      *
32782       END
32783
32784 *$ CREATE DT_BDPREE.FOR
32785 *COPY DT_BDPREE
32786 *
32787 *=== bdpree ===========================================================*
32788 *
32789       BLOCK DATA DT_BDPREE
32790
32791 C     INCLUDE '(DBLPRC)'
32792 * DBLPRC.ADD
32793       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32794       SAVE
32795 * (original name: GLOBAL)
32796       PARAMETER ( KALGNM = 2 )
32797       PARAMETER ( ANGLGB = 5.0D-16 )
32798       PARAMETER ( ANGLSQ = 2.5D-31 )
32799       PARAMETER ( AXCSSV = 0.2D+16 )
32800       PARAMETER ( ANDRFL = 1.0D-38 )
32801       PARAMETER ( AVRFLW = 1.0D+38 )
32802       PARAMETER ( AINFNT = 1.0D+30 )
32803       PARAMETER ( AZRZRZ = 1.0D-30 )
32804       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
32805       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
32806       PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
32807       PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
32808       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
32809       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
32810       PARAMETER ( CSNNRM = 2.0D-15 )
32811       PARAMETER ( DMXTRN = 1.0D+08 )
32812       PARAMETER ( ZERZER = 0.D+00 )
32813       PARAMETER ( ONEONE = 1.D+00 )
32814       PARAMETER ( TWOTWO = 2.D+00 )
32815       PARAMETER ( THRTHR = 3.D+00 )
32816       PARAMETER ( FOUFOU = 4.D+00 )
32817       PARAMETER ( FIVFIV = 5.D+00 )
32818       PARAMETER ( SIXSIX = 6.D+00 )
32819       PARAMETER ( SEVSEV = 7.D+00 )
32820       PARAMETER ( EIGEIG = 8.D+00 )
32821       PARAMETER ( ANINEN = 9.D+00 )
32822       PARAMETER ( TENTEN = 10.D+00 )
32823       PARAMETER ( HLFHLF = 0.5D+00 )
32824       PARAMETER ( ONETHI = ONEONE / THRTHR )
32825       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
32826       PARAMETER ( ONEFOU = ONEONE / FOUFOU )
32827       PARAMETER ( THRTWO = THRTHR / TWOTWO )
32828       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
32829       PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
32830       PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
32831       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
32832       PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
32833       PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
32834       PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
32835       PARAMETER ( EULERO = 0.577215664901532860606512      D+00 )
32836       PARAMETER ( EULEXP = 1.781072417990197985236504      D+00 )
32837       PARAMETER ( EULLOG =-0.5495393129816448223376619     D+00 )
32838       PARAMETER ( E1M2EU = 0.8569023337737540831433017     D+00 )
32839       PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
32840       PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
32841       PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
32842       PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
32843       PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
32844       PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
32845       PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
32846       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
32847       PARAMETER ( CLIGHT = 2.99792458         D+10 )
32848       PARAMETER ( AVOGAD = 6.0221367          D+23 )
32849       PARAMETER ( BOLTZM = 1.380658           D-23 )
32850       PARAMETER ( AMELGR = 9.1093897          D-28 )
32851       PARAMETER ( PLCKBR = 1.05457266         D-27 )
32852       PARAMETER ( ELCCGS = 4.8032068          D-10 )
32853       PARAMETER ( ELCMKS = 1.60217733         D-19 )
32854       PARAMETER ( AMUGRM = 1.6605402          D-24 )
32855       PARAMETER ( AMMUMU = 0.113428913        D+00 )
32856       PARAMETER ( AMPRMU = 1.007276470        D+00 )
32857       PARAMETER ( AMNEMU = 1.008664904        D+00 )
32858       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
32859       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
32860       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
32861       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
32862       PARAMETER ( PLABRC = 0.197327053        D+00 )
32863       PARAMETER ( AMELCT = 0.51099906         D-03 )
32864       PARAMETER ( AMUGEV = 0.93149432         D+00 )
32865       PARAMETER ( AMMUON = 0.105658389        D+00 )
32866       PARAMETER ( AMPRTN = 0.93827231         D+00 )
32867       PARAMETER ( AMNTRN = 0.93956563         D+00 )
32868       PARAMETER ( AMDEUT = 1.87561339         D+00 )
32869       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
32870      &                   * 1.D-09 )
32871       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
32872       PARAMETER ( BLTZMN = 8.617385           D-14 )
32873       PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
32874       PARAMETER ( GFOHB3 = 1.16639            D-05 )
32875       PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
32876       PARAMETER ( SIN2TW = 0.2319             D+00 )
32877       PARAMETER ( GEVMEV = 1.0                D+03 )
32878       PARAMETER ( EMVGEV = 1.0                D-03 )
32879       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
32880       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
32881       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
32882       LOGICAL LGBIAS, LGBANA
32883       COMMON /FKGLOB/ LGBIAS, LGBANA
32884 C     INCLUDE '(DIMPAR)'
32885 * DIMPAR.ADD
32886       PARAMETER ( MXXRGN = 5000 )
32887       PARAMETER ( MXXMDF = 82   )
32888       PARAMETER ( MXXMDE = 54   )
32889       PARAMETER ( MFSTCK = 1000 )
32890       PARAMETER ( MESTCK = 100  )
32891       PARAMETER ( NALLWP = 39   )
32892       PARAMETER ( NELEMX = 80   )
32893       PARAMETER ( MPDPDX = 8    )
32894       PARAMETER ( ICOMAX = 180  )
32895       PARAMETER ( NSTBIS = 304  )
32896       PARAMETER ( IDMAXP = 220  )
32897       PARAMETER ( IDMXDC = 640  )
32898       PARAMETER ( MKBMX1 = 1    )
32899       PARAMETER ( MKBMX2 = 1    )
32900 C     INCLUDE '(IOUNIT)'
32901 * IOUNIT.ADD
32902       PARAMETER ( LUNIN  =  5 )
32903       PARAMETER ( LUNOUT =  6 )
32904 **sr 19.5. set error output-unit from 15 to 6
32905       PARAMETER ( LUNERR = 6  )
32906       PARAMETER ( LUNBER = 14 )
32907       PARAMETER ( LUNECH =  8 )
32908       PARAMETER ( LUNFLU = 13 )
32909       PARAMETER ( LUNGEO = 16 )
32910       PARAMETER ( LUNPMF = 12 )
32911       PARAMETER ( LUNRAN =  2 )
32912       PARAMETER ( LUNXSC =  9 )
32913       PARAMETER ( LUNDET = 17 )
32914       PARAMETER ( LUNRAY = 10 )
32915       PARAMETER ( LUNRDB =  1 )
32916       PARAMETER ( LUNPGO =  7 )
32917       PARAMETER ( LUNPGS =  4 )
32918       PARAMETER ( LUNSCR =  3 )
32919 *
32920 *----------------------------------------------------------------------*
32921 *                                                                      *
32922 *     Created on 16 september 1991 by    Alfredo Ferrari & Paola Sala  *
32923 *                                                   Infn - Milan       *
32924 *                                                                      *
32925 *     Last change on 03-feb-94     by    Alfredo Ferrari               *
32926 *                                                                      *
32927 *                                                                      *
32928 *----------------------------------------------------------------------*
32929 *
32930 * (original name: CMPISG,CHPISG)
32931       PARAMETER ( TPPPI0 = 0.279656044337515D+00 )
32932       PARAMETER ( TNNPI0 = 0.279642680857450D+00 )
32933       PARAMETER ( TPPPIP = 0.292295207182790D+00 )
32934       PARAMETER ( TPPDEP = 0.287514778898469D+00 )
32935       PARAMETER ( TNNPIM = 0.286723140900975D+00 )
32936       PARAMETER ( TNNDEM = 0.281949292916434D+00 )
32937       PARAMETER ( TPNPI0 = 0.279456888147740D+00 )
32938       PARAMETER ( TPNDE0 = 0.274693916135245D+00 )
32939       PARAMETER ( TPNPIP = 0.292086756473890D+00 )
32940       PARAMETER ( TNPPI0 = 0.279842093144975D+00 )
32941       PARAMETER ( TNPDE0 = 0.275072555824202D+00 )
32942       PARAMETER ( TNPPIP = 0.292489370554958D+00 )
32943       PARAMETER ( PIRSMX = 1.2D+00 )
32944       PARAMETER ( NPIREA = 10 )
32945       PARAMETER ( NPIRTA = 68 )
32946       PARAMETER ( NPIRLN = 21 )
32947       PARAMETER ( NPIRLG = NPIRTA - NPIRLN )
32948       PARAMETER ( NPISIS = NPIRLN + 20 )
32949       PARAMETER ( NPISEX = NPIRLN + 21 )
32950       PARAMETER ( NPIIMN = 14 )
32951       PARAMETER ( NPIIRC =  6 )
32952       PARAMETER ( DELWLL = 0.035D+00 )
32953       CHARACTER CHPIRE*8
32954       LOGICAL LDLRES
32955       COMMON /FKCMPI/ PMNPIS, PMMPIS, PISPIS, PEXPIS, PMXPIS, DPPISG,
32956      &                RTPISG, AMNPIS, AMMPIS, AISPIS, AEXPIS, AMXPIS,
32957      &                ARPISG, BPISLO (NPIRLN:NPIRTA,NPIREA),
32958      &                CPISLO (NPIRLN:NPIRTA,NPIREA), PPITHR (NPIREA),
32959      &                SPISLO (NPIRLN:NPIRTA,NPIREA), APITHR (NPIREA),
32960      &                SGPIIN (NPIIMN:NPIRTA,NPIIRC), RHPICR (1:5)   ,
32961      &                SGPICU (0:20,NPIRTA,NPIREA)  , SGRTRS (NPIREA),
32962      &                SGPIDF (0:20,NPIRTA,NPIREA)  , BRREIN (NPIREA),
32963      &                SGPIIS (NPIRTA,NPIREA)       , BRREOU (NPIREA),
32964      &                BRD3OU (2,2,-1:2), BRDEOU (2,-1:2),
32965      &                SGABSR (2,2,4)   , PRRSDL,
32966      &                IPIREA (2,2,3:5) , IPIINE (2,3:5)    , NPIRVR ,
32967      &                KPIIRE (2,NPIREA), KPIORE (2,NPIREA) ,
32968      &                JSTOKP (5), KPTOJS (23), ITTRRS (3:5), LDLRES
32969       COMMON /FKCHPI/ CHPIRE (NPIREA)
32970       DIMENSION SG2BRS (2,2), SGABSW (2,2), SG3BRS (2,2,2)
32971       EQUIVALENCE ( SG2BRS   (1,1), SGABSR (1,1,1) )
32972       EQUIVALENCE ( SGABSW   (1,1), SGABSR (1,1,2) )
32973       EQUIVALENCE ( SG3BRS (1,1,1), SGABSR (1,1,3) )
32974 * (original name: FRBKCM)
32975       PARAMETER ( MXFFBK =     6 )
32976       PARAMETER ( MXZFBK =     9 )
32977       PARAMETER ( MXNFBK =    10 )
32978       PARAMETER ( MXAFBK =    16 )
32979       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
32980       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
32981       PARAMETER ( NXAFBK = MXAFBK + 1 )
32982       PARAMETER ( MXPSST =   300 )
32983       PARAMETER ( MXPSFB = 41000 )
32984       LOGICAL LFRMBK, LNCMSS
32985       COMMON /FKFRBK/  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
32986      &          EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
32987      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
32988      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
32989      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
32990      &          IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
32991      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
32992      &          IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
32993      &          IFBFRB, NBUFBK, LFRMBK, LNCMSS
32994 * (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII)
32995       PARAMETER ( PI     = PIPIPI )
32996       PARAMETER ( PISQ   = PIPISQ )
32997       PARAMETER ( SKTOHL = 0.5456645846610345D+00 )
32998       PARAMETER ( RZNUCL = 1.12        D+00 )
32999       PARAMETER ( RMSPRO = 0.8         D+00 )
33000       PARAMETER ( R0PROT = RMSPRO / SQRT12  )
33001       PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT
33002      &          / R0PROT )
33003       PARAMETER ( RLLE04 = RZNUCL )
33004       PARAMETER ( RLLE16 = RZNUCL )
33005       PARAMETER ( RLGT16 = RZNUCL )
33006       PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 )
33007       PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 )
33008       PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 )
33009       PARAMETER ( SKLE04 = 1.4D+00 )
33010       PARAMETER ( SKLE16 = 1.9D+00 )
33011       PARAMETER ( SKGT16 = 2.4D+00 )
33012       PARAMETER ( HLLE04 = SKTOHL * SKLE04 )
33013       PARAMETER ( HLLE16 = SKTOHL * SKLE16 )
33014       PARAMETER ( HLGT16 = SKTOHL * SKGT16 )
33015       PARAMETER ( ALPHA0 = 0.1D+00 )
33016       PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 )
33017       PARAMETER ( GAMSK0 = 0.9D+00 )
33018       PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 )
33019       PARAMETER ( POTME0 = 0.6666666666666667D+00 )
33020       PARAMETER ( POTBA0 = 1.D+00 )
33021       PARAMETER ( PNFRAT = 1.533D+00 )
33022       PARAMETER ( RADPIM = 0.035D+00 )
33023       PARAMETER ( RDPMHL = 14.D+00   )
33024       PARAMETER ( APMRST = 4.D+00 / 44.D+00 )
33025       PARAMETER ( APMPRO = 1.D+00 / 6.D+00 )
33026       PARAMETER ( APPPRO = 5.D+00 / 6.D+00 )
33027       PARAMETER ( AP0PFS = 0.5D+00 )
33028       PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 )
33029       PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 )
33030       PARAMETER ( XPAUCO = 1.88495407241652 D+00 )
33031       PARAMETER ( MXSCIN = 50     )
33032       LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY,
33033      &        LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC
33034       COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260),
33035      &                RADTAB (2:260), SKITAB (2:260), HALTAB (2:260),
33036      &                SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260),
33037      &                CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260),
33038      &                PFRTAB (2:260)
33039       COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP,
33040      &                ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO,
33041      &                RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR,
33042      &                YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN,
33043      &                RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM,
33044      &                PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2,
33045      &                PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT,
33046      &                BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2,
33047      &                YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3,
33048      &                XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC,
33049      &                SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ,
33050      &                R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE,
33051      &                PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY,
33052      &                EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ,
33053      &                PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM,
33054      &                EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3,
33055      &                PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM,
33056      &                BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN
33057       COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2),
33058      &                RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN,
33059      &                EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF,
33060      &                BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC,
33061      &                WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES,
33062      &                POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND,
33063      &                BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4),
33064      &                SIGPAB (3), SIGNAB (3), HHLP   (2), FORTOT (2),
33065      &                FPNBLC, DPNBLC, FFTFLG, IFTFLG,
33066      &                IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2,
33067      &                KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3,
33068      &                NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM,
33069      &                IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ,
33070      &                LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC
33071       COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT
33072       COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN),
33073      &                YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN),
33074      &                AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX,
33075      &                NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN),
33076      &                NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN),
33077      &                ISCTYP (0:MXSCIN), NUSCIN, NEXPEM,
33078      &                LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH,
33079      &                LNCDCY, LNUSCT
33080       DIMENSION AWSTAB (2:260), SIGMAB (3)
33081       EQUIVALENCE ( DEFPRO, DEFNUC (1) )
33082       EQUIVALENCE ( DEFNEU, DEFNUC (2) )
33083       EQUIVALENCE ( RHOIPP, RHONCP (1) )
33084       EQUIVALENCE ( RHOINP, RHONCP (2) )
33085       EQUIVALENCE ( RHOIP2, RHONC2 (1) )
33086       EQUIVALENCE ( RHOIN2, RHONC2 (2) )
33087       EQUIVALENCE ( RHOIP3, RHONC3 (1) )
33088       EQUIVALENCE ( RHOIN3, RHONC3 (2) )
33089       EQUIVALENCE ( RHOIPT, RHONCT (1) )
33090       EQUIVALENCE ( RHOINT, RHONCT (2) )
33091       EQUIVALENCE ( OMALHL, SK3PAR )
33092       EQUIVALENCE ( ALPHAL, HABPAR )
33093       EQUIVALENCE ( ALPTAB (2), AWSTAB (2) )
33094       EQUIVALENCE ( SIGMPE, SIGMPR (1) )
33095       EQUIVALENCE ( SIGMPC, SIGMPR (2) )
33096       EQUIVALENCE ( SIGMPI, SIGMPR (3) )
33097       EQUIVALENCE ( SIGMPA, SIGMPR (4) )
33098       EQUIVALENCE ( SIGMNE, SIGMNU (1) )
33099       EQUIVALENCE ( SIGMNC, SIGMNU (2) )
33100       EQUIVALENCE ( SIGMNI, SIGMNU (3) )
33101       EQUIVALENCE ( SIGMNA, SIGMNU (4) )
33102       EQUIVALENCE ( SIGMA2, SIGPAB (1) )
33103       EQUIVALENCE ( SIGMA3, SIGPAB (2) )
33104       EQUIVALENCE ( SIGMAS, SIGPAB (3) )
33105       EQUIVALENCE ( SIGPAB (1), SIGMAB (1) )
33106 * (original name: NUCLEV)
33107       LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL
33108       COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2),
33109      &                DEFMAG (2), ENNCLV (160,2), RANCLV (160,2),
33110      &                CUMRAD (0:160,2), RUSNUC (2),
33111      &                ENPLVL (114), ENNLVL(164), JUSNUC (160,2),
33112      &                NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2),
33113      &                NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2),
33114      &                JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8),
33115      &                MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2),
33116      &                NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL,
33117      &                LFLVSL, LRLVSL, LEQSBL
33118       DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8),
33119      &          MGSSPR (19) , MGSSNE (25)
33120       EQUIVALENCE ( RUSNUC (1), RUSPRO )
33121       EQUIVALENCE ( RUSNUC (2), RUSNEU )
33122       EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) )
33123       EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) )
33124       EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) )
33125       EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) )
33126       EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) )
33127       EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) )
33128       EQUIVALENCE ( NTANUC (1), NTAPRO )
33129       EQUIVALENCE ( NTANUC (2), NTANEU )
33130       EQUIVALENCE ( NAVNUC (1), NAVPRO )
33131       EQUIVALENCE ( NAVNUC (2), NAVNEU )
33132       EQUIVALENCE ( NLSNUC (1), NLSPRO )
33133       EQUIVALENCE ( NLSNUC (2), NLSNEU )
33134       EQUIVALENCE ( NCONUC (1), NCOPRO )
33135       EQUIVALENCE ( NCONUC (2), NCONEU )
33136       EQUIVALENCE ( NSKNUC (1), NSKPRO )
33137       EQUIVALENCE ( NSKNUC (2), NSKNEU )
33138       EQUIVALENCE ( NHANUC (1), NHAPRO )
33139       EQUIVALENCE ( NHANUC (2), NHANEU )
33140       EQUIVALENCE ( NUSNUC (1), NUSPRO )
33141       EQUIVALENCE ( NUSNUC (2), NUSNEU )
33142       EQUIVALENCE ( NACNUC (1), NACPRO )
33143       EQUIVALENCE ( NACNUC (2), NACNEU )
33144       EQUIVALENCE ( JMXNUC (1), JMXPRO )
33145       EQUIVALENCE ( JMXNUC (2), JMXNEU )
33146       EQUIVALENCE ( MAGNUC (1), MAGPRO )
33147       EQUIVALENCE ( MAGNUC (2), MAGNEU )
33148 * (original name: PARNUC)
33149       PARAMETER ( PIGRK  = PIPIPI )
33150       PARAMETER ( ALEVEL = 8.D-03 )
33151       PARAMETER ( RCNUCL = 1.12D+00 )
33152       PARAMETER ( R0SIG  = 1.3D+00 )
33153       PARAMETER ( R0SIGK = 1.5D+00 )
33154       PARAMETER ( RCOULB = 1.5D+00 )
33155       PARAMETER ( COULBH = 0.88235D-03 )
33156       PARAMETER ( RHONU0 = 0.75D+00 / PIGRK / RCNUCL / RCNUCL / RCNUCL )
33157       PARAMETER ( TAUFO0 = 10.0D+00 )
33158       PARAMETER ( EKEEXP = 0.03D+00 )
33159       PARAMETER ( EKREXP = 0.05D+00 )
33160       PARAMETER ( EKEMNM = 0.01D+00 )
33161       PARAMETER ( NCPMX = 120 )
33162       COMMON /FKPARN/ EKORI , PXORI , PYORI , PZORI , PTORI , TAUFOR,
33163      &                ENNUC  (NCPMX), PNUCL  (NCPMX), EKFNUC (NCPMX),
33164      &                XSTNUC (NCPMX), YSTNUC (NCPMX), ZSTNUC (NCPMX),
33165      &                PXNUCL (NCPMX), PYNUCL (NCPMX), PZNUCL (NCPMX),
33166      &                RSTNUC (NCPMX), FREEPA (NCPMX), CRRPAN (NCPMX),
33167      &                CRRPAP (NCPMX), BSTNUC (NCPMX), AGENUC (NCPMX),
33168      &                TAUFPA (NCPMX), RHNUCL(NCPMX,2), BNDGAV, DEFMIN,
33169      &                KPNUCL (NCPMX), KRFNUC (NCPMX), ILINUC (NCPMX),
33170      &                INUCTS (NCPMX), ISFNUC (NCPMX), KPORI , IBORI ,
33171      &                IBNUCL, NPNUC , NNUCTS
33172 *
33173       DATA LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH / 6*.FALSE. /
33174       DATA POTBAR / POTBA0 /, POTMES / POTME0 /, WLLRES / 0.D+00 /
33175       DATA JUSNUC / 320 * 0 /, INUCLV / 1 /, IEVPRE / 0 /
33176       DATA MAGNUM / 2, 8, 20, 28, 50, 82, 126, 160 /
33177       DATA LPREEQ / .FALSE. /
33178 * /cmpisg/
33179       DATA JSTOKP / 1, 8, 13, 14, 23 /
33180       DATA KPTOJS / 1, 6*0, 2, 4*0, 3, 4, 8*0, 5 /
33181       DATA CHPIRE / 'PI+PPI+P','PI-PPI-P','PI-PPI0N','PI0PPI0P',
33182      &              'PI0PPI+N','PI-NPI-N','PI+NPI+N','PI+NPI0P',
33183      &              'PI0NPI0N','PI0NPI-P' /
33184       DATA KPIIRE / 13, 1, 14, 1, 14, 1, 23, 1, 23, 1, 14, 8,
33185      &              13, 8, 13, 8, 23, 8, 23, 8 /
33186       DATA KPIORE / 13, 1, 14, 1, 23, 8, 23, 1, 13, 8, 14, 8,
33187      &              13, 8, 23, 1, 23, 8, 14, 1 /
33188       DATA IPIREA / 1, 0, 7, 8, 2, 3, 6, 0, 4, 5, 9, 10 /
33189       DATA IPIINE / 1, 2, 3, 4, 5, 6 /
33190 * /frbkcm/
33191       DATA LFRMBK / .FALSE. /
33192       DATA NBUFBK /   500  /
33193       DATA EXMXFB / 80.0 D+00 /
33194       DATA R0FRBK / 1.18 D+00 /
33195       DATA R0CFBK / 2.173D+00 /
33196       DATA C1CFBK / 6.103D-03 /
33197       DATA C2CFBK / 9.443D-03 /
33198 * /parnuc/
33199       DATA TAUFOR / TAUFO0 /
33200 *=== End of Block Data Bdpree =========================================*
33201       END
33202
33203 *$ CREATE DT_XHOINI.FOR
33204 *COPY DT_XHOINI
33205 *
33206 *====phoini============================================================*
33207 *
33208       SUBROUTINE DT_XHOINI
33209 C     SUBROUTINE DT_PHOINI
33210
33211       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33212       SAVE
33213       PARAMETER ( LINP = 10 ,
33214      &            LOUT = 6 ,
33215      &            LDAT = 9 )
33216
33217       RETURN
33218       END
33219
33220 *$ CREATE DT_XVENTB.FOR
33221 *COPY DT_XVENTB
33222 *
33223 *====eventb============================================================*
33224 *
33225       SUBROUTINE DT_XVENTB(NCSY,IREJ)
33226 C     SUBROUTINE DT_EVENTB(NCSY,IREJ)
33227
33228       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33229       SAVE
33230       PARAMETER ( LINP = 10 ,
33231      &            LOUT = 6 ,
33232      &            LDAT = 9 )
33233
33234       WRITE(LOUT,1000)
33235  1000 FORMAT(1X,'EVENTB:   PHOJET-package requested but not linked!')
33236       STOP
33237
33238       END
33239
33240 *$ CREATE DT_XVENT.FOR
33241 *COPY DT_XVENT
33242 *
33243 *===event==============================================================*
33244 *
33245       SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
33246 C     SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
33247
33248       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33249       SAVE
33250
33251       DIMENSION PP(4),PT(4)
33252
33253       RETURN
33254       END
33255
33256 *$ CREATE DT_XOHISX.FOR
33257 *COPY DT_XOHISX
33258 *
33259 *===pohisx=============================================================*
33260 *
33261       SUBROUTINE DT_XOHISX(I,X)
33262 C     SUBROUTINE POHISX(I,X)
33263
33264       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33265       SAVE
33266
33267       RETURN
33268       END
33269
33270 *$ CREATE PHO_LHIST.FOR
33271 *COPY PHO_LHIST
33272 *
33273 *===poluhi=============================================================*
33274 *
33275       SUBROUTINE PHO_LHIST(I,X)
33276 **
33277
33278       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33279       SAVE
33280
33281       RETURN
33282       END
33283
33284 *$ CREATE PDFSET.FOR
33285 *COPY PDFSET
33286 *
33287 C**********************************************************************
33288 C
33289 C   dummy subroutines, remove to link PDFLIB
33290 C
33291 C**********************************************************************
33292       SUBROUTINE PDFSET(PARAM,VALUE)
33293       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33294       DIMENSION PARAM(20),VALUE(20)
33295       CHARACTER*20 PARAM
33296       END
33297
33298 *$ CREATE STRUCTM.FOR
33299 *COPY STRUCTM
33300 *
33301       SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
33302       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33303       END
33304
33305 *$ CREATE STRUCTP.FOR
33306 *COPY STRUCTP
33307 *
33308       SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
33309       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33310       END
33311
33312 *$ CREATE DT_DIQBRK.FOR
33313 *COPY DT_DIQBRK
33314 *
33315 *===diqbrk=============================================================*
33316 *
33317       SUBROUTINE DT_XIQBRK
33318 C     SUBROUTINE DT_DIQBRK
33319
33320       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33321       SAVE
33322
33323       STOP 'diquark-breaking not implemeted !'
33324
33325       RETURN
33326       END
33327
33328 *$ CREATE DT_ELHAIN.FOR
33329 *COPY DT_ELHAIN
33330 *
33331 *===elhain=============================================================*
33332 *
33333       SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
33334
33335 ************************************************************************
33336 * Elastic hadron-hadron scattering.                                    *
33337 * This is a revised version of the original.                           *
33338 * This version dated 03.04.98 is written by S. Roesler                 *
33339 ************************************************************************
33340
33341       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33342       SAVE
33343       PARAMETER ( LINP = 10 ,
33344      &            LOUT = 6 ,
33345      &            LDAT = 9 )
33346       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
33347      &           TINY10=1.0D-10)
33348
33349       PARAMETER (ENNTHR = 3.5D0)
33350       PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
33351      &           BLOWB=0.05D0,BHIB=0.2D0,
33352      &           BLOWM=0.1D0, BHIM=2.0D0)
33353
33354 * particle properties (BAMJET index convention)
33355       CHARACTER*8  ANAME
33356       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33357      &                IICH(210),IIBAR(210),K1(210),K2(210)
33358 * final state from HADRIN interaction
33359       PARAMETER (MAXFIN=10)
33360       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
33361      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
33362
33363 C     DATA TSLOPE /10.0D0/
33364
33365       IREJ = 0
33366
33367     1 CONTINUE
33368
33369       PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
33370       EKIN = ELAB-AAM(IP)
33371 *   kinematical quantities in cms of the hadrons
33372       AMP2 = AAM(IP)**2
33373       AMT2 = AAM(IT)**2
33374       S    = AMP2+AMT2+TWO*ELAB*AAM(IT)
33375       ECM  = SQRT(S)
33376       ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
33377       PCM  = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
33378
33379 * nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
33380       IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
33381      &     ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
33382 *   TSAMCS treats pp and np only, therefore change pn into np and
33383 *   nn into pp
33384          IF (IT.EQ.1) THEN
33385             KPROJ = IP
33386          ELSE
33387             KPROJ = 8
33388             IF (IP.EQ.8) KPROJ = 1
33389          ENDIF
33390          CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
33391          T = TWO*PCM**2*(CTCMS-ONE)
33392
33393 * very crude treatment otherwise: sample t from exponential dist.
33394       ELSE
33395 *   momentum transfer t
33396          TMAX = TWO*TWO*PCM**2
33397          RR = (PLAB-PLOWH)/(PHIH-PLOWH)
33398          IF (IIBAR(IP).NE.0) THEN
33399             TSLOPE = BLOWB+RR*(BHIB-BLOWB)
33400          ELSE
33401             TSLOPE = BLOWM+RR*(BHIM-BLOWM)
33402          ENDIF
33403          FMAX = EXP(-TSLOPE*TMAX)-ONE
33404          R = DT_RNDM(RR)
33405          T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
33406          IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
33407       ENDIF
33408
33409 *   target hadron in Lab after scattering
33410       ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
33411       PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
33412       IF (PLRH(2).LE.TINY10) THEN
33413 C        WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
33414          GOTO 1
33415       ENDIF
33416 *   projectile hadron in Lab after scattering
33417       ELRH(1) = ELAB+AAM(IT)-ELRH(2)
33418       PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
33419 *   scattering angle of projectile in Lab
33420       CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
33421       STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
33422       CALL DT_DSFECF(SPLABP,CPLABP)
33423 *   direction cosines of projectile in Lab
33424       CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
33425      &                          CXRH(1),CYRH(1),CZRH(1))
33426 *   scattering angle of target in Lab
33427       PLLABT = PLAB-CTLABP*PLRH(1)
33428       CTLABT = PLLABT/PLRH(2)
33429       STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
33430 *   direction cosines of target in Lab
33431       CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
33432      &                            CXRH(2),CYRH(2),CZRH(2))
33433 *   fill /HNFSPA/
33434       IRH = 2
33435       ITRH(1) = IP
33436       ITRH(2) = IT
33437
33438       RETURN
33439       END
33440
33441 *$ CREATE DT_TSAMCS.FOR
33442 *COPY DT_TSAMCS
33443 *
33444 *===tsamcs=============================================================*
33445 *
33446       SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
33447
33448 ************************************************************************
33449 * Sampling of cos(theta) for nucleon-proton scattering according to    *
33450 * hetkfa2/bertini parametrization.                                     *
33451 * This is a revised version of the original (HJM 24/10/88)             *
33452 * This version dated 28.10.95 is written by S. Roesler                 *
33453 ************************************************************************
33454
33455       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33456       SAVE
33457       PARAMETER ( LINP = 10 ,
33458      &            LOUT = 6 ,
33459      &            LDAT = 9 )
33460       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
33461      &           TINY10=1.0D-10)
33462
33463       DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
33464       DIMENSION PDCI(60),PDCH(55)
33465
33466       DATA (DCLIN(I),I=1,80) /
33467      &     5.000D-01,  1.000D+00,  0.000D+00,  1.000D+00,  0.000D+00,
33468      &     4.993D-01,  9.881D-01,  5.963D-02,  9.851D-01,  5.945D-02,
33469      &     4.936D-01,  8.955D-01,  5.224D-01,  8.727D-01,  5.091D-01,
33470      &     4.889D-01,  8.228D-01,  8.859D-01,  7.871D-01,  8.518D-01,
33471      &     4.874D-01,  7.580D-01,  1.210D+00,  7.207D-01,  1.117D+00,
33472      &     4.912D-01,  6.969D-01,  1.516D+00,  6.728D-01,  1.309D+00,
33473      &     5.075D-01,  6.471D-01,  1.765D+00,  6.667D-01,  1.333D+00,
33474      &     5.383D-01,  6.054D-01,  1.973D+00,  7.059D-01,  1.176D+00,
33475      &     5.397D-01,  5.990D-01,  2.005D+00,  7.023D-01,  1.191D+00,
33476      &     5.336D-01,  6.083D-01,  1.958D+00,  6.959D-01,  1.216D+00,
33477      &     5.317D-01,  6.075D-01,  1.962D+00,  6.897D-01,  1.241D+00,
33478      &     5.300D-01,  6.016D-01,  1.992D+00,  6.786D-01,  1.286D+00,
33479      &     5.281D-01,  6.063D-01,  1.969D+00,  6.786D-01,  1.286D+00,
33480      &     5.280D-01,  5.960D-01,  2.020D+00,  6.667D-01,  1.333D+00,
33481      &     5.273D-01,  5.920D-01,  2.040D+00,  6.604D-01,  1.358D+00,
33482      &     5.273D-01,  5.862D-01,  2.069D+00,  6.538D-01,  1.385D+00/
33483       DATA (DCLIN(I),I=81,160) /
33484      &     5.223D-01,  5.980D-01,  2.814D+00,  6.538D-01,  1.385D+00,
33485      &     5.202D-01,  5.969D-01,  2.822D+00,  6.471D-01,  1.412D+00,
33486      &     5.183D-01,  5.881D-01,  2.883D+00,  6.327D-01,  1.469D+00,
33487      &     5.159D-01,  5.866D-01,  2.894D+00,  6.250D-01,  1.500D+00,
33488      &     5.133D-01,  5.850D-01,  2.905D+00,  6.170D-01,  1.532D+00,
33489      &     5.106D-01,  5.833D-01,  2.917D+00,  6.087D-01,  1.565D+00,
33490      &     5.084D-01,  5.801D-01,  2.939D+00,  6.000D-01,  1.600D+00,
33491      &     5.063D-01,  5.763D-01,  2.966D+00,  5.909D-01,  1.636D+00,
33492      &     5.036D-01,  5.730D-01,  2.989D+00,  5.814D-01,  1.674D+00,
33493      &     5.014D-01,  5.683D-01,  3.022D+00,  5.714D-01,  1.714D+00,
33494      &     4.986D-01,  5.641D-01,  3.051D+00,  5.610D-01,  1.756D+00,
33495      &     4.964D-01,  5.580D-01,  3.094D+00,  5.500D-01,  1.800D+00,
33496      &     4.936D-01,  5.573D-01,  3.099D+00,  5.431D-01,  1.827D+00,
33497      &     4.909D-01,  5.509D-01,  3.144D+00,  5.313D-01,  1.875D+00,
33498      &     4.885D-01,  5.512D-01,  3.142D+00,  5.263D-01,  1.895D+00,
33499      &     4.857D-01,  5.437D-01,  3.194D+00,  5.135D-01,  1.946D+00/
33500       DATA (DCLIN(I),I=161,195) /
33501      &     4.830D-01,  5.353D-01,  3.253D+00,  5.000D-01,  2.000D+00,
33502      &     4.801D-01,  5.323D-01,  3.274D+00,  4.915D-01,  2.034D+00,
33503      &     4.770D-01,  5.228D-01,  3.341D+00,  4.767D-01,  2.093D+00,
33504      &     4.738D-01,  5.156D-01,  3.391D+00,  4.643D-01,  2.143D+00,
33505      &     4.701D-01,  5.010D-01,  3.493D+00,  4.444D-01,  2.222D+00,
33506      &     4.672D-01,  4.990D-01,  3.507D+00,  4.375D-01,  2.250D+00,
33507      &     4.634D-01,  4.856D-01,  3.601D+00,  4.194D-01,  2.323D+00/
33508
33509       DATA PDCI /
33510      &     4.400D+02,  1.896D-01,  1.931D-01,  1.982D-01,  1.015D-01,
33511      &     1.029D-01,  4.180D-02,  4.228D-02,  4.282D-02,  4.350D-02,
33512      &     2.204D-02,  2.236D-02,  5.900D+02,  1.433D-01,  1.555D-01,
33513      &     1.774D-01,  1.000D-01,  1.128D-01,  5.132D-02,  5.600D-02,
33514      &     6.158D-02,  6.796D-02,  3.660D-02,  3.820D-02,  6.500D+02,
33515      &     1.192D-01,  1.334D-01,  1.620D-01,  9.527D-02,  1.141D-01,
33516      &     5.283D-02,  5.952D-02,  6.765D-02,  7.878D-02,  4.796D-02,
33517      &     6.957D-02,  8.000D+02,  4.872D-02,  6.694D-02,  1.152D-01,
33518      &     9.348D-02,  1.368D-01,  6.912D-02,  7.953D-02,  9.577D-02,
33519      &     1.222D-01,  7.755D-02,  9.525D-02,  1.000D+03,  3.997D-02,
33520      &     5.456D-02,  9.804D-02,  8.084D-02,  1.208D-01,  6.520D-02,
33521      &     8.233D-02,  1.084D-01,  1.474D-01,  9.328D-02,  1.093D-01/
33522
33523       DATA PDCH /
33524      &     1.000D+03,  9.453D-02,  9.804D-02,  8.084D-02,  1.208D-01,
33525      &     6.520D-02,  8.233D-02,  1.084D-01,  1.474D-01,  9.328D-02,
33526      &     1.093D-01,  1.400D+03,  1.072D-01,  7.450D-02,  6.645D-02,
33527      &     1.136D-01,  6.750D-02,  8.580D-02,  1.110D-01,  1.530D-01,
33528      &     1.010D-01,  1.350D-01,  2.170D+03,  4.004D-02,  3.013D-02,
33529      &     2.664D-02,  5.511D-02,  4.240D-02,  7.660D-02,  1.364D-01,
33530      &     2.300D-01,  1.670D-01,  2.010D-01,  2.900D+03,  1.870D-02,
33531      &     1.804D-02,  1.320D-02,  2.970D-02,  2.860D-02,  5.160D-02,
33532      &     1.020D-01,  2.400D-01,  2.250D-01,  3.370D-01,  4.400D+03,
33533      &     1.196D-03,  8.784D-03,  1.517D-02,  2.874D-02,  2.488D-02,
33534      &     4.464D-02,  8.330D-02,  2.008D-01,  2.360D-01,  3.567D-01/
33535
33536       DATA (DCHN(I),I=1,90) /
33537      &     4.770D-01,  4.750D-01,  4.715D-01,  4.685D-01,  4.650D-01,
33538      &     4.610D-01,  4.570D-01,  4.550D-01,  4.500D-01,  4.450D-01,
33539      &     4.405D-01,  4.350D-01,  4.300D-01,  4.250D-01,  4.200D-01,
33540      &     4.130D-01,  4.060D-01,  4.000D-01,  3.915D-01,  3.840D-01,
33541      &     3.760D-01,  3.675D-01,  3.580D-01,  3.500D-01,  3.400D-01,
33542      &     3.300D-01,  3.200D-01,  3.100D-01,  3.000D-01,  2.900D-01,
33543      &     2.800D-01,  2.700D-01,  2.600D-01,  2.500D-01,  2.400D-01,
33544      &     2.315D-01,  2.240D-01,  2.150D-01,  2.060D-01,  2.000D-01,
33545      &     1.915D-01,  1.850D-01,  1.780D-01,  1.720D-01,  1.660D-01,
33546      &     1.600D-01,  1.550D-01,  1.500D-01,  1.450D-01,  1.400D-01,
33547      &     1.360D-01,  1.320D-01,  1.280D-01,  1.250D-01,  1.210D-01,
33548      &     1.180D-01,  1.150D-01,  1.120D-01,  1.100D-01,  1.070D-01,
33549      &     1.050D-01,  1.030D-01,  1.010D-01,  9.900D-02,  9.700D-02,
33550      &     9.550D-02,  9.480D-02,  9.400D-02,  9.200D-02,  9.150D-02,
33551      &     9.100D-02,  9.000D-02,  8.990D-02,  8.900D-02,  8.850D-02,
33552      &     8.750D-02,  8.700D-02,  8.650D-02,  8.550D-02,  8.500D-02,
33553      &     8.499D-02,  8.450D-02,  8.350D-02,  8.300D-02,  8.250D-02,
33554      &     8.150D-02,  8.100D-02,  8.030D-02,  8.000D-02,  7.990D-02/
33555       DATA (DCHN(I),I=91,143) /
33556      &     7.980D-02,  7.950D-02,  7.900D-02,  7.860D-02,  7.800D-02,
33557      &     7.750D-02,  7.650D-02,  7.620D-02,  7.600D-02,  7.550D-02,
33558      &     7.530D-02,  7.500D-02,  7.499D-02,  7.498D-02,  7.480D-02,
33559      &     7.450D-02,  7.400D-02,  7.350D-02,  7.300D-02,  7.250D-02,
33560      &     7.230D-02,  7.200D-02,  7.100D-02,  7.050D-02,  7.020D-02,
33561      &     7.000D-02,  6.999D-02,  6.995D-02,  6.993D-02,  6.991D-02,
33562      &     6.990D-02,  6.870D-02,  6.850D-02,  6.800D-02,  6.780D-02,
33563      &     6.750D-02,  6.700D-02,  6.650D-02,  6.630D-02,  6.600D-02,
33564      &     6.550D-02,  6.525D-02,  6.510D-02,  6.500D-02,  6.499D-02,
33565      &     6.498D-02,  6.496D-02,  6.494D-02,  6.493D-02,  6.490D-02,
33566      &     6.488D-02,  6.485D-02,  6.480D-02/
33567
33568       DATA DCHNA /
33569      &     6.300D+02,  7.810D-02,  1.421D-01,  1.979D-01,  2.479D-01,
33570      &     3.360D-01,  5.400D-01,  7.236D-01,  1.000D+00,  1.540D+03,
33571      &     2.225D-01,  3.950D-01,  5.279D-01,  6.298D-01,  7.718D-01,
33572      &     9.405D-01,  9.835D-01,  1.000D+00,  2.560D+03,  2.625D-01,
33573      &     4.550D-01,  5.963D-01,  7.020D-01,  8.380D-01,  9.603D-01,
33574      &     9.903D-01,  1.000D+00,  3.520D+03,  4.250D-01,  6.875D-01,
33575      &     8.363D-01,  9.163D-01,  9.828D-01,  1.000D+00,  1.000D+00,
33576      &     1.000D+00/
33577
33578       DATA DCHNB /
33579      &     6.300D+02,  3.800D-02,  7.164D-02,  1.275D-01,  2.171D-01,
33580      &     3.227D-01,  4.091D-01,  5.051D-01,  6.061D-01,  7.074D-01,
33581      &     8.434D-01,  1.000D+00,  2.040D+03,  1.200D-01,  2.115D-01,
33582      &     3.395D-01,  5.295D-01,  7.251D-01,  8.511D-01,  9.487D-01,
33583      &     9.987D-01,  1.000D+00,  1.000D+00,  1.000D+00,  2.200D+03,
33584      &     1.344D-01,  2.324D-01,  3.754D-01,  5.674D-01,  7.624D-01,
33585      &     8.896D-01,  9.808D-01,  1.000D+00,  1.000D+00,  1.000D+00,
33586      &     1.000D+00,  2.850D+03,  2.330D-01,  4.130D-01,  6.610D-01,
33587      &     9.010D-01,  9.970D-01,  1.000D+00,  1.000D+00,  1.000D+00,
33588      &     1.000D+00,  1.000D+00,  1.000D+00,  3.500D+03,  3.300D-01,
33589      &     5.450D-01,  7.950D-01,  1.000D+00,  1.000D+00,  1.000D+00,
33590      &     1.000D+00,  1.000D+00,  1.000D+00,  1.000D+00,  1.000D+00/
33591
33592       CST = ONE
33593       IF (EKIN.GT.3.5D0) RETURN
33594 C
33595       IF(KPROJ.EQ.8) GOTO 101
33596       IF(KPROJ.EQ.1) GOTO 102
33597 C*                                             INVALID REACTION
33598       WRITE(LOUT,'(A,I5/A)')
33599      &        ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
33600      &        ' COS(THETA) = 1D0 RETURNED'
33601       RETURN
33602 C-------------------------------- NP ELASTIC SCATTERING----------
33603 101   CONTINUE
33604       IF (EKIN.GT.0.740D0)GOTO 1000
33605       IF (EKIN.LT.0.300D0)THEN
33606 C                                 EKIN .LT. 300 MEV
33607          IDAT=1
33608       ELSE
33609 C                                 300 MEV < EKIN < 740 MEV
33610          IDAT=6
33611       END IF
33612 C
33613       ENER=EKIN
33614       IE=INT(ABS(ENER/0.020D0))
33615       UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
33616 C                                            FORWARD/BACKWARD DECISION
33617       K=IDAT+5*IE
33618       BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
33619       IF (DT_RNDM(CST).LT.BWFW)THEN
33620          VALUE2=-1D0
33621          K=K+1
33622       ELSE
33623          VALUE2=1D0
33624          K=K+3
33625       END IF
33626 C
33627       COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
33628       RND=DT_RNDM(COEF)
33629 C
33630       IF(RND.LT.COEF)THEN
33631          CST=DT_RNDM(RND)
33632          CST=CST*VALUE2
33633       ELSE
33634          R1=DT_RNDM(CST)
33635          R2=DT_RNDM(R1)
33636          R3=DT_RNDM(R2)
33637          R4=DT_RNDM(R3)
33638 C
33639          IF(VALUE2.GT.0.0)THEN
33640             CST=MAX(R1,R2,R3,R4)
33641             GOTO 1500
33642          ELSE
33643             R5=DT_RNDM(R4)
33644 C
33645             IF (IDAT.EQ.1)THEN
33646                CST=-MAX(R1,R2,R3,R4,R5)
33647             ELSE
33648                R6=DT_RNDM(R5)
33649                R7=DT_RNDM(R6)
33650                CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
33651             END IF
33652 C
33653          END IF
33654 C
33655       END IF
33656 C
33657       GOTO 1500
33658 C
33659 C********                                EKIN  .GT.  0.74 GEV
33660 C
33661 1000  ENER=EKIN - 0.66D0
33662 C     IE=ABS(ENER/0.02)
33663       IE=INT(ENER/0.02D0)
33664       EMEV=EKIN*1D3
33665 C
33666       UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
33667       K=IE
33668       BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
33669       RND=DT_RNDM(BWFW)
33670 C                                        FORWARD NEUTRON
33671       IF (RND.GE.BWFW)THEN
33672          DO 1200 K=10,36,9
33673            IF (DCHNA(K).GT.EMEV) THEN
33674               UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
33675               UNIV=DT_RNDM(UNIVE)
33676               DO 1100 I=1,8
33677                  II=K+I
33678                  P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
33679 C
33680                  IF (P.GT.UNIV)THEN
33681                     UNIV=DT_RNDM(UNIVE)
33682                     FLTI=DBLE(I)-UNIV
33683                     GOTO(290,290,290,290,330,340,350,360) I
33684                  END IF
33685  1100         CONTINUE
33686            END IF
33687  1200    CONTINUE
33688 C
33689       ELSE
33690 C                                        BACKWARD NEUTRON
33691          DO 1400 K=13,60,12
33692             IF (DCHNB(K).GT.EMEV) THEN
33693                UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
33694                UNIV=DT_RNDM(UNIVE)
33695                DO 1300 I=1,11
33696                  II=K+I
33697                  P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
33698 C
33699                  IF (P.GT.UNIV)THEN
33700                    UNIV=DT_RNDM(P)
33701                    FLTI=DBLE(I)-UNIV
33702                    GOTO(120,120,140,150,160,160,180,190,200,210,220) I
33703                  END IF
33704  1300          CONTINUE
33705             END IF
33706  1400    CONTINUE
33707       END IF
33708 C
33709 120   CST=1.0D-2*FLTI-1.0D0
33710       GOTO 1500
33711 140   CST=2.0D-2*UNIV-0.98D0
33712       GOTO 1500
33713 150   CST=4.0D-2*UNIV-0.96D0
33714       GOTO 1500
33715 160   CST=6.0D-2*FLTI-1.16D0
33716       GOTO 1500
33717 180   CST=8.0D-2*UNIV-0.80D0
33718       GOTO 1500
33719 190   CST=1.0D-1*UNIV-0.72D0
33720       GOTO 1500
33721 200   CST=1.2D-1*UNIV-0.62D0
33722       GOTO 1500
33723 210   CST=2.0D-1*UNIV-0.50D0
33724       GOTO 1500
33725 220   CST=3.0D-1*(UNIV-1.0D0)
33726       GOTO 1500
33727 C
33728 290   CST=1.0D0-2.5d-2*FLTI
33729       GOTO 1500
33730 330   CST=0.85D0+0.5D-1*UNIV
33731       GOTO 1500
33732 340   CST=0.70D0+1.5D-1*UNIV
33733       GOTO 1500
33734 350   CST=0.50D0+2.0D-1*UNIV
33735       GOTO 1500
33736 360   CST=0.50D0*UNIV
33737 C
33738 1500  RETURN
33739 C
33740 C-----------------------------------  PP ELASTIC SCATTERING -------
33741 C
33742  102  CONTINUE
33743       EMEV=EKIN*1D3
33744 C
33745       IF (EKIN.LE.0.500D0) THEN
33746          RND=DT_RNDM(EMEV)
33747          CST=2.0D0*RND-1.0D0
33748          RETURN
33749 C
33750       ELSEIF (EKIN.LT.1.0D0) THEN
33751          DO 2200 K=13,60,12
33752             IF (PDCI(K).GT.EMEV) THEN
33753                UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
33754                UNIV=DT_RNDM(UNIVE)
33755                SUM=0
33756                DO 2100 I=1,11
33757                  II=K+I
33758                  SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
33759 C
33760                  IF (UNIV.LT.SUM)THEN
33761                    UNIV=DT_RNDM(SUM)
33762                    FLTI=DBLE(I)-UNIV
33763                    GOTO(55,55,55,60,60,65,65,65,65,70,70) I
33764                  END IF
33765  2100          CONTINUE
33766             END IF
33767  2200    CONTINUE
33768       ELSE
33769          DO 2400 K=12,55,11
33770             IF (PDCH(K).GT.EMEV) THEN
33771               UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
33772               UNIV=DT_RNDM(UNIVE)
33773               SUM=0.0D0
33774               DO 2300 I=1,10
33775                 II=K+I
33776                 SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
33777 C
33778                 IF (UNIV.LT.SUM)THEN
33779                   UNIV=DT_RNDM(SUM)
33780                   FLTI=UNIV+DBLE(I)
33781                   GOTO(50,55,60,60,65,65,65,65,70,70) I
33782                 END IF
33783  2300         CONTINUE
33784             END IF
33785  2400    CONTINUE
33786       END IF
33787 C
33788 50    CST=0.4D0*UNIV
33789       GOTO 2500
33790 55    CST=0.2D0*FLTI
33791       GOTO 2500
33792 60    CST=0.3D0+0.1D0*FLTI
33793       GOTO 2500
33794 65    CST=0.6D0+0.04D0*FLTI
33795       GOTO 2500
33796 70    CST=0.78D0+0.02D0*FLTI
33797 C
33798 2500  CONTINUE
33799       IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
33800 C
33801       RETURN
33802       END
33803
33804 *$ CREATE DT_DHADRI.FOR
33805 *COPY DT_DHADRI
33806 *
33807 *===dhadri=============================================================*
33808 *
33809       SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
33810
33811       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33812       SAVE
33813
33814       PARAMETER ( LINP = 10 ,
33815      &            LOUT = 6 ,
33816      &            LDAT = 9 )
33817 C
33818 C-----------------------------
33819 C*** INPUT VARIABLES LIST:
33820 C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
33821 C*** GEV/C LABORATORY MOMENTUM REGION
33822 C*** N    - PROJECTILE HADRON INDEX
33823 C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
33824 C*** ELAB - LABORATORY ENERGY OF N (GEV)
33825 C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
33826 C*** ITTA - TARGET NUCLEON INDEX
33827 C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
33828 C  IR COUNTS THE NUMBER OF PRODUCED PARTICLES
33829 C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
33830 C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
33831 C*** RESPECT., UNITS (GEV/C AND GEV)
33832 C----------------------------
33833
33834       COMMON /HNGAMR/ REDU,AMO,AMM(15)
33835       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33836       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33837      &                NRK(2,268),NURE(30,2)
33838 * particle properties (BAMJET index convention),
33839 * (dublicate of DTPART for HADRIN)
33840       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33841      &                K1H(110),K2H(110)
33842       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33843       COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
33844      &                ITS(149),IS
33845       COMMON /HNDRUN/ RUNTES,EFTES
33846 * particle properties (BAMJET index convention)
33847       CHARACTER*8  ANAME
33848       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33849      &                IICH(210),IIBAR(210),K1(210),K2(210)
33850 * final state from HADRIN interaction
33851       PARAMETER (MAXFIN=10)
33852       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
33853      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
33854
33855       DIMENSION ITPRF(110)
33856       DATA NNN/0/
33857       DATA UMODA/0./
33858       DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
33859       LOWP=0
33860       IF (N.LE.0.OR.N.GE.111)N=1
33861       IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
33862         GOTO 280
33863 *       WRITE (6,1000)
33864 *    +  ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
33865 *       STOP
33866 *1000   FORMAT (3(5H ****/),A,2I4,3(5H ****/))
33867 *    +  45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
33868       ENDIF
33869       IATMPT=0
33870       IF (ABS(PLAB-5.0D0).LT.4.99999D0)                        GO TO 20
33871 C     IF(IPRI.GE.1) WRITE (6,1010) PLAB
33872 C     STOP
33873  1010 FORMAT ( '  PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
33874      + ALLOWED REGION, PLAB=',1E15.5)
33875
33876    20 CONTINUE
33877       UMODAT=N*1.11111D0+ITTA*2.19291D0
33878       IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
33879       UMODA=UMODAT
33880    30 IATMPT=0
33881       LOWP=LOWP+1
33882    40 CONTINUE
33883       IMACH=0
33884       REDU=2.0D0
33885       IF (LOWP.GT.20) THEN
33886 C        WRITE(LOUT,*) ' jump 1'
33887          GO TO 280
33888       ENDIF
33889       NNN=N
33890       IF (NNN.EQ.N)                                             GO TO 50
33891       RUNTES=0.0D0
33892       EFTES=0.0D0
33893    50 CONTINUE
33894       IS=1
33895       IRH=0
33896       IST=1
33897       NSTAB=23
33898       IRE=NURE(N,1)
33899       IF(ITTA.GT.1) IRE=NURE(N,2)
33900 C
33901 C-----------------------------
33902 C*** IE,AMT,ECM,SI DETERMINATION
33903 C----------------------------
33904       CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
33905       IANTH=-1
33906 **sr
33907 C     IF (AMH(1).NE.0.93828D0) IANTH=1
33908       IF (AMH(1).NE.0.9383D0) IANTH=1
33909 **
33910       IF (IANTH.GE.0) SI=1.0D0
33911       ECMMH=ECM
33912 C
33913 C-----------------------------
33914 C    ENERGY INDEX
33915 C  IRE CHARACTERIZES THE REACTION
33916 C  IE IS THE ENERGY INDEX
33917 C----------------------------
33918       IF (SI.LT.1.D-6) THEN
33919 C        WRITE(LOUT,*) ' jump 2'
33920          GO TO 280
33921       ENDIF
33922       IF (N.LE.NSTAB)                                           GO TO 60
33923       RUNTES=RUNTES+1.0D0
33924       IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
33925  1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
33926       IF(IBARH(N).EQ.1) N=8
33927       IF(IBARH(N).EQ.-1)  N=9
33928    60 CONTINUE
33929       IMACH=IMACH+1
33930 **sr 19.2.97: loop for direct channel suppression
33931 C     IF (IMACH.GT.10) THEN
33932       IF (IMACH.GT.1000) THEN
33933 **
33934 C        WRITE(LOUT,*) ' jump 3'
33935          GO TO 280
33936       ENDIF
33937       ECM =ECMMH
33938       AMN2=AMN**2
33939       AMT2=AMT**2
33940       ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM    )
33941       IF(ECMN.LE.AMN) ECMN=AMN
33942       PCMN=SQRT(ECMN**2-AMN2)
33943       GAM=(ELAB+AMT)/ECM
33944       BGAM=PLAB/ECM
33945       IF (IANTH.GE.0) ECM=2.1D0
33946 C
33947 C-----------------------------
33948 C*** RANDOM CHOICE OF REACTION CHANNEL
33949 C----------------------------
33950       IST=0
33951       VV=DT_RNDM(AMN2)
33952       VV=VV-1.D-17
33953 C
33954 C-----------------------------
33955 C***  PLACE REDUCED VERSION
33956 C----------------------------
33957       IIEI=IEII(IRE)
33958       IDWK=IEII(IRE+1)-IIEI
33959       IIWK=IRII(IRE)
33960       IIKI=IKII(IRE)
33961 C
33962 C-----------------------------
33963 C***  SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
33964 C----------------------------
33965       HECM=ECM
33966       HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
33967       IF (HUMO.LT.ECM) ECM=HUMO
33968 C
33969 C-----------------------------
33970 C*** INTERPOLATION PREPARATION
33971 C----------------------------
33972       ECMO=UMO(IE)
33973       ECM1=UMO(IE-1)
33974       DECM=ECMO-ECM1
33975       DEC=ECMO-ECM
33976 C
33977 C-----------------------------
33978 C*** RANDOM LOOP
33979 C----------------------------
33980       IK=0
33981       WKK=0.0D0
33982       WICOR=0.0D0
33983    70 IK=IK+1
33984       IWK=IIWK+(IK-1)*IDWK+IE-IIEI
33985       WOK=WK(IWK)
33986       WDK=WOK-WK(IWK-1)
33987 C
33988 C-----------------------------
33989 C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
33990 C    GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
33991 C    CONTRIBUTE
33992 C----------------------------
33993       IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
33994       WICO=WOK*1.23459876D0+WDK*1.735218469D0
33995       IF (WICO.EQ.WICOR)                                        GO TO 70
33996       IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
33997       WICOR=WICO
33998 C
33999 C-----------------------------
34000 C*** INTERPOLATION IN CHANNEL WEIGHTS
34001 C----------------------------
34002       EKLIM=-THRESH(IIKI+IK)
34003       IELIM=IDT_IEFUND(EKLIM,IRE)
34004       DELIM=UMO(IELIM)+EKLIM
34005      *+1.D-16
34006       DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
34007       IF (DELIM*DELIM-DETE*DETE) 90,90,80
34008    80 DECC=DELIM
34009                                                                GO TO 100
34010    90 DECC=DECM
34011   100 CONTINUE
34012       WKK=WOK-WDK*DEC/(DECC+1.D-9)
34013 C
34014 C-----------------------------
34015 C*** RANDOM CHOICE
34016 C----------------------------
34017 C
34018       IF (VV.GT.WKK)                                            GO TO 70
34019 C
34020 C***IK IS THE REACTION CHANNEL
34021 C----------------------------
34022       INRK=IKII(IRE)+IK
34023       ECM=HECM
34024       I1001 =0
34025 C
34026   110 CONTINUE
34027       IT1=NRK(1,INRK)
34028       AM1=DT_DAMG(IT1)
34029       IT2=NRK(2,INRK)
34030       AM2=DT_DAMG(IT2)
34031       AMS=AM1+AM2
34032       I1001=I1001+1
34033       IF (I1001.GT.50)                                          GO TO 60
34034 C
34035       IF (IT2*AMS.GT.IT2*ECM)                                  GO TO 110
34036       IT11=IT1
34037       IT22=IT2
34038       IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
34039       AM11=AM1
34040       AM22=AM2
34041       IF (IT2.GT.0)                                            GO TO 120
34042 **sr 19.2.97: supress direct channel for pp-collisions
34043       IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
34044          RR = DT_RNDM(AM11)
34045          IF (RR.LE.0.75D0) GOTO 60
34046       ENDIF
34047 **
34048 C
34049 C-----------------------------
34050 C  INCLUSION OF DIRECT RESONANCES
34051 C  RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE  IT1
34052 C------------------------
34053       KZ1=K1H(IT1)
34054       IST=IST+1
34055       IECO=0
34056       ECO=ECM
34057       GAM=(ELAB+AMT)/ECO
34058       BGAM=PLAB/ECO
34059       CXS(1)=CX
34060       CYS(1)=CY
34061       CZS(1)=CZ
34062                                                                GO TO 170
34063   120 CONTINUE
34064       WW=DT_RNDM(ECO)
34065       IF(WW.LT. 0.5D0)                                         GO TO 130
34066       IT1=IT22
34067       IT2=IT11
34068       AM1=AM22
34069       AM2=AM11
34070   130 CONTINUE
34071 C
34072 C-----------------------------
34073 C   THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
34074       IBN=IBARH(N)
34075       IB1=IBARH(IT1)
34076       IT11=IT1
34077       IT22=IT2
34078       AM11=AM1
34079       AM22=AM2
34080       IF(IB1.EQ.IBN)                                           GO TO 140
34081       IT1=IT22
34082       IT2=IT11
34083       AM1=AM22
34084       AM2=AM11
34085   140 CONTINUE
34086 C-----------------------------
34087 C***IT1,IT2 ARE THE CREATED PARTICLES
34088 C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
34089 C------------------------
34090       CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
34091      *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
34092       IST=IST+1
34093       ITS(IST)=IT1
34094       AMM(IST)=AM1
34095 C
34096 C-----------------------------
34097 C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
34098 C----------------------------
34099       CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
34100      &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34101       IST=IST+1
34102       ITS(IST)=IT2
34103       AMM(IST)=AM2
34104       CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
34105      *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34106   150 CONTINUE
34107 C
34108 C-----------------------------
34109 C***TEST   STABLE OR UNSTABLE
34110 C----------------------------
34111       IF(ITS(IST).GT.NSTAB)                                    GO TO 160
34112       IRH=IRH+1
34113 C
34114 C-----------------------------
34115 C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
34116 C----------------------------
34117 C*    IF (REDU.LT.0.D0) GO TO 1009
34118       ITRH(IRH)=ITS(IST)
34119       PLRH(IRH)=PLS(IST)
34120       CXRH(IRH)=CXS(IST)
34121       CYRH(IRH)=CYS(IST)
34122       CZRH(IRH)=CZS(IST)
34123       ELRH(IRH)=ELS(IST)
34124       IST=IST-1
34125       IF(IST.GE.1)                                             GO TO 150
34126                                                                GO TO 260
34127   160 CONTINUE
34128 C
34129 C  RANDOM CHOICE OF DECAY CHANNELS
34130 C----------------------------
34131 C
34132       IT=ITS(IST)
34133       ECO=AMM(IST)
34134       GAM=ELS(IST)/ECO
34135       BGAM=PLS(IST)/ECO
34136       IECO=0
34137       KZ1=K1H(IT)
34138   170 CONTINUE
34139       IECO=IECO+1
34140       VV=DT_RNDM(GAM)
34141       VV=VV-1.D-17
34142       IIK=KZ1-1
34143   180 IIK=IIK+1
34144       IF (VV.GT.WTI(IIK))                                      GO TO 180
34145 C
34146 C  IIK IS THE DECAY CHANNEL
34147 C----------------------------
34148       IT1=NZKI(IIK,1)
34149       I310=0
34150   190 CONTINUE
34151       I310=I310+1
34152       AM1=DT_DAMG(IT1)
34153       IT2=NZKI(IIK,2)
34154       AM2=DT_DAMG(IT2)
34155       IF (IT2-1.LT.0)                                          GO TO 240
34156       IT3=NZKI(IIK,3)
34157       AM3=DT_DAMG(IT3)
34158       AMS=AM1+AM2+AM3
34159 C
34160 C  IF  IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
34161 C----------------------------
34162       IF (IECO.LE.10)                                          GO TO 200
34163       IATMPT=IATMPT+1
34164       IF(IATMPT.GT.3) THEN
34165 C        WRITE(LOUT,*) ' jump 4'
34166          GO TO 280
34167       ENDIF
34168                                                                 GO TO 40
34169   200 CONTINUE
34170       IF (I310.GT.50)                                          GO TO 170
34171       IF (AMS.GT.ECO)                                          GO TO 190
34172 C
34173 C  FOR THE DECAY CHANNEL
34174 C  IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM  IT
34175 C----------------------------
34176       IF (REDU.LT.0.D0)                                        GO TO 30
34177       ITWTHC=0
34178       REDU=2.0D0
34179       IF(IT3.EQ.0)                                             GO TO 220
34180   210 CONTINUE
34181       ITWTH=1
34182       CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
34183      *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
34184                                                                GO TO 230
34185   220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
34186      &COD2,COF2,SIF2,AM1,AM2)
34187       ITWTH=-1
34188       IT3=0
34189   230 CONTINUE
34190       ITWTHC=ITWTHC+1
34191       IF (REDU.GT.0.D0)                                        GO TO 240
34192       REDU=2.0D0
34193       IF (ITWTHC.GT.100)                                        GO TO 30
34194       IF (ITWTH) 220,220,210
34195   240 CONTINUE
34196       ITS(IST  )=IT1
34197       IF (IT2-1.LT.0)                                          GO TO 250
34198       ITS(IST+1)  =IT2
34199       ITS(IST+2)=IT3
34200       RX=CXS(IST)
34201       RY=CYS(IST)
34202       RZ=CZS(IST)
34203       AMM(IST)=AM1
34204       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
34205      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34206       IST=IST+1
34207       AMM(IST)=AM2
34208       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
34209      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34210       IF (IT3.LE.0)                                            GO TO 250
34211       IST=IST+1
34212       AMM(IST)=AM3
34213       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
34214      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34215   250 CONTINUE
34216                                                                GO TO 150
34217   260 CONTINUE
34218   270 CONTINUE
34219       RETURN
34220   280 CONTINUE
34221 C
34222 C----------------------------
34223 C
34224 C   ZERO CROSS SECTION CASE
34225 C----------------------------
34226 C
34227       IRH=1
34228       ITRH(1)=N
34229       CXRH(1)=CX
34230       CYRH(1)=CY
34231       CZRH(1)=CZ
34232       ELRH(1)=ELAB
34233       PLRH(1)=PLAB
34234       RETURN
34235       END
34236
34237 *$ CREATE DT_RUNTT.FOR
34238 *COPY DT_RUNTT
34239 *
34240 *===runtt==============================================================*
34241 *
34242       BLOCK DATA DT_RUNTT
34243
34244       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34245       SAVE
34246
34247       COMMON /HNDRUN/ RUNTES,EFTES
34248
34249       DATA RUNTES,EFTES /100.D0,100.D0/
34250
34251       END
34252
34253 *$ CREATE DT_NONAME.FOR
34254 *COPY DT_NONAME
34255 *
34256 *===noname=============================================================*
34257 *
34258       BLOCK DATA DT_NONAME
34259
34260       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34261       SAVE
34262
34263 * slope parameters for HADRIN interactions
34264       COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
34265       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34266
34267 C     DATAS     DATAS    DATAS      DATAS     DATAS
34268 C******          *********
34269       DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
34270      &           207, 224, 241, 252, 268 /
34271       DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
34272      &           220, 241, 262, 279, 296 /
34273       DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
34274      &           3364, 3507, 4011, 4368, 4725, 4912, 5184/
34275
34276 C
34277 C     MASSES FOR THE SLOPE B(M) IN GEV
34278 C     SLOPE B(M) FOR AN MESONIC SYSTEM
34279 C     SLOPE B(M) FOR A BARYONIC SYSTEM
34280
34281 *
34282       DATA SM,BBM,BBB/  0.8D0, 0.85D0,  0.9D0, 0.95D0, 1.D0,
34283      &     1.05D0,  1.1D0, 1.15D0,  1.2D0, 1.25D0,
34284      &      1.3D0,  1.35D0, 1.4D0,  1.45D0,  1.5D0,
34285      &     1.55D0,  1.6D0,  1.65D0, 1.7D0,   1.75D0,
34286      &      1.8D0,  1.85D0, 1.9D0,  1.95D0,  2.D0,
34287      &     15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
34288      &    12.35D0, 11.7D0, 10.85D0, 10.D0,  9.15D0,
34289      &      8.3D0,  7.8D0,  7.3D0,  7.25D0,  7.2D0,
34290      &     6.95D0,  6.7D0,  6.6D0,  6.5D0,   6.3D0,
34291      &      6.1D0,  5.85D0, 5.6D0,  5.35D0,  5.1D0,
34292      &      15.D0,   15.D0, 15.D0,  15.D0,   15.D0, 15.D0, 15.D0,
34293      &     14.2D0,  13.4D0, 12.6D0,
34294      &     11.8D0, 11.2D0, 10.6D0,  9.8D0,    9.D0,
34295      &     8.25D0,  7.5D0, 6.25D0,  5.D0,    4.5D0, 5*4.D0 /
34296 *
34297       END
34298
34299 *$ CREATE DT_DAMG.FOR
34300 *COPY DT_DAMG
34301 *
34302 *===damg===============================================================*
34303 *
34304       DOUBLE PRECISION FUNCTION DT_DAMG(IT)
34305
34306       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34307       SAVE
34308
34309 * particle properties (BAMJET index convention),
34310 * (dublicate of DTPART for HADRIN)
34311       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34312      &                K1H(110),K2H(110)
34313
34314       DIMENSION GASUNI(14)
34315       DATA GASUNI/
34316      *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
34317      *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
34318       DATA GAUNO/2.352D0/
34319       DATA GAUNON/2.4D0/
34320       DATA IO/14/
34321       DATA NSTAB/23/
34322
34323       I=1
34324       IF (IT.LE.0)                                              GO TO 30
34325       IF (IT.LE.NSTAB)                                          GO TO 20
34326       DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
34327       VV=DT_RNDM(DGAUNI)
34328       VV=VV*2.0D0-1.0D0+1.D-16
34329    10 CONTINUE
34330       VO=GASUNI(I)
34331       I=I+1
34332       V1=GASUNI(I)
34333       IF (VV.GT.V1)                                             GO TO 10
34334       UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
34335      &      (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
34336       DAM=GAH(IT)*UNIGA/GAUNO
34337       AAM=AMH(IT)+DAM
34338       DT_DAMG=AAM
34339       RETURN
34340    20 CONTINUE
34341       DT_DAMG=AMH(IT)
34342       RETURN
34343    30 CONTINUE
34344       DT_DAMG=0.0D0
34345       RETURN
34346       END
34347
34348 *$ CREATE DT_DCALUM.FOR
34349 *COPY DT_DCALUM
34350 *
34351 *===dcalum=============================================================*
34352 *
34353       SUBROUTINE DT_DCALUM(N,ITTA)
34354
34355       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34356       SAVE
34357
34358 C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
34359
34360 * particle properties (BAMJET index convention),
34361 * (dublicate of DTPART for HADRIN)
34362       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34363      &                K1H(110),K2H(110)
34364       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34365       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34366       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34367      &                NRK(2,268),NURE(30,2)
34368
34369       IRE=NURE(N,ITTA/8+1)
34370       IEO=IEII(IRE)+1
34371       IEE=IEII(IRE +1)
34372       AM1=AMH(N   )
34373       AM12=AM1**2
34374       AM2=AMH(ITTA)
34375       AM22=AM2**2
34376       DO 10 IE=IEO,IEE
34377         PLAB2=PLABF(IE)**2
34378         ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
34379         UMO(IE)=ELAB
34380    10 CONTINUE
34381       IKO=IKII(IRE)+1
34382       IKE=IKII(IRE +1)
34383       UMOO=UMO(IEO)
34384       DO 30 IK=IKO,IKE
34385         IF(NRK(2,IK).GT.0)                                      GO TO 30
34386         IKI=NRK(1,IK)
34387         AMSS=5.0D0
34388         K11=K1H(IKI)
34389         K22=K2H(IKI)
34390         DO 20 IK1=K11,K22
34391           IN=NZKI(IK1,1)
34392           AMS=AMH(IN)
34393           IN=NZKI(IK1,2)
34394           IF(IN.GT.0)AMS=AMS+AMH(IN)
34395           IN=NZKI(IK1,3)
34396           IF(IN.GT.0) AMS=AMS+AMH(IN)
34397           IF (AMS.LT.AMSS) AMSS=AMS
34398    20   CONTINUE
34399         IF(UMOO.LT.AMSS) UMOO=AMSS
34400         THRESH(IK)=UMOO
34401    30 CONTINUE
34402       RETURN
34403       END
34404
34405 *$ CREATE DT_DCHANH.FOR
34406 *COPY DT_DCHANH
34407 *
34408 *===dchanh=============================================================*
34409 *
34410       SUBROUTINE DT_DCHANH
34411
34412       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34413       SAVE
34414
34415       PARAMETER ( LINP = 10 ,
34416      &            LOUT = 6 ,
34417      &            LDAT = 9 )
34418 * particle properties (BAMJET index convention),
34419 * (dublicate of DTPART for HADRIN)
34420       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34421      &                K1H(110),K2H(110)
34422       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34423       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34424       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34425      &                NRK(2,268),NURE(30,2)
34426
34427       DIMENSION HWT(460),HWK(40),SI(5184)
34428       EQUIVALENCE (WK(1),SI(1))
34429 C--------------------
34430 C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
34431 C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
34432 C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
34433 C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
34434 C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
34435 C--------------------------
34436       IREG=16
34437       DO 90 IRE=1,IREG
34438         IWKO=IRII(IRE)
34439         IEE=IEII(IRE+1)-IEII(IRE)
34440         IKE=IKII(IRE+1)-IKII(IRE)
34441         IEO=IEII(IRE)+1
34442         IIKA=IKII(IRE)
34443 *   modifications to suppress elestic scattering  24/07/91
34444         DO 80 IE=1,IEE
34445           SIS=1.D-14
34446           SINORC=0.0D0
34447           DO 10 IK=1,IKE
34448             IWK=IWKO+IEE*(IK-1)+IE
34449             IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
34450             SIS=SIS+SI(IWK)*SINORC
34451    10     CONTINUE
34452           SIIN(IEO+IE-1)=SIS
34453           SIO=0.D0
34454           IF (SIS.GE.1.D-12)                                    GO TO 20
34455           SIS=1.D0
34456           SIO=1.D0
34457    20     CONTINUE
34458           SINORC=0.0D0
34459           DO 30 IK=1,IKE
34460             IWK=IWKO+IEE*(IK-1)+IE
34461             IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
34462             SIO=SIO+SI(IWK)*SINORC/SIS
34463             HWK(IK)=SIO
34464    30     CONTINUE
34465           DO 40 IK=1,IKE
34466             IWK=IWKO+IEE*(IK-1)+IE
34467    40     WK(IWK)=HWK(IK)
34468           IIKI=IKII(IRE)
34469           DO 70 IK=1,IKE
34470             AM111=0.D0
34471             INRK1=NRK(1,IIKI+IK)
34472             IF (INRK1.GT.0) AM111=AMH(INRK1)
34473             AM222=0.D0
34474             INRK2=NRK(2,IIKI+IK)
34475             IF (INRK2.GT.0) AM222=AMH(INRK2)
34476             THRESH(IIKI+IK)=AM111 +AM222
34477             IF (INRK2-1.GE.0)                                   GO TO 60
34478             INRKK=K1H(INRK1)
34479             AMSS=5.D0
34480             INRKO=K2H(INRK1)
34481             DO 50 INRK1=INRKK,INRKO
34482               INZK1=NZKI(INRK1,1)
34483               INZK2=NZKI(INRK1,2)
34484               INZK3=NZKI(INRK1,3)
34485               IF (INZK1.LE.0.OR.INZK1.GT.110)                   GO TO 50
34486               IF (INZK2.LE.0.OR.INZK2.GT.110)                   GO TO 50
34487               IF (INZK3.LE.0.OR.INZK3.GT.110)                   GO TO 50
34488 C     WRITE (6,310)INRK1,INZK1,INZK2,INZK3
34489  1000 FORMAT (4I10)
34490               AMS=AMH(INZK1)+AMH(INZK2)
34491               IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
34492               IF (AMSS.GT.AMS) AMSS=AMS
34493    50       CONTINUE
34494             AMS=AMSS
34495             IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
34496             THRESH(IIKI+IK)=AMS
34497    60       CONTINUE
34498    70     CONTINUE
34499    80   CONTINUE
34500    90 CONTINUE
34501       DO 100 J=1,460
34502   100 HWT(J)=0.D0
34503       DO 120 I=1,110
34504         IK1=K1H(I)
34505         IK2=K2H(I)
34506         HV=0.D0
34507         IF (IK2.GT.460)IK2=460
34508         IF (IK1.LE.0)IK1=1
34509         DO 110 J=IK1,IK2
34510           HV=HV+WTI(J)
34511           HWT(J)=HV
34512           JI=J
34513   110   CONTINUE
34514         IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
34515  1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
34516   120 CONTINUE
34517       DO 130 J=1,460
34518   130 WTI(J)=HWT(J)
34519       RETURN
34520       END
34521
34522 *$ CREATE DT_DHADDE.FOR
34523 *COPY DT_DHADDE
34524 *
34525 *===dhadde=============================================================*
34526 *
34527       SUBROUTINE DT_DHADDE
34528
34529       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34530       SAVE
34531
34532 * particle properties (BAMJET index convention)
34533       CHARACTER*8  ANAME
34534       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
34535      &                IICH(210),IIBAR(210),K1(210),K2(210)
34536 * HADRIN: decay channel information
34537       PARAMETER (IDMAX9=602)
34538       CHARACTER*8 ZKNAME
34539       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
34540 * particle properties (BAMJET index convention),
34541 * (dublicate of DTPART for HADRIN)
34542       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34543      &                K1H(110),K2H(110)
34544       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34545 * decay channel information for HADRIN
34546       COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
34547      &                K1Z(16),K2Z(16),WTZ(153),II22,
34548      &                NZK1(153),NZK2(153),NZK3(153)
34549
34550       DATA IRETUR/0/
34551
34552       IRETUR=IRETUR+1
34553       AMH(31)=0.48D0
34554       IF (IRETUR.GT.1) RETURN
34555       DO 10 I=1,94
34556         AMH(I)   = AAM(I)
34557         GAH(I)   = GA(I)
34558         TAUH(I)  = TAU(I)
34559         ICHH(I)  = IICH(I)
34560         IBARH(I) = IIBAR(I)
34561         K1H(I)   = K1(I)
34562         K2H(I)   = K2(I)
34563    10 CONTINUE
34564 **sr
34565 C     AMH(1)=0.93828D0
34566       AMH(1)=0.9383D0
34567 **
34568       AMH(2)=AMH(1)
34569       DO 20 I=26,30
34570         K1H(I)=452
34571         K2H(I)=452
34572    20 CONTINUE
34573       DO 30 I=1,307
34574         WTI(I)    = WT(I)
34575         NZKI(I,1) = NZK(I,1)
34576         NZKI(I,2) = NZK(I,2)
34577         NZKI(I,3) = NZK(I,3)
34578    30 CONTINUE
34579       DO 40 I=1,16
34580         L=I+94
34581         AMH(L)=AMZ(I)
34582         GAH( L)=GAZ(I)
34583         TAUH( L)=TAUZ(I)
34584         ICHH( L)=ICHZ(I)
34585         IBARH( L)=IBARZ(I)
34586         K1H( L)=K1Z(I)
34587         K2H( L)=K2Z(I)
34588    40 CONTINUE
34589       DO 50 I=1,153
34590         L=I+307
34591         WTI(L)    = WTZ(I)
34592         NZKI(L,3) = NZK3(I)
34593         NZKI(L,2) = NZK2(I)
34594         NZKI(L,1) = NZK1(I)
34595    50 CONTINUE
34596       RETURN
34597       END
34598
34599 *$ CREATE IDT_IEFUND.FOR
34600 *COPY IDT_IEFUND
34601 *
34602 *===iefund=============================================================*
34603 *
34604       INTEGER FUNCTION IDT_IEFUND(PL,IRE)
34605
34606       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34607       SAVE
34608
34609 C*****IEFUN CALCULATES A MOMENTUM INDEX
34610
34611       PARAMETER ( LINP = 10 ,
34612      &            LOUT = 6 ,
34613      &            LDAT = 9 )
34614       COMMON /HNDRUN/ RUNTES,EFTES
34615       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34616       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34617      &                NRK(2,268),NURE(30,2)
34618
34619       IPLA=IEII(IRE)+1
34620      *+1
34621       IPLE=IEII(IRE+1)
34622       IF (PL.LT.0.)                                             GO TO 30
34623       DO 10 I=IPLA,IPLE
34624         J=I-IPLA+1
34625         IF (PL.LE.PLABF(I))                                     GO TO 60
34626    10 CONTINUE
34627       I=IPLE
34628       IF ( EFTES.GT.40.D0)                                      GO TO 20
34629       EFTES=EFTES+1.0D0
34630       WRITE(LOUT,1000)PL,J
34631    20 CONTINUE
34632                                                                 GO TO 70
34633    30 CONTINUE
34634       DO 40 I=IPLA,IPLE
34635         J=I-IPLA+1
34636         IF (-PL.LE.UMO(I))                                      GO TO 60
34637    40 CONTINUE
34638       I=IPLE
34639       IF ( EFTES.GT.40.D0)                                      GO TO 50
34640       EFTES=EFTES+1.0D0
34641       WRITE(LOUT,1000)PL,I
34642    50 CONTINUE
34643    60 CONTINUE
34644    70 CONTINUE
34645       IDT_IEFUND=I
34646       RETURN
34647  1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
34648      +7H IEFUN=,I5)
34649       END
34650
34651 *$ CREATE DT_DSIGIN.FOR
34652 *COPY DT_DSIGIN
34653 *
34654 *===dsigin=============================================================*
34655 *
34656       SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
34657
34658       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34659       SAVE
34660
34661 * particle properties (BAMJET index convention),
34662 * (dublicate of DTPART for HADRIN)
34663       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34664      &                K1H(110),K2H(110)
34665       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34666       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34667      &                NRK(2,268),NURE(30,2)
34668
34669       IE=IDT_IEFUND(PLAB,IRE)
34670       IF (IE.LE.IEII(IRE)) IE=IE+1
34671       AMT=AMH(ITAR)
34672       AMN=AMH(N)
34673       AMN2=AMN*AMN
34674       AMT2=AMT*AMT
34675       ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
34676 C*** INTERPOLATION PREPARATION
34677       ECMO=UMO(IE)
34678       ECM1=UMO(IE-1)
34679       DECM=ECMO-ECM1
34680       DEC=ECMO-ECM
34681       IIKI=IKII(IRE)+1
34682       EKLIM=-THRESH(IIKI)
34683       WOK=SIIN(IE)
34684       WDK=WOK-SIIN(IE-1)
34685       IF (ECM.GT.ECMO) WDK=0.0D0
34686 C*** INTERPOLATION IN CHANNEL WEIGHTS
34687       IELIM=IDT_IEFUND(EKLIM,IRE)
34688       DELIM=UMO(IELIM)+EKLIM
34689      *+1.D-16
34690       DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
34691       IF (DELIM*DELIM-DETE*DETE) 20,20,10
34692    10 DECC=DELIM
34693                                                                 GO TO 30
34694    20 DECC=DECM
34695    30 CONTINUE
34696       WKK=WOK-WDK*DEC/(DECC+1.D-9)
34697       IF (WKK.LT.0.0D0) WKK=0.0D0
34698       SI=WKK+1.D-12
34699       IF (-EKLIM.GT.ECM) SI=1.D-14
34700       RETURN
34701       END
34702
34703 *$ CREATE DT_DTCHOI.FOR
34704 *COPY DT_DTCHOI
34705 *
34706 *===dtchoi=============================================================*
34707 *
34708       SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
34709
34710       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34711       SAVE
34712
34713 C     ****************************
34714 C     TCHOIC CALCULATES A RANDOM VALUE
34715 C     FOR THE FOUR-MOMENTUM-TRANSFER T
34716 C     ****************************
34717
34718 * particle properties (BAMJET index convention),
34719 * (dublicate of DTPART for HADRIN)
34720       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34721      &                K1H(110),K2H(110)
34722 * slope parameters for HADRIN interactions
34723       COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
34724
34725       AMA=AM1
34726       AMB=AM2
34727       IF (I.GT.30.AND.II.GT.30)                                 GO TO 20
34728       III=II
34729       AM3=AM2
34730       IF (I.LE.30)                                              GO TO 10
34731       III=I
34732       AM3=AM1
34733    10 CONTINUE
34734                                                                 GO TO 30
34735    20 CONTINUE
34736       III=II
34737       AM3=AM2
34738       IF (AMA.LE.AMB)                                           GO TO 30
34739       III=I
34740       AM3=AM1
34741    30 CONTINUE
34742       IB=IBARH(III)
34743       AMA=AM3
34744       K=INT((AMA-0.75D0)/0.05D0)
34745       IF (K-2.LT.0) K=1
34746       IF (K-26.GE.0) K=25
34747       IF (IB)50,40,50
34748    40 BM=BBM(K)
34749                                                                 GO TO 60
34750    50 BM=BBB(K)
34751    60 CONTINUE
34752 C     NORMALIZATION
34753       TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1  **2
34754       TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1  **2
34755       VB=DT_RNDM(TMIN)
34756 **sr test
34757 C     IF (VB.LT.0.2D0) BM=BM*0.1
34758 C    **0.5
34759       BM = BM*5.05D0
34760 **
34761       TMI=BM*TMIN
34762       TMA=BM*TMAX
34763       ETMA=0.D0
34764       IF (ABS(TMA).GT.120.D0)                                   GO TO 70
34765       ETMA=EXP(TMA)
34766    70 CONTINUE
34767       AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
34768 C*** RANDOM CHOICE OF THE T - VALUE
34769       R=DT_RNDM(TMI)
34770       T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
34771       RETURN
34772       END
34773
34774 *$ CREATE DT_DTWOPA.FOR
34775 *COPY DT_DTWOPA
34776 *
34777 *===dtwopa=============================================================*
34778 *
34779       SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
34780      &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
34781
34782       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34783       SAVE
34784
34785 C     ******************************************************
34786 C     QUASI TWO PARTICLE PRODUCTION
34787 C     TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
34788 C     FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
34789 C     IN THE CM - SYSTEM
34790 C     COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
34791 C     SPHERICAL COORDINATES
34792 C     ******************************************************
34793
34794 * particle properties (BAMJET index convention),
34795 * (dublicate of DTPART for HADRIN)
34796       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34797      &                K1H(110),K2H(110)
34798
34799       AMA=AM1
34800       AMB=AM2
34801       AMA2=AMA*AMA
34802       E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
34803       E2=UMOO - E1
34804       IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
34805       AMTE=(E1-AMA)*(E1+AMA)
34806       AMTE=AMTE+1.D-18
34807       P1=SQRT(AMTE)
34808       P2=P1
34809 C     / P2 / = / P1 /  BUT OPPOSITE DIRECTIONS
34810 C     DETERMINATION  OF  THE ANGLES
34811 C     COS(THETA1)=COD1      COS(THETA2)=COD2
34812 C     SIN(PHI1)=SIF1        SIN(PHI2)=SIF2
34813 C     COS(PHI1)=COF1        COS(PHI2)=COF2
34814 C     PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
34815       CALL DT_DSFECF(COF1,SIF1)
34816       COF2=-COF1
34817       SIF2=-SIF1
34818 C     CALCULATION OF THETA1
34819       CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
34820       COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
34821       IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
34822       COD2=-COD1
34823       RETURN
34824       END
34825
34826 *$ CREATE DT_ZK.FOR
34827 *COPY DT_ZK
34828 *
34829 *===zk=================================================================*
34830 *
34831       BLOCK DATA DT_ZK
34832
34833       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34834       SAVE
34835
34836 * decay channel information for HADRIN
34837       COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
34838      &                K1Z(16),K2Z(16),WTZ(153),II22,
34839      &                NZK1(153),NZK2(153),NZK3(153)
34840 * decay channel information for HADRIN
34841       CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
34842       COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
34843
34844 *     Particle masses in GeV                                           *
34845       DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
34846      &          2*1.7D0, 3*0.D0/
34847 *     Resonance width Gamma in GeV                                     *
34848       DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
34849 *     Mean life time in seconds                                        *
34850       DATA TAUZ / 16*0.D0 /
34851 *     Charge of particles and resonances                               *
34852       DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
34853 *     Baryonic charge                                                  *
34854       DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
34855 *     First number of decay channels used for resonances               *
34856 *     and decaying particles                                           *
34857       DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
34858      &          3*460/
34859 *     Last number of decay channels used for resonances                *
34860 *     and decaying particles                                           *
34861       DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
34862      &          3*460/
34863 *     Weight of decay channel                                          *
34864       DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
34865      & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
34866      & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
34867      & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
34868      & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
34869      & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
34870      & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
34871      & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
34872      & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
34873      & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
34874      & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
34875      & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
34876      & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
34877      & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
34878      & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
34879      & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
34880      & .05D0, .65D0, 9*1.D0 /
34881 *     Particle numbers in decay channel                                *
34882       DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
34883      & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
34884      & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
34885      & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
34886      & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
34887      & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
34888      & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
34889      & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
34890       DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
34891      & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
34892      & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
34893      & 4*33, 32, 3*35,  2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
34894      & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
34895      & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
34896      & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
34897      & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
34898      & 1, 8, 1, 8, 1, 9*0 /
34899       DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
34900      & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
34901      & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
34902      & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
34903      & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
34904      & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
34905 *     Particle  names                                                  *
34906       DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS  ',' PAP  ',' PAN  ',
34907      & 'APN', 'DEO   ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
34908      & 3*'BLANK' /
34909 *     Name of decay channel                                            *
34910       DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
34911      & 'ANNPI0','APPPI0','ANPPI-'/
34912       DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K-  ','K0AK0 ',
34913      & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET  ','&0R0  ','P-R+  ',
34914      & 'P+R-  ','POOM  ',' ETET ','ETSP0 ','R0ET  ',' R0R0 ','R+R-  ',
34915      & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
34916      & 'P+R-R0','R0OM  ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
34917      & 'P+R-OM','OMOM  ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
34918      & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
34919      & 'OMOMOM',
34920      & ' P+PO ','P+POPO','P+P+P-','P+ET  ','P0R+  ','P+R0  ','ETSP+ ',
34921      & 'R+ET  ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
34922      & 'P+R-R+','R+OM  ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
34923      & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
34924      & 'P-PO  ','P-POPO','P-P-P+','P-ET  ','POR-  ','P-R0  ','ETSP- ',
34925      & 'R-ET  ','R-R0  ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
34926       DATA ZKNAM6/'P+R-R-','R-OM  ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
34927      & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
34928      & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO  ','LPI+  ',
34929      & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
34930      & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
34931      & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
34932      & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
34933      & 9*'BLANK'/
34934 *=                                               end*block.zk      *
34935       END
34936
34937 *$ CREATE DT_BLKD43.FOR
34938 *COPY DT_BLKD43
34939 *
34940 *===blkd43=============================================================*
34941 *
34942       BLOCK DATA DT_BLKD43
34943
34944       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34945       SAVE
34946
34947 *
34948 *=== reac =============================================================*
34949 *
34950 *----------------------------------------------------------------------*
34951 *                                                                      *
34952 *     Created on 10 december 1991  by    Alfredo Ferrari & Paola Sala  *
34953 *                                                   Infn - Milan       *
34954 *                                                                      *
34955 *     Last change on 10-dec-91     by    Alfredo Ferrari               *
34956 *                                                                      *
34957 *     This is the original common reac of Hadrin                       *
34958 *                                                                      *
34959 *----------------------------------------------------------------------*
34960 *
34961       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34962      &                NRK(2,268),NURE(30,2)
34963
34964       DIMENSION
34965      & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
34966      & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
34967      & SPIKP1(315), SPIKPU(278), SPIKPV(372),
34968      & SPIKPW(278), SPIKPX(372), SPIKP4(315),
34969      & SPIKP5(187), SPIKP6(289),
34970      & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
34971      & SPIKP9(143), SPIKP0(169), SPKPV(143),
34972      & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
34973      & SANPEL(84) , SPIKPF(273),
34974      & SPKP15(187), SPKP16(272),
34975      & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
34976      & NURELN(60)
34977 *
34978        DIMENSION NRKLIN(532)
34979        EQUIVALENCE (NRK(1,1), NRKLIN(1))
34980        EQUIVALENCE (   UMO(  1),  UMOPI(1)), (   UMO( 93),  UMOKC(1))
34981        EQUIVALENCE (   UMO(161),   UMOP(1)), (   UMO(200),   UMON(1))
34982        EQUIVALENCE (   UMO(263),  UMOK0(1))
34983        EQUIVALENCE ( PLABF(  1),  PLAPI(1)), ( PLABF( 93),  PLAKC(1))
34984        EQUIVALENCE ( PLABF(161),   PLAP(1)), ( PLABF(200),   PLAN(1))
34985        EQUIVALENCE ( PLABF(263),  PLAK0(1))
34986        EQUIVALENCE (   WK(   1), SPIKP1(1)), (   WK( 316), SPIKPU(1))
34987        EQUIVALENCE (   WK( 594), SPIKPV(1)), (   WK( 966), SPIKPW(1))
34988        EQUIVALENCE (   WK(1244), SPIKPX(1)), (   WK(1616), SPIKP4(1))
34989        EQUIVALENCE (   WK(1931), SPIKP5(1)), (   WK(2118), SPIKP6(1))
34990        EQUIVALENCE (   WK(2407), SKMPEL(1)), (   WK(2509), SPIKP7(1))
34991        EQUIVALENCE (   WK(2798), SKMNEL(1)), (   WK(2866), SPIKP8(1))
34992        EQUIVALENCE (   WK(3053), SPIKP9(1)), (   WK(3196), SPIKP0(1))
34993        EQUIVALENCE (   WK(3365),  SPKPV(1)), (   WK(3508), SAPPEL(1))
34994        EQUIVALENCE (   WK(3613), SPIKPE(1)), (   WK(4012), SAPNEL(1))
34995        EQUIVALENCE (   WK(4096), SPIKPZ(1)), (   WK(4369), SANPEL(1))
34996        EQUIVALENCE (   WK(4453), SPIKPF(1)), (   WK(4726), SPKP15(1))
34997        EQUIVALENCE (   WK(4913), SPKP16(1))
34998        EQUIVALENCE (NRK(1,1), NRKLIN(1))
34999        EQUIVALENCE (NRKLIN(   1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
35000        EQUIVALENCE (NRKLIN( 297),  NRKP(1)), (NRKLIN( 367),  NRKN(1))
35001        EQUIVALENCE (NRKLIN( 483), NRKK0(1))
35002        EQUIVALENCE (NURE(1,1), NURELN(1))
35003 *
35004 **** pi- p data                                                        *
35005 **** pi+ n data                                                        *
35006       DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
35007      & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
35008      & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
35009      & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
35010      & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
35011      & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
35012      & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
35013      & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
35014      & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
35015      & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
35016       DATA PLAKC /
35017      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35018      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35019      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35020      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35021      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35022      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35023      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35024      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35025      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35026      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35027      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35028      & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
35029       DATA PLAK0 /
35030      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35031      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35032      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
35033      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
35034      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
35035      & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
35036 *                 pp   pn   np   nn                                    *
35037       DATA PLAP /
35038      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35039      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35040      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35041      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35042      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35043      & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
35044 *    app   apn   anp   ann                                             *
35045       DATA PLAN /
35046      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
35047      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35048      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35049      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
35050      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35051      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35052      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
35053      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35054      & 3.43D0, 3.75D0, 4.07D0, 4.43D0  /
35055       DATA SIIN / 296*0.D0 /
35056       DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
35057      & 1.557D0,1.615D0,1.6435D0,
35058      & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
35059      & 2.286D0,2.366D0,2.482D0,2.56D0,
35060      & 2.735D0,2.90D0,
35061      &             1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
35062      & 1.496D0,1.527D0,1.557D0,
35063      & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
35064      & 2.071D0,2.159D0,2.286D0,2.366D0,
35065      & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
35066      &             1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
35067      & 1.496D0,1.527D0,1.557D0,
35068      & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
35069      & 2.071D0,2.159D0,2.286D0,2.366D0,
35070      & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
35071      &                   1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
35072      & 1.557D0,1.615D0,1.6435D0,
35073      & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
35074      & 2.286D0,2.366D0,2.482D0,2.56D0,
35075      &  2.735D0, 2.90D0/
35076       DATA UMOKC/ 1.44D0,
35077      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35078      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35079      & 3.1D0,1.44D0,
35080      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35081      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35082      & 3.1D0,1.44D0,
35083      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35084      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35085      & 3.1D0,1.44D0,
35086      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35087      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35088      &  3.1D0/
35089       DATA UMOK0/ 1.44D0,
35090      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35091      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35092      & 3.1D0,1.44D0,
35093      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35094      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35095      &  3.1D0/
35096 *                 pp   pn   np   nn                                    *
35097       DATA UMOP/
35098      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35099      & 3.D0,3.1D0,3.2D0,
35100      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35101      & 3.D0,3.1D0,3.2D0,
35102      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35103      & 3.D0,3.1D0,3.2D0/
35104 *    app   apn   anp   ann                                             *
35105       DATA UMON /
35106      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35107      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35108      & 3.D0,3.1D0,3.2D0,
35109      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35110      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35111      & 3.D0,3.1D0,3.2D0,
35112      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35113      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35114      &  3.D0,3.1D0,3.2D0/
35115 **** reaction channel state particles                                  *
35116       DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
35117      & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
35118      & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
35119      & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
35120      & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
35121      & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
35122      & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
35123      & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
35124      & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
35125      & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
35126       DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
35127      & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
35128      & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
35129      & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
35130      & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
35131      & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
35132      & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
35133      & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
35134 *                                                                      *
35135 *   k0 p   k0 n   ak0 p   ak/ n                                        *
35136 *                                                                      *
35137       DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
35138      & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13,   22, 13, 21, 23,
35139      & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
35140      & 53, 47, 1, 103, 0, 93, 0/
35141 *   pp  pn   np   nn                                                   *
35142       DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
35143      & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
35144      & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
35145      & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
35146 *     app   apn   anp   ann                                            *
35147       DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
35148      & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
35149      & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
35150      & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
35151      & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
35152      & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
35153      & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
35154 **** channel cross section                                             *
35155       DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
35156      & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
35157      & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
35158      & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
35159      & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
35160      &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
35161      & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
35162      & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
35163      &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
35164      & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
35165      & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
35166      & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
35167      & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
35168      & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
35169      & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
35170      & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
35171      & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
35172      & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
35173      & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
35174      & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
35175 **** pi+ n data                                                        *
35176       DATA SPIKPU/   0.D0, 25.D0, 13.D0,  11.D0, 10.5D0, 14.D0,  20.D0,
35177      & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
35178      & 10.D0, 10.D0, 9.5D0,  9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
35179      & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0,   5.5D0,  4.8D0,
35180      & 4.2D0, 7.5D0, 3.4D0,  2.5D0, 2.5D0, 2.1D0, 1.4D0,   1.D0,   .8D0,
35181      &  .6D0, .46D0,  .3D0, .2D0, .15D0, .13D0, 11*0.D0,  .95D0,  .65D0,
35182      & .48D0, .35D0,  .2D0, .18D0, .17D0, .16D0,  .15D0,   .1D0,  .09D0,
35183      & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0,  .2D0,   .1D0,
35184      & .08D0, .06D0, .045D0,   .03D0, .02D0, .01D0,      .005D0, .003D0,
35185      & 12*0.D0, .3D0, .24D0,   .18D0, .15D0, .13D0,  .12D0, .11D0, .1D0,
35186      & .09D0,  .08D0, .05D0,   .04D0, .03D0,  0.D0, 0.16D0, .7D0, 1.3D0,
35187      & 3.1D0,  4.5D0,  2.D0, 18*0.D0, 3*.0D0,  0.D0, 0.D0, 4.0D0, 11.D0,
35188      & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0,  1.5D0, .9D0, .55D0,
35189      &  .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0,   2.25D0, 3.3D0,
35190      & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
35191      & .64D0,  1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0,  4.4D0,   3.D0, 1.8D0,
35192      &  .9D0, .53D0, .28D0,      10*0.D0, 2*0.D0,  .25D0,  .82D0,
35193      & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0,  5.7D0, 3.9D0, 2.35D0, 1.15D0,
35194      & .69D0, .37D0, 10*0.D0,     7*0.D0,   .0D0, .34D0,  1.5D0, 3.47D0,
35195      & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0,  .3D0,  .15D0, 6*0.D0/
35196 *
35197       DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
35198      & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
35199      & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
35200      & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
35201      & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
35202      & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
35203      & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
35204      & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
35205      & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
35206      & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
35207      & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
35208      & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
35209      & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
35210      & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
35211      & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
35212      & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
35213      & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
35214      & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
35215      & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
35216      & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
35217 **** pi- p data                                                        *
35218       DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
35219      & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
35220      & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
35221      & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
35222      & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
35223      & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
35224      & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
35225      & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
35226      & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
35227      & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
35228      & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
35229      & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
35230      & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
35231      & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
35232      & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
35233      & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
35234      & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
35235      & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
35236      & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
35237 *
35238       DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
35239      & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
35240      & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
35241      & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
35242      & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
35243      & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
35244      & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
35245      & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
35246      & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
35247      & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
35248      & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
35249      & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
35250      & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
35251      & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
35252      & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
35253      & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
35254      & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
35255      & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
35256      & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
35257      & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
35258 **** pi- n data                                                        *
35259       DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
35260      & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
35261      & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
35262      & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
35263      & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
35264      & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
35265      & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
35266      & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
35267      & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
35268      & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
35269      & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
35270      & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
35271      & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
35272      & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
35273      & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
35274      & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
35275      & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
35276      & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
35277      & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
35278      & 3.3D0, 5.4D0, 7.D0 /
35279 **** k+  p data                                                        *
35280       DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
35281      & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
35282      & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
35283      & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
35284      & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
35285      & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35286      & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
35287      & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
35288      & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
35289      & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
35290      & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0,
35291      & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0,
35292      & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
35293 **** k+  n data                                                        *
35294       DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
35295      & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
35296      & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
35297      & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
35298      & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
35299      & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
35300      & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
35301      & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
35302      & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
35303      & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
35304      & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
35305      & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
35306      & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
35307      & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
35308      & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
35309      & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
35310      & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
35311      & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
35312      & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
35313 **** k-  p data                                                        *
35314       DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
35315      &     7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
35316      &    0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
35317      &    .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
35318      &    0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
35319      &    .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
35320      &    0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
35321      &    .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
35322      &    0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
35323      &    .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
35324      &    0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
35325      &    .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
35326       DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
35327      & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
35328      & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
35329      & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
35330      & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,  3*0.D0, 1.0D0, 3.03D0,
35331      & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
35332      & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
35333      & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
35334      & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
35335      & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
35336      & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
35337      & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
35338      & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
35339      & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
35340      & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
35341      & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
35342      & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
35343      & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
35344      & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
35345      & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
35346      & 10*0.D0/
35347 ***** k- n data                                                        *
35348       DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
35349      &        3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
35350      &        0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
35351      &        1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
35352      &        0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
35353      &        .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
35354      &        0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
35355      &       .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
35356       DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
35357      &  14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
35358      &  1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
35359      &  3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
35360      &  1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
35361      &  3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
35362      &  1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
35363      &  7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
35364      &  .39D0, .22D0, .07D0, 0.D0,
35365      &  6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
35366      &  4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
35367      &  10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
35368      &  13*0.D0, .1D0, .3D0, .7D0, 1.D0,
35369      &  13*0.D0, .1D0, .3D0, .7D0, 1.D0,
35370      &  9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
35371      &  5.10D0, 5.44D0, 5.3D0,
35372      &  4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
35373 *****  p p data                                                        *
35374       DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35375      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35376      &              0.D0, 3.6D0, 1.7D0, 10*0.D0,
35377      &              .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
35378      &              11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
35379      &              .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
35380      &              2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
35381      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35382      &              16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
35383      &              10*0.D0, 4.3D0, 7.6D0, 9.D0,
35384      &              10*0.D0, 1.7D0, 2.6D0, 3.D0,
35385      &              6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
35386      &              6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
35387      &              1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
35388      &              10*0.D0, 1.9D0, 4.1D0, 5.2D0/
35389 *****  p n data                                                        *
35390       DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35391      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35392      &              0.D0, 1.8D0, .2D0,  12*0.D0,
35393      &              3.2D0, 6.05D0, 9.9D0, 5.1D0,
35394      &              3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
35395      &              2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
35396      &              3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
35397      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35398      &              16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
35399      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35400      &              16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
35401      &              10*0.D0, .7D0, 5.1D0, 8.D0,
35402      &              10*0.D0, .7D0, 5.1D0, 8.D0,
35403      &              10*.0D0, .3D0, 2.8D0, 4.7D0,
35404      &              10*.0D0, .3D0, 2.8D0, 4.7D0,
35405      &              7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
35406      &              7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
35407      &              5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
35408 *   nn - data                                                          *
35409 *                                                                      *
35410       DATA SPKPV/  0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35411      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35412      &              0.D0, 3.6D0, 1.7D0, 12*0.D0,
35413      &              8.7D0, 17.7D0, 18.8D0, 15.9D0,
35414      &              11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
35415      &              .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
35416      &              2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
35417      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
35418      &              11.D0, 5.5D0, 3.5D0,
35419      &              10*0.D0, 4.3D0, 7.6D0, 9.D0,
35420      &              10*0.D0, 1.7D0, 2.6D0, 3.D0,
35421      &              6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
35422      &              6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
35423      &              1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
35424      &              10*0.D0, 1.9D0, 4.1D0, 5.2D0/
35425 ****************   ap - p - data                                       *
35426       DATA SAPPEL/ 0.D0,  176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
35427      &  50.D0,  50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
35428      &  25.D0,  22.D0, 21.D0, 20.D0, 18.D0, 17.D0,  11*0.D0,
35429      &  .05D0,  .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
35430      &  0.D0,  1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
35431      &  .1D0,  .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
35432      &  0.D0,  55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
35433      &  10.D0,  7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
35434      &  1.55D0,  1.3D0, .95D0, .75D0,
35435      &  0.D0,  3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
35436      &  .25D0,  .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35437      & .01D0,  .008D0, .006D0, .005D0/
35438       DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35439      & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35440      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
35441      & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
35442      & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
35443      & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
35444      & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
35445      & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
35446      & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
35447      & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0,
35448      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35449      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35450      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35451      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
35452      & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
35453      & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
35454      & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
35455      & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
35456      & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
35457      & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
35458 ****************   ap - n - data                                       *
35459       DATA SAPNEL/
35460      & 0.D0,  176.D0, 160.D0, 105.D0, 75.D0,  68.D0, 65.D0,
35461      & 50.D0, 50.D0,  43.D0,  42.D0,  40.5D0, 35.D0, 30.D0,  28.D0,
35462      & 25.D0, 22.D0,  21.D0,  20.D0,  18.D0,  17.D0, 11*0.D0,
35463      & .05D0, .15D0, .18D0,  .2D0,    .2D0,  .3D0,  .4D0,   .6D0,  .7D0,
35464      & .85D0,  0.D0,  1.D0,  .9D0,    .46D0, .3D0,  .23D0, .18D0, .16D0,
35465      & .14D0,  .1D0, .08D0, .05D0,    .02D0, .015D0, 4*.011D0, 3*.005D0,
35466      & 0.D0,  3.3D0,  3.D0, 1.5D0,     1.D0, .7D0,  .4D0,  .35D0, .4D0,
35467      & .25D0, .18D0, .08D0, .04D0,    .03D0, .023D0, .016D0, .014D0,
35468      & .01D0, .008D0, .006D0, .005D0 /
35469        DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35470      &  84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35471      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
35472      & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35473      & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
35474      & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
35475      & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
35476      & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35477      & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35478      & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35479      & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
35480      & 4.9D0, 8.5D0,  15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
35481      & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
35482      & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
35483 *                                                                      *
35484 *                                                                      *
35485 ****************   an - p - data                                       *
35486 *                                                                      *
35487       DATA SANPEL/
35488      & 0.D0,  176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
35489      & 50.D0, 43.D0,  42.D0,  40.5D0, 35.D0, 30.D0, 28.D0,
35490      & 25.D0, 22.D0,  21.D0,  20.D0,  18.D0, 17.D0, 11*0.D0, .05D0,
35491      & .15D0, .18D0,   .2D0,   .2D0,   .3D0,  .4D0, .6D0,   .7D0, .85D0,
35492      & 0.D0,   1.D0,   .9D0,  .46D0,  .3D0,  .23D0, .18D0, .16D0, .14D0,
35493      & .1D0,  .08D0,  .05D0,  .02D0, .015D0, 4*.011D0, 3*.005D0,
35494      & 0.D0,  3.3D0,  3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
35495      & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35496      & .01D0, .008D0, .006D0, .005D0 /
35497       DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35498      & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35499      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
35500      & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35501      & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
35502      & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
35503      & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
35504      & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35505      & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35506      & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35507      & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
35508      & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
35509      & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
35510      & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
35511 ****  ko - n - data                                                    *
35512       DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
35513      &      6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
35514      &      0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
35515      &    3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
35516      &     1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35517      &    3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
35518      &     1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35519      &    4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
35520      &     1.4D0, 1.2D0, 1.05D0, .9D0, .66D0,  .5D0,
35521      &    7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
35522      &   11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
35523      &    4.85D0, 4.9D0,
35524      &   10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
35525      &    6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
35526      &    2.85D0, 2.35D0, 2.01D0, 1.8D0,
35527      &   12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
35528      &   12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0  /
35529 **** ako - p - data                                                    *
35530       DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
35531      & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
35532      & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
35533      & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
35534      & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
35535      & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
35536      & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
35537      & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
35538      & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
35539      & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
35540      & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
35541      & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
35542      & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
35543      & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
35544      & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
35545      & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
35546      & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
35547      & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
35548      & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
35549      & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
35550      & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
35551       DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
35552      & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
35553 *=                                               end*block.blkdt3      *
35554       END
35555
35556 *$ CREATE DT_QEL_POL.FOR
35557 *COPY DT_QEL_POL
35558 *
35559 *===qel_pol============================================================*
35560 *
35561       SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
35562
35563       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35564       SAVE
35565
35566       CALL DT_MASS_INI
35567       CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
35568
35569       RETURN
35570       END
35571
35572 *$ CREATE DT_GEN_QEL.FOR
35573 *COPY DT_GEN_QEL
35574 C==================================================================
35575 C   Generation of  a Quasi-Elastic neutrino scattering
35576 C==================================================================
35577 *
35578 *===gen_qel============================================================*
35579 *
35580       SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
35581
35582 C...Generate a quasi-elastic   neutrino/antineutrino
35583 C.  Interaction on a nuclear target
35584 C.  INPUT  : LTYP = neutrino type (1,...,6)
35585 C.           ENU (GeV) = neutrino energy
35586 C----------------------------------------------------
35587
35588       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35589       SAVE
35590
35591       PARAMETER ( LINP = 10 ,
35592      &            LOUT = 6 ,
35593      &            LDAT = 9 )
35594       PARAMETER (MAXLND=4000)
35595       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
35596 * nuclear potential
35597       LOGICAL LFERMI
35598       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
35599      &                EBINDP(2),EBINDN(2),EPOT(2,210),
35600      &                ETACOU(2),ICOUL,LFERMI
35601 * steering flags for qel neutrino scattering modules
35602       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
35603 **sr - removed (not needed)
35604 C     COMMON /CBAD/  LBAD, NBAD
35605 C     COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
35606 **
35607
35608       DIMENSION PI(3),PO(3)
35609 CJR+
35610       DATA ININU/0/
35611 CJR-
35612 C     REAL*8 DBETA(3)
35613 C     REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
35614       DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
35615       DATA AMN  /0.93827231D0, 0.93956563D0/
35616       DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
35617       DATA INIPRI/0/
35618
35619 C     DATA PFERMI/0.22D0/
35620 CGB+...Binding Energy
35621       DATA EBIND/0.008D0/
35622 CGB-...
35623
35624       ININU=ININU+1
35625       IF(ININU.EQ.1)NDSIG=0
35626       LBAD = 0
35627       enu0=enu
35628 c      write(*,*) enu0
35629 C...Lepton mass
35630       AML = AML0(LTYP)       !  massa leptoni
35631       AML2 = AML**2          !  massa leptoni **2
35632 C...Particle labels (LUND)
35633       N = 5
35634       K(1,1) = 21
35635       K(2,1) = 21
35636       K(3,1) = 21
35637       K(3,3) = 1
35638       K(4,1) = 1
35639       K(4,3) = 1
35640       K(5,1) = 1
35641       K(5,3) = 2
35642       K0 = (LTYP-1)/2          !  2
35643       K1 = LTYP/2              !  2
35644       KA = 12 + 2*K0           !  16
35645       IS = -1 + 2*LTYP - 4*K1  !  -1 +10 -8 = 1
35646       K(1,2) = IS*KA
35647       K(4,2) = IS*(KA-1)
35648       K(3,2) = IS*24
35649       LNU = 2 - LTYP + 2*K1    !  2 - 5 + 2 = - 1
35650       IF (LNU .EQ. 2)  THEN
35651         K(2,2) = 2212
35652         K(5,2) = 2112
35653         AMI = AMN(1)
35654         AMF = AMN(2)
35655 CJR+
35656         PFERMI=PFERMN(2)
35657 CJR-
35658       ELSE
35659         K(2,2) = 2112
35660         K(5,2) = 2212
35661         AMI = AMN(2)
35662         AMF = AMN(1)
35663 CJR+
35664         PFERMI=PFERMP(2)
35665 CJR-
35666       ENDIF
35667       AMI2 = AMI**2
35668       AMF2 = AMF**2
35669
35670       DO IGB=1,5
35671         P(3,IGB) = 0.
35672         P(4,IGB) = 0.
35673         P(5,IGB) = 0.
35674       END DO
35675
35676       NTRY = 0
35677 CGB+...
35678       EFMAX  = SQRT(PFERMI**2 + AMI2) -AMI             ! max. Fermi Energy
35679       ENWELL = EFMAX + EBIND ! depth of nuclear potential well
35680 CGB-...
35681
35682   100 CONTINUE
35683
35684 C...4-momentum initial lepton
35685       P(1,5) = 0.     ! massa
35686       P(1,4) = ENU0    ! energia
35687       P(1,1) = 0.     ! px
35688       P(1,2) = 0.     ! py
35689       P(1,3) = ENU0    ! pz
35690
35691 C     PF = PFERMI*PYR(0)**(1./3.)
35692 c       write(23,*) PYR(0)
35693 c      write(*,*) 'Pfermi=',PF
35694 c      PF = 0.
35695       NTRY=NTRY+1
35696 C     IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
35697       IF (NTRY .GT. 500)  THEN
35698         LBAD = 1
35699         WRITE (LOUT,1001)  NBAD, ENU
35700         RETURN
35701       ENDIF
35702 C     CT = -1. + 2.*PYR(0)
35703 c      CT = -1.
35704 C     ST =  SQRT(1.-CT*CT)
35705 C     F = 2.*3.1415926*PYR(0)
35706 c      F = 0.
35707
35708 C     P(2,4) = SQRT(PF*PF + MI2) - EBIND  ! energia
35709 C     P(2,1) = PF*ST*COS(F)               ! px
35710 C     P(2,2) = PF*ST*SIN(F)               ! py
35711 C     P(2,3) = PF*CT                      ! pz
35712 C     P(2,5) = SQRT(P(2,4)**2-PF*PF)      ! massa
35713        P(2,1) = P21
35714        P(2,2) = P22
35715        P(2,3) = P23
35716        P(2,4) = P24
35717        P(2,5) = P25
35718       beta1=-p(2,1)/p(2,4)
35719       beta2=-p(2,2)/p(2,4)
35720       beta3=-p(2,3)/p(2,4)
35721       N=2
35722 C      WRITE(6,*)' before transforming into target rest frame'
35723       CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
35724 C      print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
35725       N=5
35726
35727       phi11=atan(p(1,2)/p(1,3))
35728       pi(1)=p(1,1)
35729       pi(2)=p(1,2)
35730       pi(3)=p(1,3)
35731
35732       CALL DT_TESTROT(PI,Po,PHI11,1)
35733       DO ll=1,3
35734         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35735       END DO
35736 c        WRITE(*,*) po
35737       p(1,1)=po(1)
35738       p(1,2)=po(2)
35739       p(1,3)=po(3)
35740       phi12=atan(p(1,1)/p(1,3))
35741
35742       pi(1)=p(1,1)
35743       pi(2)=p(1,2)
35744       pi(3)=p(1,3)
35745       CALL DT_TESTROT(Pi,Po,PHI12,2)
35746       DO ll=1,3
35747         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35748       END DO
35749 c        WRITE(*,*) po
35750       p(1,1)=po(1)
35751       p(1,2)=po(2)
35752       p(1,3)=po(3)
35753
35754       enu=p(1,4)
35755
35756 C...Kinematical limits in Q**2
35757 c      S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) !            ????
35758       S = P(2,5)**2 + 2.*ENU*P(2,5)
35759       SQS = SQRT(S)                          ! E centro massa
35760       IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
35761       ELF = (S-AMF2+AML2)/(2.*SQS)           ! energia leptone finale p
35762       PSTAR = (S-P(2,5)**2)/(2.*SQS)       ! p* neutrino nel c.m.
35763       PLF = SQRT(ELF**2-AML2)               ! 3-momento leptone finale
35764       Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)    ! + o -
35765       Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)    ! according con cos(theta)
35766       IF (Q2MIN .LT. 0.)   Q2MIN = 0.      ! ??? non fisico
35767
35768 C...Generate Q**2
35769       DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
35770   200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
35771       DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
35772       IF (DSIG .LT.  DSIGMAX*PYR(0)) GOTO 200
35773       CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
35774       NDSIG=NDSIG+1
35775 C     WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
35776 C    &Q2,Q2min,Q2MAX,DSIGEV
35777
35778 C...c.m. frame. Neutrino along z axis
35779       DETOT = (P(1,4)) + (P(2,4)) ! e totale
35780       DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
35781       DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
35782       DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
35783 c      WRITE(*,*)
35784 c      WRITE(*,*)
35785 C      WRITE(*,*) 'Input values laboratory frame'
35786       N=2
35787
35788       CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
35789
35790       N=5
35791 c      STHETA = ULANGL(P(1,3),P(1,1))
35792 c      write(*,*) 'stheta' ,stheta
35793 c      stheta=0.
35794 c      CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
35795 c      WRITE(*,*)
35796 c      WRITE(*,*)
35797 C      WRITE(*,*) 'Output values cm frame'
35798 C...Kinematic in c.m. frame
35799       CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
35800       STSTAR = SQRT(1.-CTSTAR**2)
35801       PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
35802       P(4,5) = AML                  ! massa leptone
35803       P(4,4) = ELF                 ! e leptone
35804       P(4,3) = PLF*CTSTAR          ! px
35805       P(4,1) = PLF*STSTAR*COS(PHI) ! py
35806       P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
35807
35808       P(5,5) = AMF                  ! barione
35809       P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
35810       P(5,3) = -P(4,3)             ! px
35811       P(5,1) = -P(4,1)             ! py
35812       P(5,2) = -P(4,2)             ! pz
35813
35814       P(3,5) = -Q2
35815       P(3,1) = P(1,1)-P(4,1)
35816       P(3,2) = P(1,2)-P(4,2)
35817       P(3,3) = P(1,3)-P(4,3)
35818       P(3,4) = P(1,4)-P(4,4)
35819
35820 C...Transform back to laboratory  frame
35821 C      WRITE(*,*) 'before going back to nucl rest frame'
35822 c      CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
35823       N=5
35824
35825       CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
35826
35827 C      WRITE(*,*) 'Now back in nucl rest frame'
35828       IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
35829
35830 c********************************************
35831
35832       DO kw=1,5
35833         pi(1)=p(kw,1)
35834         pi(2)=p(kw,2)
35835         pi(3)=p(kw,3)
35836         CALL DT_TESTROT(Pi,Po,PHI12,3)
35837         DO ll=1,3
35838           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35839         END DO
35840         p(kw,1)=po(1)
35841         p(kw,2)=po(2)
35842         p(kw,3)=po(3)
35843       END DO
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,PHI11,4)
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
35859 c********************************************
35860
35861 C      WRITE(*,*) 'Now back in lab frame'
35862
35863       CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
35864
35865 CGB+...
35866 C...test (on final momentum of nucleon) if Fermi-blocking
35867 C...is operating
35868       ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
35869      &  - P(5,5)
35870       IF (ENUCL.LT. EFMAX) THEN
35871         IF(INIPRI.LT.10)THEN
35872           INIPRI=INIPRI+1
35873 C         WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
35874 C...the interaction is not possible due to Pauli-Blocking and
35875 C...it must be resampled
35876         ENDIF
35877         GOTO 100
35878       ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
35879         IF(INIPRI.LT.10)THEN
35880           INIPRI=INIPRI+1
35881 C     WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
35882         ENDIF
35883 C                      Reject (J:R) here all these events
35884 C                      are otherwise rejected in dpmjet
35885         GOTO 100
35886 C...the interaction is possible, but the nucleon remains inside
35887 C...the nucleus. The nucleus is therefore left excited.
35888 C...We treat this case as a nucleon with 0 kinetic energy.
35889 C       P(5,5) = AMF
35890 C       P(5,4) = AMF
35891 C       P(5,1) = 0.
35892 C       P(5,2) = 0.
35893 C       P(5,3) = 0.
35894       ELSE IF (ENUCL.GE.ENWELL) THEN
35895 C     WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
35896 C...the interaction is possible, the nucleon can exit the nucleus
35897 C...but the nuclear well depth must be subtracted. The nucleus could be
35898 C...left in an excited state.
35899         Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
35900 C       P(5,4) = ENUCL-ENWELL + AMF
35901         Pnucl = SQRT(P(5,4)**2-AMF**2)
35902 C...The 3-momentum is scaled assuming that the direction remains
35903 C...unaffected
35904         P(5,1) = P(5,1) * Pnucl/Pstart
35905         P(5,2) = P(5,2) * Pnucl/Pstart
35906         P(5,3) = P(5,3) * Pnucl/Pstart
35907 C     WRITE(6,*)' qel new P(5,4) ',P(5,4)
35908       ENDIF
35909 CGB-...
35910       DSIGSU=DSIGSU+DSIGEV
35911
35912          GA=P(4,4)/P(4,5)
35913          BGX=P(4,1)/P(4,5)
35914          BGY=P(4,2)/P(4,5)
35915          BGZ=P(4,3)/P(4,5)
35916 *
35917          DBETB(1)=BGX/GA
35918          DBETB(2)=BGY/GA
35919          DBETB(3)=BGZ/GA
35920          IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
35921
35922             CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
35923
35924          ENDIF
35925 c
35926 C      PRINT*,' FINE   EVENTO '
35927       enu=enu0
35928       RETURN
35929
35930  1001 FORMAT(2X, 'DT_GEN_QEL   : event rejected ', I5,  G10.3)
35931       END
35932
35933 *$ CREATE DT_MASS_INI.FOR
35934 *COPY DT_MASS_INI
35935 C====================================================================
35936 C.  Masses
35937 C====================================================================
35938 *
35939 *===mass_ini===========================================================*
35940 *
35941       SUBROUTINE DT_MASS_INI
35942 C...Initialize  the kinematics for the quasi-elastic cross section
35943
35944       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35945       SAVE
35946
35947 * particle masses used in qel neutrino scattering modules
35948       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
35949      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
35950      &                EMPROTSQ,EMNEUTSQ,EMNSQ
35951
35952       EML(1) = 0.51100D-03   ! e-
35953       EML(2) = EML(1)        ! e+
35954       EML(3) = 0.105659D0      ! mu-
35955       EML(4) = EML(3)        ! mu+
35956       EML(5) = 1.7777D0        ! tau-
35957       EML(6) = EML(5)        ! tau+
35958       EMPROT = 0.93827231D0    ! p
35959       EMNEUT = 0.93956563D0    ! n
35960       EMPROTSQ = EMPROT**2
35961       EMNEUTSQ = EMNEUT**2
35962       EMN = (EMPROT + EMNEUT)/2.
35963       EMNSQ = EMN**2
35964       DO J=1,3
35965         J0 = 2*(J-1)
35966         EMN1(J0+1) = EMNEUT
35967         EMN1(J0+2) = EMPROT
35968         EMN2(J0+1) = EMPROT
35969         EMN2(J0+2) = EMNEUT
35970       ENDDO
35971       DO J=1,6
35972         EMLSQ(J) = EML(J)**2
35973         ETQE(J)  = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
35974       ENDDO
35975       RETURN
35976       END
35977
35978 *$ CREATE DT_DSQEL_Q2.FOR
35979 *COPY DT_DSQEL_Q2
35980 *
35981 *===dsqel_q2===========================================================*
35982 *
35983       DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
35984
35985 C...differential cross section for  Quasi-Elastic scattering
35986 C.       nu + N -> l + N'
35987 C.  From Llewellin Smith  Phys.Rep.  3C, 261, (1971).
35988 C.
35989 C.  INPUT :  JTYP = 1,...,6    nu_e, ...., nubar_tau
35990 C.           ENU (GeV) =  Neutrino energy
35991 C.           Q2  (GeV**2) =  (Transfer momentum)**2
35992 C.
35993 C.  OUTPUT : DSQEL_Q2  = differential  cross section :
35994 C.                       dsigma/dq**2  (10**-38 cm+2/GeV**2)
35995 C------------------------------------------------------------------
35996
35997       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35998       SAVE
35999
36000 * particle masses used in qel neutrino scattering modules
36001       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
36002      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
36003      &                EMPROTSQ,EMNEUTSQ,EMNSQ
36004 **sr - removed (not needed)
36005 C     COMMON /CAXIAL/ FA0, AXIAL2
36006 **
36007
36008       DIMENSION SS(6)
36009       DATA C0 /0.17590D0 /  ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
36010       DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
36011       DATA AXIAL2 /1.03D0/  ! to be checked
36012
36013       FA0=-1.253D0
36014       CSI = 3.71D0                   !  ???
36015       GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2   ! G_e(q**2)
36016       GVM = (1.D0+CSI)*GVE           ! G_m (q**2)
36017       X = Q2/(EMN*EMN)     ! emn=massa barione
36018       XA = X/4.D0
36019       FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
36020       FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
36021       FA = FA0/(1.D0 + Q2/AXIAL2)**2
36022       FFA = FA*FA
36023       FFV1 = FV1*FV1
36024       FFV2 = FV2*FV2
36025       RM = EMLSQ(JTYP)/(EMN*EMN)            ! emlsq(jtyp)
36026       A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
36027       A2 = -RM * ((FV1 + FV2)**2 +  FFA)
36028       AA = (XA+0.25D0*RM)*(A1 + A2)
36029       BB = -X*FA*(FV1 + FV2)
36030       CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
36031       SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
36032       DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU)  !
36033       IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
36034
36035       RETURN
36036       END
36037
36038 *$ CREATE DT_PREPOLA.FOR
36039 *COPY DT_PREPOLA
36040 *
36041 *===prepola============================================================*
36042 *
36043       SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
36044
36045       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36046       SAVE
36047 c
36048 c By G. Battistoni and E. Scapparone (sept. 1997)
36049 c According to:
36050 c     Albright & Jarlskog, Nucl Phys B84 (1975) 467
36051 c
36052 c
36053       PARAMETER (MAXLND=4000)
36054       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
36055       COMMON /QNPOL/ POLARX(4),PMODUL
36056 * particle masses used in qel neutrino scattering modules
36057       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
36058      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
36059      &                EMPROTSQ,EMNEUTSQ,EMNSQ
36060 * steering flags for qel neutrino scattering modules
36061       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
36062 **sr - removed (not needed)
36063 C     COMMON /CAXIAL/ FA0, AXIAL2
36064 C     COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
36065 C    &        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
36066 **
36067       REAL*8 POL(4,4),BB2(3)
36068       DIMENSION SS(6)
36069 C     DATA C0 /0.17590D0 /  ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
36070       DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
36071 **sr uncommented since common block CAXIAL is now commented
36072       DATA AXIAL2 /1.03D0/  ! to be checked
36073 **
36074
36075       RML=P(4,5)
36076       RMM=0.93960D+00
36077       FM2 = RMM**2
36078       MPI = 0.135D+00
36079       OLDQ2=Q2
36080       FA0=-1.253D+00
36081       CSI = 3.71D+00                      !
36082       GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2   ! G_e(q**2)
36083       GVM = (1.D0+CSI)*GVE           ! G_m (q**2)
36084       X = Q2/(EMN*EMN)     ! emn=massa barione
36085       XA = X/4.D0
36086       FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
36087       FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
36088       FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
36089       FFA = FA*FA
36090       FFV1 = FV1*FV1
36091       FFV2 = FV2*FV2
36092       FP=2.D0*FA*RMM/(MPI**2 + Q2)
36093       RM = EMLSQ(JTYP)/(EMN*EMN)            ! emlsq(jtyp)
36094       A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
36095       A2 = -RM * ((FV1 + FV2)**2 +  FFA)
36096       AA = (XA+0.25D+00*RM)*(A1 + A2)
36097       BB = -X*FA*(FV1 + FV2)
36098       CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
36099       SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
36100
36101       OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2   )  ! articolo di ll...-smith
36102       OMEGA2=4.D+00*CC
36103       OMEGA3=2.D+00*FA*(FV1+FV2)
36104       OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
36105      1     (Q2/FM2))*FP**2)
36106       OMEGA5=OMEGA2
36107       OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
36108       WW1=2.D+00*OMEGA1*EMN**2
36109       WW2=2.D+00*OMEGA2*EMN**2
36110       WW3=2.D+00*OMEGA3*EMN**2
36111       WW4=2.D+00*OMEGA4*EMN**2
36112       WW5=2.D+00*OMEGA5*EMN**2
36113
36114       DO I=1,3
36115         BB2(I)=-P(4,I)/P(4,4)
36116       END DO
36117 c      WRITE(*,*)
36118 c      WRITE(*,*)
36119 c      WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
36120       N=5
36121       CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
36122 * NOW PARTICLES ARE IN THE SCATTERED LEPTON  REST FRAME
36123 c      WRITE(*,*)
36124 c      WRITE(*,*)
36125 c      WRITE(*,*) 'Prepola: now in lepton rest frame'
36126       EE=ENU
36127       QM2=Q2+RML**2
36128       U=Q2/(2.*RMM)
36129       FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
36130      +     (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
36131      +     ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
36132
36133       FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
36134      +     - ((RML**2)/FM2)*WW4                        !<=FM2 inv di RMM!!
36135
36136       FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
36137
36138       DO I=1,3
36139         POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
36140         POLARX(I)=POL(4,I)
36141       END DO
36142
36143       PMODUL=0.D0
36144       DO I=1,3
36145         PMODUL=PMODUL+POL(4,I)**2
36146       END DO
36147
36148       IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
36149          IF(NEUDEC.EQ.1) THEN
36150             CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
36151      +        ETL,PXL,PYL,PZL,
36152      +        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36153 c
36154 c     Tau has decayed in muon
36155 c
36156          ENDIF
36157          IF(NEUDEC.EQ.2) THEN
36158             CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
36159      +        ETL,PXL,PYL,PZL,
36160      +        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36161 c
36162 c     Tau has decayed in electron
36163 c
36164          ENDIF
36165          K(4,1)=15
36166          K(4,4) = 6
36167          K(4,5) = 8
36168          N=N+3
36169 c
36170 c     fill common for muon(electron)
36171 c
36172          P(6,1)=PXL
36173          P(6,2)=PYL
36174          P(6,3)=PZL
36175          P(6,4)=ETL
36176          K(6,1)=1
36177          IF(JTYP.EQ.5) THEN
36178             IF(NEUDEC.EQ.1) THEN
36179                P(6,5)=EML(JTYP-2)
36180                K(6,2)=13
36181             ELSEIF(NEUDEC.EQ.2) THEN
36182                P(6,5)=EML(JTYP-4)
36183                K(6,2)=11
36184             ENDIF
36185          ELSEIF(JTYP.EQ.6) THEN
36186             IF(NEUDEC.EQ.1) THEN
36187                K(6,2)=-13
36188             ELSEIF(NEUDEC.EQ.2) THEN
36189                K(6,2)=-11
36190             ENDIF
36191          END IF
36192          K(6,3)=4
36193          K(6,4)=0
36194          K(6,5)=0
36195 c
36196 c     fill common for tau_(anti)neutrino
36197 c
36198          P(7,1)=PXB
36199          P(7,2)=PYB
36200          P(7,3)=PZB
36201          P(7,4)=ETB
36202          P(7,5)=0.
36203          K(7,1)=1
36204          IF(JTYP.EQ.5) THEN
36205             K(7,2)=16
36206          ELSEIF(JTYP.EQ.6) THEN
36207             K(7,2)=-16
36208          END IF
36209          K(7,3)=4
36210          K(7,4)=0
36211          K(7,5)=0
36212 c
36213 c     Fill common for muon(electron)_(anti)neutrino
36214 c
36215          P(8,1)=PXN
36216          P(8,2)=PYN
36217          P(8,3)=PZN
36218          P(8,4)=ETN
36219          P(8,5)=0.
36220          K(8,1)=1
36221          IF(JTYP.EQ.5) THEN
36222             IF(NEUDEC.EQ.1) THEN
36223                K(8,2)=-14
36224             ELSEIF(NEUDEC.EQ.2) THEN
36225                K(8,2)=-12
36226             ENDIF
36227          ELSEIF(JTYP.EQ.6) THEN
36228             IF(NEUDEC.EQ.1) THEN
36229                K(8,2)=14
36230             ELSEIF(NEUDEC.EQ.2) THEN
36231                K(8,2)=12
36232             ENDIF
36233          END IF
36234          K(8,3)=4
36235          K(8,4)=0
36236          K(8,5)=0
36237       ENDIF
36238 c      WRITE(*,*)
36239 c      WRITE(*,*)
36240
36241 c      IF(PMODUL.GE.1.D+00) THEN
36242 c        WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
36243 c        write(*,*) pmodul
36244 c        DO I=1,3
36245 c          POL(4,I)=POL(4,I)/PMODUL
36246 c          POLARX(I)=POL(4,I)
36247 c        END DO
36248 c        PMODUL=0.
36249 c        DO I=1,3
36250 c          PMODUL=PMODUL+POL(4,I)**2
36251 c        END DO
36252 c        WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
36253 c
36254 c      ENDIF
36255
36256 c      WRITE(*,*) 'PMODUL = ',PMODUL
36257
36258 c      WRITE(*,*)
36259 c      WRITE(*,*)
36260 c      WRITE(*,*) 'prepola: Now back to nucl rest frame'
36261       CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
36262
36263       XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
36264       YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
36265       ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
36266       DO NDC =6,8
36267          V(NDC,1) = XDC
36268          V(NDC,2) = YDC
36269          V(NDC,3) = ZDC
36270       END DO
36271
36272       RETURN
36273       END
36274
36275 *$ CREATE DT_TESTROT.FOR
36276 *COPY DT_TESTROT
36277 *
36278 *===testrot============================================================*
36279 *
36280       SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
36281
36282       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36283       SAVE
36284
36285       DIMENSION ROT(3,3),PI(3),PO(3)
36286
36287       IF (MODE.EQ.1) THEN
36288          ROT(1,1) = 1.D0
36289          ROT(1,2) = 0.D0
36290          ROT(1,3) = 0.D0
36291          ROT(2,1) = 0.D0
36292          ROT(2,2) = COS(PHI)
36293          ROT(2,3) = -SIN(PHI)
36294          ROT(3,1) = 0.D0
36295          ROT(3,2) = SIN(PHI)
36296          ROT(3,3) = COS(PHI)
36297       ELSEIF (MODE.EQ.2) THEN
36298          ROT(1,1) = 0.D0
36299          ROT(1,2) = 1.D0
36300          ROT(1,3) = 0.D0
36301          ROT(2,1) = COS(PHI)
36302          ROT(2,2) = 0.D0
36303          ROT(2,3) = -SIN(PHI)
36304          ROT(3,1) = SIN(PHI)
36305          ROT(3,2) = 0.D0
36306          ROT(3,3) = COS(PHI)
36307       ELSEIF (MODE.EQ.3) THEN
36308          ROT(1,1) = 0.D0
36309          ROT(2,1) = 1.D0
36310          ROT(3,1) = 0.D0
36311          ROT(1,2) = COS(PHI)
36312          ROT(2,2) = 0.D0
36313          ROT(3,2) = -SIN(PHI)
36314          ROT(1,3) = SIN(PHI)
36315          ROT(2,3) = 0.D0
36316          ROT(3,3) = COS(PHI)
36317       ELSEIF (MODE.EQ.4) THEN
36318          ROT(1,1) = 1.D0
36319          ROT(2,1) = 0.D0
36320          ROT(3,1) = 0.D0
36321          ROT(1,2) = 0.D0
36322          ROT(2,2) = COS(PHI)
36323          ROT(3,2) = -SIN(PHI)
36324          ROT(1,3) = 0.D0
36325          ROT(2,3) = SIN(PHI)
36326          ROT(3,3) = COS(PHI)
36327       ELSE
36328          STOP ' TESTROT: mode not supported!'
36329       ENDIF
36330       DO 1 J=1,3
36331         PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
36332     1 CONTINUE
36333
36334       RETURN
36335       END
36336
36337 *$ CREATE DT_LEPDCYP.FOR
36338 *COPY DT_LEPDCYP
36339 *
36340 *===lepdcyp============================================================*
36341 *
36342       SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
36343      &                      ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36344 C
36345 C-----------------------------------------------------------------
36346 C
36347 C   Author   :- G. Battistoni         10-NOV-1995
36348 C
36349 C=================================================================
36350 C
36351 C   Purpose   : performs decay of polarized lepton in
36352 C               its rest frame: a => b + l + anti-nu
36353 C               (Example: mu- => nu-mu + e- + anti-nu-e)
36354 C               Polarization is assumed along Z-axis
36355 C               WARNING:
36356 C               1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
36357 C                  OF NEGLIGIBLE MASS
36358 C               2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
36359 C                  IN THIS VERSION
36360 C
36361 C   Method    : modifies phase space distribution obtained
36362 C               by routine EXPLOD using a rejection against the
36363 C               matrix element for unpolarized lepton decay
36364 C
36365 C   Inputs    : Mass of a :  AMA
36366 C               Mass of l :  AML
36367 C               Polar. of a: POL
36368 C               (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
36369 C                                                 POL = -1)
36370 C
36371 C   Outputs   : kinematic variables in the rest frame of decaying lepton
36372 C               ETL,PXL,PYL,PZL 4-moment of l
36373 C               ETB,PXB,PYB,PZB 4-moment of b
36374 C               ETN,PXN,PYN,PZN 4-moment of anti-nu
36375 C
36376 C============================================================
36377 C +
36378 C Declarations.
36379 C -
36380       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36381       SAVE
36382
36383       PARAMETER ( LINP = 10 ,
36384      &            LOUT = 6 ,
36385      &            LDAT = 9 )
36386       PARAMETER ( KALGNM = 2 )
36387       PARAMETER ( ANGLGB = 5.0D-16 )
36388       PARAMETER ( ANGLSQ = 2.5D-31 )
36389       PARAMETER ( AXCSSV = 0.2D+16 )
36390       PARAMETER ( ANDRFL = 1.0D-38 )
36391       PARAMETER ( AVRFLW = 1.0D+38 )
36392       PARAMETER ( AINFNT = 1.0D+30 )
36393       PARAMETER ( AZRZRZ = 1.0D-30 )
36394       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
36395       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
36396       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
36397       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
36398       PARAMETER ( CSNNRM = 2.0D-15 )
36399       PARAMETER ( DMXTRN = 1.0D+08 )
36400       PARAMETER ( ZERZER = 0.D+00 )
36401       PARAMETER ( ONEONE = 1.D+00 )
36402       PARAMETER ( TWOTWO = 2.D+00 )
36403       PARAMETER ( THRTHR = 3.D+00 )
36404       PARAMETER ( FOUFOU = 4.D+00 )
36405       PARAMETER ( FIVFIV = 5.D+00 )
36406       PARAMETER ( SIXSIX = 6.D+00 )
36407       PARAMETER ( SEVSEV = 7.D+00 )
36408       PARAMETER ( EIGEIG = 8.D+00 )
36409       PARAMETER ( ANINEN = 9.D+00 )
36410       PARAMETER ( TENTEN = 10.D+00 )
36411       PARAMETER ( HLFHLF = 0.5D+00 )
36412       PARAMETER ( ONETHI = ONEONE / THRTHR )
36413       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
36414       PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
36415       PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
36416       PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
36417       PARAMETER ( CLIGHT = 2.99792458         D+10 )
36418       PARAMETER ( AVOGAD = 6.0221367          D+23 )
36419       PARAMETER ( AMELGR = 9.1093897          D-28 )
36420       PARAMETER ( PLCKBR = 1.05457266         D-27 )
36421       PARAMETER ( ELCCGS = 4.8032068          D-10 )
36422       PARAMETER ( ELCMKS = 1.60217733         D-19 )
36423       PARAMETER ( AMUGRM = 1.6605402          D-24 )
36424       PARAMETER ( AMMUMU = 0.113428913        D+00 )
36425       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
36426       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
36427       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
36428       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
36429       PARAMETER ( PLABRC = 0.197327053        D+00 )
36430       PARAMETER ( AMELCT = 0.51099906         D-03 )
36431       PARAMETER ( AMUGEV = 0.93149432         D+00 )
36432       PARAMETER ( AMMUON = 0.105658389        D+00 )
36433       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
36434       PARAMETER ( GEVMEV = 1.0                D+03 )
36435       PARAMETER ( EMVGEV = 1.0                D-03 )
36436       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
36437       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
36438       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
36439 C +
36440 C    variables for EXPLOD
36441 C -
36442       PARAMETER ( KPMX = 10 )
36443       DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
36444      &          PZEXPL (KPMX), ETEXPL (KPMX)
36445 C +
36446 C      test variables
36447 C -
36448 **sr - removed (not needed)
36449 C     COMMON /GBATNU/ ELERAT,NTRY
36450 **
36451 C +
36452 C     Initializes test variables
36453 C -
36454       NTRY = 0
36455       ELERAT = 0.D+00
36456 C +
36457 C     Maximum value for matrix element
36458 C -
36459       ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
36460      &  SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
36461 C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
36462 C     Inputs for EXPLOD
36463 C part. no. 1 is l       (e- in mu- decay)
36464 C part. no. 2 is b       (nu-mu in mu- decay)
36465 C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
36466 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
36467       NPEXPL = 3
36468       ETOTEX = AMA
36469       AMEXPL(1) = AML
36470       AMEXPL(2) = 0.D+00
36471       AMEXPL(3) = 0.D+00
36472 C +
36473 C     phase space distribution
36474 C -
36475   100 CONTINUE
36476       NTRY = NTRY + 1
36477
36478       CALL DT_EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
36479      &                 PYEXPL, PZEXPL )
36480
36481 C +
36482 C  Calculates matrix element:
36483 C  64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
36484 C  Here CTH is the cosine of the angle between anti-nu and Z axis
36485 C -
36486       CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
36487      &  PZEXPL(3)**2 )
36488       PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
36489       PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
36490      &     PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
36491       ELEMAT = 16.D+00 * PROD1 * PROD2
36492       IF(ELEMAT.GT.ELEMAX) THEN
36493         WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
36494         STOP
36495       ENDIF
36496 C +
36497 C     Here performs the rejection
36498 C -
36499       TEST = DT_RNDM(ETOTEX) * ELEMAX
36500       IF ( TEST .GT. ELEMAT ) GO TO 100
36501 C +
36502 C     final assignment of variables
36503 C -
36504       ELERAT = ELEMAT/ELEMAX
36505       ETL = ETEXPL(1)
36506       PXL = PXEXPL(1)
36507       PYL = PYEXPL(1)
36508       PZL = PZEXPL(1)
36509       ETB = ETEXPL(2)
36510       PXB = PXEXPL(2)
36511       PYB = PYEXPL(2)
36512       PZB = PZEXPL(2)
36513       ETN = ETEXPL(3)
36514       PXN = PXEXPL(3)
36515       PYN = PYEXPL(3)
36516       PZN = PZEXPL(3)
36517   999 RETURN
36518       END
36519
36520 *$ CREATE DT_GEN_DELTA.FOR
36521 *COPY DT_GEN_DELTA
36522 C==================================================================
36523 C.  Generation of  Delta resonance events
36524 C==================================================================
36525 *
36526 *===gen_delta==========================================================*
36527 *
36528       SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
36529
36530       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36531       SAVE
36532
36533       PARAMETER ( LINP = 10 ,
36534      &            LOUT = 6 ,
36535      &            LDAT = 9 )
36536 C...Generate a Delta-production neutrino/antineutrino
36537 C.  CC-interaction on a nucleon
36538 C
36539 C.  INPUT  ENU (GeV) = Neutrino Energy
36540 C.         LLEP = neutrino type
36541 C.         LTARG = nucleon target type 1=p, 2=n.
36542 C.         JINT = 1:CC, 2::NC
36543 C.
36544 C.  OUTPUT PPL(4)  4-monentum of final lepton
36545 C----------------------------------------------------
36546       PARAMETER (MAXLND=4000)
36547       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
36548 **sr - removed (not needed)
36549 C     COMMON /CBAD/  LBAD, NBAD
36550 **
36551
36552       DIMENSION PI(3),PO(3)
36553 C     REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
36554       DIMENSION AML0(6),AMN(2)
36555       DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
36556       DATA AMN  /0.93827231, 0.93956563/
36557       DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
36558
36559 c     WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
36560       LBAD = 0
36561 C...Final lepton mass
36562       IF (JINT.EQ.1) THEN
36563         AML = AML0(LLEP)
36564       ELSE
36565         AML = 0.
36566       ENDIF
36567       AML2 = AML**2
36568
36569 C...Particle labels (LUND)
36570       N = 5
36571       K(1,1) = 21
36572       K(2,1) = 21
36573       K(3,1) = 21
36574       K(4,1) = 1
36575       K(3,3) = 1
36576       K(4,3) = 1
36577       IF (LTARG .EQ. 1)  THEN
36578          K(2,2) = 2212
36579       ELSE
36580          K(2,2) = 2112
36581       ENDIF
36582       K0 = (LLEP-1)/2
36583       K1 = LLEP/2
36584       KA = 12 + 2*K0
36585       IS = -1 + 2*LLEP - 4*K1
36586       LNU = 2 - LLEP + 2*K1
36587       K(1,2) = IS*KA
36588       K(5,1) = 1
36589       K(5,3) = 2
36590       IF (JINT .EQ. 1)  THEN                    ! CC interactions
36591          K(3,2) = IS*24
36592          K(4,2) = IS*(KA-1)
36593         IF(LNU.EQ.1) THEN
36594           IF (LTARG .EQ. 1)  THEN
36595               K(5,2) = 2224
36596           ELSE
36597               K(5,2) = 2214
36598           ENDIF
36599         ELSE
36600           IF (LTARG .EQ. 1)  THEN
36601               K(5,2) = 2114
36602           ELSE
36603               K(5,2) = 1114
36604           ENDIF
36605         ENDIF
36606       ELSE
36607          K(3,2) = 23                           ! NC (Z0) interactions
36608          K(4,2) = K(1,2)
36609 **sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
36610 *                                Delta0 for neutron (LTARG=2)
36611 C        IF (LTARG .EQ. 1)  THEN
36612 C           K(5,2) = 2114
36613 C        ELSE
36614 C           K(5,2) = 2214
36615 C        ENDIF
36616          IF (LTARG .EQ. 1)  THEN
36617             K(5,2) = 2214
36618          ELSE
36619             K(5,2) = 2114
36620          ENDIF
36621 **
36622       ENDIF
36623
36624 C...4-momentum initial lepton
36625       P(1,5) = 0.
36626       P(1,4) = ENU
36627       P(1,1) = 0.
36628       P(1,2) = 0.
36629       P(1,3) = ENU
36630 C...4-momentum initial nucleon
36631       P(2,5) = AMN(LTARG)
36632 C     P(2,4) = P(2,5)
36633 C     P(2,1) = 0.
36634 C     P(2,2) = 0.
36635 C     P(2,3) = 0.
36636        P(2,1) = P21
36637        P(2,2) = P22
36638        P(2,3) = P23
36639        P(2,4) = P24
36640        P(2,5) = P25
36641       N=2
36642       beta1=-p(2,1)/p(2,4)
36643       beta2=-p(2,2)/p(2,4)
36644       beta3=-p(2,3)/p(2,4)
36645       N=2
36646
36647       CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
36648
36649 C     print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
36650
36651       phi11=atan(p(1,2)/p(1,3))
36652       pi(1)=p(1,1)
36653       pi(2)=p(1,2)
36654       pi(3)=p(1,3)
36655
36656       CALL DT_TESTROT(PI,Po,PHI11,1)
36657       DO ll=1,3
36658        IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36659       END DO
36660       p(1,1)=po(1)
36661       p(1,2)=po(2)
36662       p(1,3)=po(3)
36663       phi12=atan(p(1,1)/p(1,3))
36664
36665       pi(1)=p(1,1)
36666       pi(2)=p(1,2)
36667       pi(3)=p(1,3)
36668       CALL DT_TESTROT(Pi,Po,PHI12,2)
36669       DO ll=1,3
36670         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36671       END DO
36672       p(1,1)=po(1)
36673       p(1,2)=po(2)
36674       p(1,3)=po(3)
36675
36676       ENUU=P(1,4)
36677
36678 C...Generate the Mass of the Delta
36679       NTRY = 0
36680 100   R = PYR(0)
36681       AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
36682       NTRY = NTRY + 1
36683       IF (NTRY .GT. 1000)  THEN
36684          LBAD = 1
36685          WRITE (LOUT,1001)  NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
36686          RETURN
36687       ENDIF
36688       IF (AMD .LT. AMDMIN)  GOTO 100
36689       ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
36690       IF (ENUU .LT. ET) GOTO 100
36691
36692 C...Kinematical  limits in Q**2
36693       S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
36694       SQS = SQRT(S)
36695       PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
36696       ELF = (S - AMD**2 + AML2)/(2.*SQS)
36697       PLF = SQRT(ELF**2 - AML2)
36698       Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
36699       Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
36700       IF (Q2MIN .LT. 0.)   Q2MIN = 0.
36701
36702       DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
36703 200   Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
36704       DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
36705       IF (DSIG .LT.  DSIGMAX*PYR(0)) GOTO 200
36706
36707 C...Generate the kinematics of the final particles
36708       EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
36709       GAM = EISTAR/AMN(LTARG)
36710       BET = PSTAR/EISTAR
36711       CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
36712       EL  = GAM*(ELF + BET*PLF*CTSTAR)
36713       PLZ = GAM*(PLF*CTSTAR + BET*ELF)
36714       PL  = SQRT(EL**2 - AML2)
36715       PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
36716       PHI = 6.28319*PYR(0)
36717       P(4,1) = PLT*COS(PHI)
36718       P(4,2) = PLT*SIN(PHI)
36719       P(4,3) = PLZ
36720       P(4,4) = EL
36721       P(4,5) = AML
36722
36723 C...4-momentum of Delta
36724       P(5,1) = -P(4,1)
36725       P(5,2) = -P(4,2)
36726       P(5,3) = ENUU-P(4,3)
36727       P(5,4) = ENUU+AMN(LTARG)-P(4,4)
36728       P(5,5) = AMD
36729
36730 C...4-momentum  of intermediate boson
36731       P(3,5) = -Q2
36732       P(3,4) = P(1,4)-P(4,4)
36733       P(3,1) = P(1,1)-P(4,1)
36734       P(3,2) = P(1,2)-P(4,2)
36735       P(3,3) = P(1,3)-P(4,3)
36736       N=5
36737
36738       DO kw=1,5
36739         pi(1)=p(kw,1)
36740         pi(2)=p(kw,2)
36741         pi(3)=p(kw,3)
36742         CALL DT_TESTROT(Pi,Po,PHI12,3)
36743         DO ll=1,3
36744           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36745         END DO
36746         p(kw,1)=po(1)
36747         p(kw,2)=po(2)
36748         p(kw,3)=po(3)
36749       END DO
36750
36751 c********************************************
36752
36753         DO kw=1,5
36754           pi(1)=p(kw,1)
36755           pi(2)=p(kw,2)
36756           pi(3)=p(kw,3)
36757           CALL DT_TESTROT(Pi,Po,PHI11,4)
36758           DO ll=1,3
36759             IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36760           END DO
36761           p(kw,1)=po(1)
36762           p(kw,2)=po(2)
36763           p(kw,3)=po(3)
36764        END DO
36765 c********************************************
36766 C         transform back into Lab.
36767
36768       CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
36769
36770 C     WRITE(6,*)' Lab fram ( fermi incl.) '
36771       N=5
36772       CALL PYEXEC
36773
36774       RETURN
36775 1001  FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5,  6G10.3)
36776       END
36777
36778 *$ CREATE DT_DSIGMA_DELTA.FOR
36779 *COPY DT_DSIGMA_DELTA
36780 *
36781 *===dsigma_delta=======================================================*
36782 *
36783       DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
36784
36785       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36786       SAVE
36787
36788 C...Reaction nu + N -> lepton + Delta
36789 C.  returns the  cross section
36790 C.  dsigma/dt
36791 C.  INPUT  LNU = 1, 2  (neutrino-antineutrino)
36792 C.         QQ = t (always negative)  GeV**2
36793 C.         S  = (c.m energy)**2      GeV**2
36794 C.  OUTPUT =  10**-38 cm+2/GeV**2
36795 C-----------------------------------------------------
36796       REAL*8 MN, MN2, MN4, MD,MD2, MD4
36797       DATA MN /0.938/
36798       DATA PI /3.1415926/
36799
36800       GF = (1.1664 * 1.97)
36801       GF2 = GF*GF
36802       MN2 = MN*MN
36803       MN4 = MN2*MN2
36804       MD2 = MD*MD
36805       MD4 = MD2*MD2
36806       AML2 = AML*AML
36807       AML4 = AML2*AML2
36808       VQ  = (MN2 - MD2 - QQ)/2.
36809       VPI = (MN2 + MD2 - QQ)/2.
36810       VK  = (S + QQ - MN2 - AML2)/2.
36811       PIK = (S - MN2)/2.
36812       QK = (AML2 - QQ)/2.
36813       PIQ = (QQ + MN2 - MD2)/2.
36814       Q = SQRT(-QQ)
36815       C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
36816       C3 = SQRT(3.)*C3V/MN
36817       C4 = -C3/MD             ! attenzione al segno
36818       C5A = 1.18/(1.-QQ/0.4225)**2
36819       C32 = C3**2
36820       C42 = C4**2
36821       C5A2 = C5A**2
36822
36823       IF (LNU .EQ. 1)  THEN
36824       ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
36825      . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
36826      . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
36827      . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
36828       ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
36829      . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
36830      . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
36831      . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
36832      . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
36833      . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ-
36834      . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
36835      . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
36836      . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
36837      . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
36838      . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD*
36839      . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A
36840      . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ*
36841      . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A*
36842      . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2
36843      . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK
36844      . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
36845      . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
36846      . *C42-2.*MD2*VPI*QK**2*C32+ANS3
36847       ELSE
36848       ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
36849      . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
36850      . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
36851      . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
36852       ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
36853      . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
36854      . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
36855      . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
36856      . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
36857      . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
36858      . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
36859      . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
36860      . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
36861      . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
36862      . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
36863      . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
36864      . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
36865      . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
36866      . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
36867      . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
36868      . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
36869      . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
36870      . *C42-2.*MD2*VPI*QK**2*C32+ANS3
36871       ENDIF
36872       ANS1=32.*ANS2
36873       ANS=ANS1/(3.*MD2)
36874       P1CM = (S-MN2)/(2.*SQRT(S))
36875       DT_DSIGMA_DELTA  = GF2/2. * ANS/(64.*PI*S*P1CM**2)
36876
36877       RETURN
36878       END
36879
36880 *$ CREATE DT_QGAUS.FOR
36881 *COPY DT_QGAUS
36882 *
36883 *===qgaus==============================================================*
36884 *
36885       SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
36886
36887       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36888       SAVE
36889
36890       DIMENSION X(5),W(5)
36891       DATA X/.1488743389D0,.4333953941D0,
36892      & .6794095682D0,.8650633666D0,.9739065285D0
36893      */
36894       DATA W/.2955242247D0,.2692667193D0,
36895      & .2190863625D0,.1494513491D0,.0666713443D0
36896      */
36897       XM=0.5D0*(B+A)
36898       XR=0.5D0*(B-A)
36899       SS=0
36900       DO 11 J=1,5
36901         DX=XR*X(J)
36902         SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
36903      *  DT_DSQEL_Q2(LTYP,ENU,XM-DX))
36904 11    CONTINUE
36905       SS=XR*SS
36906
36907       RETURN
36908       END
36909
36910 *$ CREATE DT_DIQBRK.FOR
36911 *COPY DT_DIQBRK
36912 *
36913 *===diqbrk=============================================================*
36914 *
36915       SUBROUTINE DT_DIQBRK
36916
36917       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36918       SAVE
36919
36920 * event history
36921       PARAMETER (NMXHKK=200000)
36922       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36923      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36924      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36925 * extended event history
36926       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36927      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36928      &                IHIST(2,NMXHKK)
36929 * event flag
36930       COMMON /DTEVNO/ NEVENT,ICASCA
36931
36932 C     IF(DT_RNDM(VV).LE.0.5D0)THEN
36933 C       CALL GSQBS1(NHKK)
36934 C       CALL GSQBS2(NHKK)
36935 C       CALL USQBS1(NHKK)
36936 C       CALL USQBS2(NHKK)
36937 C       CALL GSABS1(NHKK)
36938 C       CALL GSABS2(NHKK)
36939 C       CALL USABS1(NHKK)
36940 C       CALL USABS2(NHKK)
36941 C     ELSE
36942 C       CALL GSQBS2(NHKK)
36943 C       CALL GSQBS1(NHKK)
36944 C       CALL USQBS2(NHKK)
36945 C       CALL USQBS1(NHKK)
36946 C       CALL GSABS2(NHKK)
36947 C       CALL GSABS1(NHKK)
36948 C       CALL USABS2(NHKK)
36949 C       CALL USABS1(NHKK)
36950 C     ENDIF
36951
36952       IF(DT_RNDM(VV).LE.0.5D0) THEN
36953         CALL DT_DBREAK(1)
36954         CALL DT_DBREAK(2)
36955         CALL DT_DBREAK(3)
36956         CALL DT_DBREAK(4)
36957         CALL DT_DBREAK(5)
36958         CALL DT_DBREAK(6)
36959         CALL DT_DBREAK(7)
36960         CALL DT_DBREAK(8)
36961       ELSE
36962         CALL DT_DBREAK(2)
36963         CALL DT_DBREAK(1)
36964         CALL DT_DBREAK(4)
36965         CALL DT_DBREAK(3)
36966         CALL DT_DBREAK(6)
36967         CALL DT_DBREAK(5)
36968         CALL DT_DBREAK(8)
36969         CALL DT_DBREAK(7)
36970       ENDIF
36971
36972       RETURN
36973       END
36974
36975 *$ CREATE MUSQBS2.FOR
36976 *COPY MUSQBS2
36977 C
36978 C
36979 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36980       SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36981      *              IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
36982 C
36983 C                  USQBS-2 diagram (split target diquark)
36984 C
36985       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36986       SAVE
36987
36988       PARAMETER ( LINP = 10 ,
36989      &            LOUT = 6 ,
36990      &            LDAT = 9 )
36991 * event history
36992       PARAMETER (NMXHKK=200000)
36993       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36994      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36995      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36996 * extended event history
36997       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36998      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36999      &                IHIST(2,NMXHKK)
37000 * Lorentz-parameters of the current interaction
37001       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37002      &                UMO,PPCM,EPROJ,PPROJ
37003 * diquark-breaking mechanism
37004       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37005
37006 C
37007       PARAMETER (NTMHKK= 300)
37008       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37009      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37010      +(4,NTMHKK)
37011 *KEEP,XSEADI.
37012       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37013      +SSMIMQ,VVMTHR
37014 *KEEP,DPRIN.
37015       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37016       COMMON /EVFLAG/ NUMEV
37017 C
37018 C                  USQBS-2 diagram (split target diquark)
37019 C
37020 C
37021 C     Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
37022 C     Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
37023 C
37024 C     Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
37025 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37026 C
37027 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37028 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37029 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37030 C
37031 C
37032 C       Put new chains into COMMON /HKKTMP/
37033 C
37034       IIGLU1=NC1T-NC1P-1
37035       IIGLU2=NC2T-NC2P-1
37036       IGCOUN=0
37037 C     WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37038       CVQ=1.D0
37039       IREJ=0
37040       IF(IPIP.EQ.2)THEN
37041 C     IF(NUMEV.EQ.-324)THEN
37042 C     WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37043 C    *             'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
37044 C    *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37045 C    *              IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
37046       ENDIF
37047 C
37048 C
37049 C
37050 C     determine x-values of NC1T diquark
37051       XDIQT=PHKK(4,NC1T)*2.D0/UMO
37052       XVQP=PHKK(4,NC1P)*2.D0/UMO
37053 C
37054 C     determine x-values of sea quark pair
37055 C
37056       IPCO=1
37057       ICOU=0
37058  2234 CONTINUE
37059       ICOU=ICOU+1
37060       IF(ICOU.GE.500)THEN
37061         IREJ=1
37062         IF(ISQ.EQ.3)IREJ=3
37063         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
37064         IPCO=0
37065         RETURN
37066       ENDIF
37067       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call  XSEAPA: UMO,XDIQT,XVQP ',
37068      * UMO, XDIQT,XVQP
37069       XSQ=0.D0
37070       XSAQ=0.D0
37071 **NEW
37072 C     CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37073       IF (IPIP.EQ.1) THEN
37074          XQMAX  = XDIQT/2.0D0
37075          XAQMAX = 2.D0*XVQP/3.0D0
37076       ELSE
37077          XQMAX  = 2.D0*XVQP/3.0D0
37078          XAQMAX = XDIQT/2.0D0
37079       ENDIF
37080       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37081       ISAQ = 6+ISQ
37082 C     write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
37083 **
37084         IF(IPCO.GE.3)
37085      &     WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37086       IF(IREJ.GE.1)THEN
37087         IF(IPCO.GE.3)
37088      &     WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37089         IPCO=0
37090         RETURN
37091       ENDIF
37092       IF(IPIP.EQ.1)THEN
37093         IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37094       ELSEIF(IPIP.EQ.2)THEN
37095         IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37096       ENDIF
37097       IF(IPCO.GE.3)THEN
37098         WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
37099      *  XDIQT,XVQP,XSQ,XSAQ
37100       ENDIF
37101 C
37102 C     subtract xsq,xsaq from NC1T diquark and NC1P quark
37103 C
37104 C     XSQ=0.D0
37105       IF(IPIP.EQ.1)THEN
37106         XDIQT=XDIQT-XSQ
37107         XVQP =XVQP -XSAQ
37108       ELSEIF(IPIP.EQ.2)THEN
37109         XDIQT=XDIQT-XSAQ
37110         XVQP =XVQP -XSQ
37111       ENDIF
37112       IF(IPCO.GE.3)
37113      &   WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
37114 C
37115 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37116 C
37117       XVTHRO=CVQ/UMO
37118       IVTHR=0
37119  3466 CONTINUE
37120       IF(IVTHR.EQ.10)THEN
37121         IREJ=1
37122         IF(ISQ.EQ.3)IREJ=3
37123         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
37124       IPCO=0
37125         RETURN
37126       ENDIF
37127       IVTHR=IVTHR+1
37128       XVTHR=XVTHRO/(201-IVTHR)
37129       UNOPRV=UNON
37130  380  CONTINUE
37131       IF(XVTHR.GT.0.66D0*XDIQT)THEN
37132         IREJ=1
37133         IF(ISQ.EQ.3)IREJ=3
37134         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR  large ',
37135      *  XVTHR
37136       IPCO=0
37137         RETURN
37138       ENDIF
37139       IF(DT_RNDM(V).LT.0.5D0)THEN
37140         XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37141         XVTQII=XDIQT-XVTQI
37142       ELSE
37143         XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37144         XVTQI=XDIQT-XVTQII
37145       ENDIF
37146       IF(IPCO.GE.3)THEN
37147         WRITE(LOUT,'(A,2E12.4)')'  MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
37148       ENDIF
37149 C
37150 C     Prepare 4 momenta of new chains and chain ends
37151 C
37152 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37153 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37154 C    +(4,NTMHKK)
37155 C
37156 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37157 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37158 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37159 C
37160 C     SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37161 C    *              IP1,IP21,IP22,IPP1,IPP2)
37162 C
37163       IF(IPIP.EQ.1)THEN
37164         XSQ1=XSQ
37165         XSAQ1=XSAQ
37166         ISQ1=ISQ
37167         ISAQ1=ISAQ
37168       ELSEIF(IPIP.EQ.2)THEN
37169         XSQ1=XSAQ
37170         XSAQ1=XSQ
37171         ISQ1=ISAQ
37172         ISAQ1=ISQ
37173       ENDIF
37174       IDHKT(1)   =IPP1
37175       ISTHKT(1)  =951
37176       JMOHKT(1,1)=NC2P
37177       JMOHKT(2,1)=0
37178       JDAHKT(1,1)=3+IIGLU1
37179       JDAHKT(2,1)=0
37180 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37181       PHKT(1,1)  =PHKK(1,NC2P)
37182       PHKT(2,1)  =PHKK(2,NC2P)
37183       PHKT(3,1)  =PHKK(3,NC2P)
37184       PHKT(4,1)  =PHKK(4,NC2P)
37185 C     PHKT(5,1)  =PHKK(5,NC2P)
37186       XMIST  =(PHKT(4,1)**2-
37187      * PHKT(3,1)**2-PHKT(2,1)**2-
37188      *PHKT(1,1)**2)
37189       IF(XMIST.GT.0.D0)THEN
37190       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37191      *PHKT(1,1)**2)
37192       ELSE
37193 C     WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
37194       PHKT(5,1)=0.D0
37195       ENDIF
37196       VHKT(1,1)  =VHKK(1,NC2P)
37197       VHKT(2,1)  =VHKK(2,NC2P)
37198       VHKT(3,1)  =VHKK(3,NC2P)
37199       VHKT(4,1)  =VHKK(4,NC2P)
37200       WHKT(1,1)  =WHKK(1,NC2P)
37201       WHKT(2,1)  =WHKK(2,NC2P)
37202       WHKT(3,1)  =WHKK(3,NC2P)
37203       WHKT(4,1)  =WHKK(4,NC2P)
37204 C     Add here IIGLU1 gluons to this chaina
37205       PG1=0.D0
37206       PG2=0.D0
37207       PG3=0.D0
37208       PG4=0.D0
37209       IF(IIGLU1.GE.1)THEN
37210       JJG=NC1P
37211       DO 61 IIG=2,2+IIGLU1-1
37212         KKG=JJG+IIG-1
37213         IDHKT(IIG)   =IDHKK(KKG)
37214         ISTHKT(IIG)  =921
37215         JMOHKT(1,IIG)=KKG
37216         JMOHKT(2,IIG)=0
37217         JDAHKT(1,IIG)=3+IIGLU1
37218         JDAHKT(2,IIG)=0
37219         PHKT(1,IIG)=PHKK(1,KKG)
37220         PG1=PG1+ PHKT(1,IIG)
37221         PHKT(2,IIG)=PHKK(2,KKG)
37222         PG2=PG2+ PHKT(2,IIG)
37223         PHKT(3,IIG)=PHKK(3,KKG)
37224         PG3=PG3+ PHKT(3,IIG)
37225         PHKT(4,IIG)=PHKK(4,KKG)
37226         PG4=PG4+ PHKT(4,IIG)
37227         PHKT(5,IIG)=PHKK(5,KKG)
37228         VHKT(1,IIG)  =VHKK(1,KKG)
37229         VHKT(2,IIG)  =VHKK(2,KKG)
37230         VHKT(3,IIG)  =VHKK(3,KKG)
37231         VHKT(4,IIG)  =VHKK(4,KKG)
37232         WHKT(1,IIG) =WHKK(1,KKG)
37233         WHKT(2,IIG) =WHKK(2,KKG)
37234         WHKT(3,IIG) =WHKK(3,KKG)
37235         WHKT(4,IIG) =WHKK(4,KKG)
37236    61 CONTINUE
37237       ENDIF
37238       IDHKT(2+IIGLU1)   =IP21
37239       ISTHKT(2+IIGLU1)  =952
37240       JMOHKT(1,2+IIGLU1)=NC1T
37241       JMOHKT(2,2+IIGLU1)=0
37242       JDAHKT(1,2+IIGLU1)=3+IIGLU1
37243       JDAHKT(2,2+IIGLU1)=0
37244       PHKT(1,2+IIGLU1)  =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
37245       PHKT(2,2+IIGLU1)  =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
37246       PHKT(3,2+IIGLU1)  =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
37247       PHKT(4,2+IIGLU1)  =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
37248 C     PHKT(5,2)  =PHKK(5,NC1T)
37249       XMIST  =(PHKT(4,2+IIGLU1)**2-
37250      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37251      *PHKT(1,2+IIGLU1)**2)
37252       IF(XMIST.GT.0.D0)THEN
37253       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
37254      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37255      *PHKT(1,2+IIGLU1)**2)
37256       ELSE
37257 C      WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
37258         PHKT(5,5+IIGLU1)=0.D0
37259       ENDIF
37260       VHKT(1,2+IIGLU1)  =VHKK(1,NC1T)
37261       VHKT(2,2+IIGLU1)  =VHKK(2,NC1T)
37262       VHKT(3,2+IIGLU1)  =VHKK(3,NC1T)
37263       VHKT(4,2+IIGLU1)  =VHKK(4,NC1T)
37264       WHKT(1,2+IIGLU1)  =WHKK(1,NC1T)
37265       WHKT(2,2+IIGLU1)  =WHKK(2,NC1T)
37266       WHKT(3,2+IIGLU1)  =WHKK(3,NC1T)
37267       WHKT(4,2+IIGLU1)  =WHKK(4,NC1T)
37268       IDHKT(3+IIGLU1)   =88888
37269       ISTHKT(3+IIGLU1)  =95
37270       JMOHKT(1,3+IIGLU1)=1
37271       JMOHKT(2,3+IIGLU1)=2+IIGLU1
37272       JDAHKT(1,3+IIGLU1)=0
37273       JDAHKT(2,3+IIGLU1)=0
37274       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
37275       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
37276       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
37277       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
37278       XMIST
37279      * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37280      *            -PHKT(3,3+IIGLU1)**2)
37281       IF(XMIST.GT.0.D0)THEN
37282       PHKT(5,3+IIGLU1)
37283      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37284      *            -PHKT(3,3+IIGLU1)**2)
37285       ELSE
37286 C      WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
37287         PHKT(5,5+IIGLU1)=0.D0
37288       ENDIF
37289       IF(IPIP.GE.2)THEN
37290 C     IF(NUMEV.EQ.-324)THEN
37291 C     WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
37292 C    * JDAHKT(1,1),
37293 C    *JDAHKT(2,1),(PHKT(III,1),III=1,5)
37294       DO 71 IIG=2,2+IIGLU1-1
37295 C     WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37296 C    &             JMOHKT(1,IIG),JMOHKT(2,IIG),
37297 C    * JDAHKT(1,IIG),
37298 C    *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37299    71 CONTINUE
37300 C     WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
37301 C    * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
37302 C    *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
37303 C     WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
37304 C    * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
37305 C    *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
37306       ENDIF
37307       CHAMAL=CHAM1
37308       IF(IPIP.EQ.1)THEN
37309         IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
37310       ELSEIF(IPIP.EQ.2)THEN
37311         IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
37312       ENDIF
37313       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
37314 C       IREJ=1
37315         IPCO=0
37316 C       RETURN
37317 C       WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
37318         GO TO 3466
37319       ENDIF
37320       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
37321       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
37322       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
37323       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
37324       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
37325       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
37326       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
37327       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
37328       IF(IPIP.EQ.1)THEN
37329         IDHKT(4+IIGLU1)   =-(ISAQ1-6)
37330       ELSEIF(IPIP.EQ.2)THEN
37331         IDHKT(4+IIGLU1)   =ISAQ1
37332       ENDIF
37333       ISTHKT(4+IIGLU1)  =951
37334       JMOHKT(1,4+IIGLU1)=NC1P
37335       JMOHKT(2,4+IIGLU1)=0
37336       JDAHKT(1,4+IIGLU1)=6+IIGLU1
37337       JDAHKT(2,4+IIGLU1)=0
37338 C     create chain    6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37339       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
37340       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
37341       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
37342       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
37343 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
37344       XMIST  =(PHKT(4,4+IIGLU1)**2-
37345      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37346      *PHKT(1,4+IIGLU1)**2)
37347       IF(XMIST.GT.0.D0)THEN
37348       PHKT(5,4+IIGLU1)  =SQRT(PHKT(4,4+IIGLU1)**2-
37349      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37350      *PHKT(1,4+IIGLU1)**2)
37351       ELSE
37352 C     WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
37353       PHKT(5,4+IIGLU1)=0.D0
37354       ENDIF
37355       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
37356       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
37357       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
37358       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
37359       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
37360       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
37361       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
37362       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
37363       IDHKT(5+IIGLU1)   =IP22
37364       ISTHKT(5+IIGLU1)  =952
37365       JMOHKT(1,5+IIGLU1)=NC1T
37366       JMOHKT(2,5+IIGLU1)=0
37367       JDAHKT(1,5+IIGLU1)=6+IIGLU1
37368       JDAHKT(2,5+IIGLU1)=0
37369       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
37370       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
37371       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
37372       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
37373 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
37374       XMIST  =(PHKT(4,5+IIGLU1)**2-
37375      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37376      *PHKT(1,5+IIGLU1)**2)
37377       IF(XMIST.GT.0.D0)THEN
37378       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
37379      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37380      *PHKT(1,5+IIGLU1)**2)
37381       ELSE
37382 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37383         PHKT(5,5+IIGLU1)=0.D0
37384       ENDIF
37385       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
37386       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
37387       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
37388       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
37389       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
37390       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
37391       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
37392       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
37393       IDHKT(6+IIGLU1)   =88888
37394       ISTHKT(6+IIGLU1)  =95
37395       JMOHKT(1,6+IIGLU1)=4+IIGLU1
37396       JMOHKT(2,6+IIGLU1)=5+IIGLU1
37397       JDAHKT(1,6+IIGLU1)=0
37398       JDAHKT(2,6+IIGLU1)=0
37399       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37400       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37401       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37402       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37403       XMIST
37404      * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37405      *            -PHKT(3,6+IIGLU1)**2)
37406       IF(XMIST.GT.0.D0)THEN
37407       PHKT(5,6+IIGLU1)
37408      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37409      *            -PHKT(3,6+IIGLU1)**2)
37410       ELSE
37411 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37412         PHKT(5,5+IIGLU1)=0.D0
37413       ENDIF
37414 C     IF(IPIP.GE.2)THEN
37415 C     IF(NUMEV.EQ.-324)THEN
37416 C     WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37417 C    * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37418 C    *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37419 C     WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37420 C    * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37421 C    *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37422 C     WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37423 C    * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37424 C    *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37425 C     ENDIF
37426       CHAMAL=CHAM1
37427       IF(IPIP.EQ.1)THEN
37428         IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37429       ELSEIF(IPIP.EQ.2)THEN
37430         IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37431       ENDIF
37432       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37433 C       IREJ=1
37434         IPCO=0
37435 C       RETURN
37436 C       WRITE(6,*)' MUSQBS1 jump back from chain 6',
37437 C    *  CHAMAL,PHKT(5,6+IIGLU1)
37438         GO TO 3466
37439       ENDIF
37440       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
37441       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
37442       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
37443       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
37444       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
37445       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
37446       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
37447       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
37448 C     IDHKT(7)   =1000*IPP1+100*ISQ+1
37449       IDHKT(7+IIGLU1)   =IP1
37450       ISTHKT(7+IIGLU1)  =951
37451       JMOHKT(1,7+IIGLU1)=NC1P
37452       JMOHKT(2,7+IIGLU1)=0
37453 **NEW
37454 C     JDAHKT(1,7+IIGLU1)=9+IIGLU1
37455       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
37456 **
37457       JDAHKT(2,7+IIGLU1)=0
37458       PHKT(1,7+IIGLU1)  =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
37459       PHKT(2,7+IIGLU1)  =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
37460       PHKT(3,7+IIGLU1)  =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
37461       PHKT(4,7+IIGLU1)  =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
37462 C     PHKT(5,7+IIGLU1)  =PHKK(5,NC1P)
37463       XMIST  =(PHKT(4,7+IIGLU1)**2-
37464      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37465      *PHKT(1,7+IIGLU1)**2)
37466       IF(XMIST.GT.0.D0)THEN
37467       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
37468      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37469      *PHKT(1,7+IIGLU1)**2)
37470       ELSE
37471 C     WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
37472       PHKT(5,7+IIGLU1)=0.D0
37473       ENDIF
37474       VHKT(1,7+IIGLU1)  =VHKK(1,NC1P)
37475       VHKT(2,7+IIGLU1)  =VHKK(2,NC1P)
37476       VHKT(3,7+IIGLU1)  =VHKK(3,NC1P)
37477       VHKT(4,7+IIGLU1)  =VHKK(4,NC1P)
37478       WHKT(1,7+IIGLU1)  =WHKK(1,NC1P)
37479       WHKT(2,7+IIGLU1)  =WHKK(2,NC1P)
37480       WHKT(3,7+IIGLU1)  =WHKK(3,NC1P)
37481       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
37482 C     Insert here the IIGLU2 gluons
37483       PG1=0.D0
37484       PG2=0.D0
37485       PG3=0.D0
37486       PG4=0.D0
37487       IF(IIGLU2.GE.1)THEN
37488       JJG=NC2P
37489       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37490         KKG=JJG+IIG-7-IIGLU1
37491         IDHKT(IIG)   =IDHKK(KKG)
37492         ISTHKT(IIG)  =921
37493         JMOHKT(1,IIG)=KKG
37494         JMOHKT(2,IIG)=0
37495         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
37496         JDAHKT(2,IIG)=0
37497         PHKT(1,IIG)=PHKK(1,KKG)
37498         PG1=PG1+ PHKT(1,IIG)
37499         PHKT(2,IIG)=PHKK(2,KKG)
37500         PG2=PG2+ PHKT(2,IIG)
37501         PHKT(3,IIG)=PHKK(3,KKG)
37502         PG3=PG3+ PHKT(3,IIG)
37503         PHKT(4,IIG)=PHKK(4,KKG)
37504         PG4=PG4+ PHKT(4,IIG)
37505         PHKT(5,IIG)=PHKK(5,KKG)
37506         VHKT(1,IIG)  =VHKK(1,KKG)
37507         VHKT(2,IIG)  =VHKK(2,KKG)
37508         VHKT(3,IIG)  =VHKK(3,KKG)
37509         VHKT(4,IIG)  =VHKK(4,KKG)
37510         WHKT(1,IIG)  =WHKK(1,KKG)
37511         WHKT(2,IIG) =WHKK(2,KKG)
37512         WHKT(3,IIG) =WHKK(3,KKG)
37513         WHKT(4,IIG) =WHKK(4,KKG)
37514    81 CONTINUE
37515       ENDIF
37516       IF(IPIP.EQ.1)THEN
37517         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*ISQ1+3
37518         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
37519         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
37520         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
37521       ELSEIF(IPIP.EQ.2)THEN
37522         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*(-ISQ1+6)-3
37523         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
37524         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
37525         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
37526       ENDIF
37527       ISTHKT(8+IIGLU1+IIGLU2)  =952
37528       JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
37529       JMOHKT(2,8+IIGLU1+IIGLU2)=0
37530       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
37531       JDAHKT(2,8+IIGLU1+IIGLU2)=0
37532       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC2T)+
37533      * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
37534       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC2T)+
37535      * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
37536       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC2T)+
37537      * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
37538       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC2T)+
37539      * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
37540 C     WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
37541 C    * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
37542       IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
37543 C       IREJ=1
37544 C       WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
37545 C    *  ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
37546         IPCO=0
37547 C       RETURN
37548         GO TO 3466
37549       ENDIF
37550 C     PHKT(5,8)  =PHKK(5,NC2T)
37551       XMIST  =(PHKT(4,8+IIGLU1+IIGLU2)**2-
37552      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37553      *PHKT(1,8+IIGLU1+IIGLU2)**2)
37554       IF(XMIST.GT.0.D0)THEN
37555       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
37556      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37557      *PHKT(1,8+IIGLU1+IIGLU2)**2)
37558       ELSE
37559 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37560         PHKT(5,5+IIGLU1)=0.D0
37561       ENDIF
37562       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC2T)
37563       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC2T)
37564       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC2T)
37565       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC2T)
37566       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC2T)
37567       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC2T)
37568       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC2T)
37569       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC2T)
37570       IDHKT(9+IIGLU1+IIGLU2)   =88888
37571       ISTHKT(9+IIGLU1+IIGLU2)  =95
37572       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
37573       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
37574       JDAHKT(1,9+IIGLU1+IIGLU2)=0
37575       JDAHKT(2,9+IIGLU1+IIGLU2)=0
37576 **NEW
37577 C     PHKT(1,9+IIGLU1+IIGLU2)
37578 C    * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37579 C     PHKT(2,9+IIGLU1+IIGLU2)
37580 C    * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37581 C     PHKT(3,9+IIGLU1+IIGLU2)
37582 C    * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37583 C     PHKT(4,9+IIGLU1+IIGLU2)
37584 C    * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37585       PHKT(1,9+IIGLU1+IIGLU2)
37586      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37587       PHKT(2,9+IIGLU1+IIGLU2)
37588      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37589       PHKT(3,9+IIGLU1+IIGLU2)
37590      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37591       PHKT(4,9+IIGLU1+IIGLU2)
37592      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37593 **
37594       XMIST
37595      * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37596      * -PHKT(2,9+IIGLU1+IIGLU2)**2
37597      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
37598       IF(XMIST.GT.0.D0)THEN
37599       PHKT(5,9+IIGLU1+IIGLU2)
37600      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37601      * -PHKT(2,9+IIGLU1+IIGLU2)**2
37602      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
37603       ELSE
37604 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37605         PHKT(5,5+IIGLU1)=0.D0
37606       ENDIF
37607       IF(IPIP.GE.2)THEN
37608 C     IF(NUMEV.EQ.-324)THEN
37609 C     WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
37610 C    * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
37611 C    *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
37612 C     DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37613 C     WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
37614 C    * JDAHKT(1,IIG),
37615 C    *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37616 C  91 CONTINUE
37617 C     WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
37618 C    * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
37619 C    *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
37620 C    *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
37621 C     WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
37622 C    * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
37623 C    *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
37624 C    *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
37625       ENDIF
37626       CHAMAL=CHAB1
37627       IF(IPIP.EQ.1)THEN
37628         IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37629       ELSEIF(IPIP.EQ.2)THEN
37630         IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37631       ENDIF
37632       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37633 C       IREJ=1
37634         IPCO=0
37635 C       RETURN
37636 C       WRITE(6,*)' MUSQBS1 jump back from chain 9',
37637 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
37638         GO TO 3466
37639       ENDIF
37640       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
37641       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
37642       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
37643       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
37644       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
37645       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
37646       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
37647       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
37648 C
37649       IPCO=0
37650       IGCOUN=9+IIGLU1+IIGLU2
37651        RETURN
37652        END
37653
37654 *$ CREATE MGSQBS2.FOR
37655 *COPY MGSQBS2
37656 C
37657 C
37658 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37659       SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37660      *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
37661 C
37662 C                  GSQBS-2 diagram (split target diquark)
37663 C
37664       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37665       SAVE
37666
37667       PARAMETER ( LINP = 10 ,
37668      &            LOUT = 6 ,
37669      &            LDAT = 9 )
37670 * event history
37671       PARAMETER (NMXHKK=200000)
37672       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37673      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37674      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37675 * extended event history
37676       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37677      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37678      &                IHIST(2,NMXHKK)
37679 * Lorentz-parameters of the current interaction
37680       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37681      &                UMO,PPCM,EPROJ,PPROJ
37682 * diquark-breaking mechanism
37683       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37684
37685 C
37686       PARAMETER (NTMHKK= 300)
37687       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37688      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37689      +(4,NTMHKK)
37690
37691 *KEEP,XSEADI.
37692       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37693      +SSMIMQ,VVMTHR
37694 *KEEP,DPRIN.
37695       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37696 C
37697 C                  GSQBS-2 diagram (split target diquark)
37698 C
37699 C
37700 C     Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
37701 C     Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
37702 C
37703 C     Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
37704 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37705 C
37706 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37707 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37708 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37709 C
37710 C
37711 C
37712 C       Put new chains into COMMON /HKKTMP/
37713 C
37714       IIGLU1=NC1T-NC1P-1
37715       IIGLU2=NC2T-NC2P-1
37716       IGCOUN=0
37717 C     WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37718       CVQ=1.D0
37719       IREJ=0
37720 C     IF(IPIP.EQ.2)THEN
37721 C     WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37722 C    *             'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
37723 C    *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37724 C    *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
37725 C     ENDIF
37726 C
37727 C
37728 C
37729 C     determine x-values of NC1T diquark
37730       XDIQT=PHKK(4,NC1T)*2.D0/UMO
37731       XVQP=PHKK(4,NC1P)*2.D0/UMO
37732 C
37733 C     determine x-values of sea quark pair
37734 C
37735       IPCO=1
37736       ICOU=0
37737  2234 CONTINUE
37738       ICOU=ICOU+1
37739       IF(ICOU.GE.500)THEN
37740         IREJ=1
37741         IF(ISQ.EQ.3)IREJ=3
37742         IF(IPCO.GE.3)
37743      &     WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
37744         IPCO=0
37745         RETURN
37746       ENDIF
37747       IF(IPCO.GE.3)
37748      &     WRITE(LOUT,*)'MGSQBS2 call  XSEAPA: UMO,XDIQT,XVQP ',
37749      * UMO, XDIQT,XVQP
37750       XSQ=0.D0
37751       XSAQ=0.D0
37752 **NEW
37753 C     CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37754       IF (IPIP.EQ.1) THEN
37755          XQMAX  = XDIQT/2.0D0
37756          XAQMAX = 2.D0*XVQP/3.0D0
37757       ELSE
37758          XQMAX  = 2.D0*XVQP/3.0D0
37759          XAQMAX = XDIQT/2.0D0
37760       ENDIF
37761       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37762       ISAQ = 6+ISQ
37763 C     write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
37764 **
37765         IF(IPCO.GE.3)
37766      &     WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37767       IF(IREJ.GE.1)THEN
37768         IF(IPCO.GE.3)
37769      &     WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37770         IPCO=0
37771         RETURN
37772       ENDIF
37773       IF(IPIP.EQ.1)THEN
37774         IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37775       ELSEIF(IPIP.EQ.2)THEN
37776         IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37777       ENDIF
37778       IF(IPCO.GE.3)THEN
37779         WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
37780      *  XDIQT,XVQP,XSQ,XSAQ
37781       ENDIF
37782 C
37783 C     subtract xsq,xsaq from NC1T diquark and NC1P quark
37784 C
37785 C     XSQ=0.D0
37786       IF(IPIP.EQ.1)THEN
37787         XDIQT=XDIQT-XSQ
37788         XVQP =XVQP -XSAQ
37789       ELSEIF(IPIP.EQ.2)THEN
37790         XDIQT=XDIQT-XSAQ
37791         XVQP =XVQP -XSQ
37792       ENDIF
37793       IF(IPCO.GE.3)
37794      &   WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
37795 C
37796 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37797 C
37798       XVTHRO=CVQ/UMO
37799       IVTHR=0
37800  3466 CONTINUE
37801       IF(IVTHR.EQ.10)THEN
37802         IREJ=1
37803         IF(ISQ.EQ.3)IREJ=3
37804         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
37805         IPCO=0
37806         RETURN
37807       ENDIF
37808       IVTHR=IVTHR+1
37809       XVTHR=XVTHRO/(201-IVTHR)
37810       UNOPRV=UNON
37811  380  CONTINUE
37812       IF(XVTHR.GT.0.66D0*XDIQT)THEN
37813         IREJ=1
37814         IF(ISQ.EQ.3)IREJ=3
37815         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR  large ',
37816      *  XVTHR
37817         IPCO=0
37818         RETURN
37819       ENDIF
37820       IF(DT_RNDM(V).LT.0.5D0)THEN
37821         XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37822         XVTQII=XDIQT-XVTQI
37823       ELSE
37824         XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37825         XVTQI=XDIQT-XVTQII
37826       ENDIF
37827       IF(IPCO.GE.3)THEN
37828         WRITE(LOUT,'(A,2E12.4)')'  MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
37829       ENDIF
37830 C
37831 C     Prepare 4 momenta of new chains and chain ends
37832 C
37833 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37834 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37835 C    +(4,NTMHKK)
37836 C
37837 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37838 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37839 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37840 C
37841 C     SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37842 C    *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
37843 C
37844       IF(IPIP.EQ.1)THEN
37845         XSQ1=XSQ
37846         XSAQ1=XSAQ
37847         ISQ1=ISQ
37848         ISAQ1=ISAQ
37849       ELSEIF(IPIP.EQ.2)THEN
37850         XSQ1=XSAQ
37851         XSAQ1=XSQ
37852         ISQ1=ISAQ
37853         ISAQ1=ISQ
37854       ENDIF
37855       KK11=IP21
37856 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
37857       KK21=IPP11
37858       KK22=IPP12
37859       XGIVE=0.D0
37860       IF(IPIP.EQ.1)THEN
37861         IDHKT(4+IIGLU1)   =-(ISAQ1-6)
37862       ELSEIF(IPIP.EQ.2)THEN
37863         IDHKT(4+IIGLU1)   =ISAQ1
37864       ENDIF
37865       ISTHKT(4+IIGLU1)  =961
37866       JMOHKT(1,4+IIGLU1)=NC1P
37867       JMOHKT(2,4+IIGLU1)=0
37868       JDAHKT(1,4+IIGLU1)=6+IIGLU1
37869       JDAHKT(2,4+IIGLU1)=0
37870 C     create chain    6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37871       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
37872       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
37873       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
37874       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
37875 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
37876       XXMIST=(PHKT(4,4+IIGLU1)**2-
37877      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37878      *PHKT(1,4+IIGLU1)**2)
37879       IF(XXMIST.GT.0.D0)THEN
37880         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
37881       ELSE
37882         WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
37883         XXMIST=ABS(XXMIST)
37884         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
37885       ENDIF
37886       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
37887       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
37888       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
37889       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
37890       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
37891       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
37892       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
37893       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
37894       IDHKT(5+IIGLU1)   =IP22
37895       ISTHKT(5+IIGLU1)  =962
37896       JMOHKT(1,5+IIGLU1)=NC1T
37897       JMOHKT(2,5+IIGLU1)=0
37898       JDAHKT(1,5+IIGLU1)=6+IIGLU1
37899       JDAHKT(2,5+IIGLU1)=0
37900       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
37901       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
37902       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
37903       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
37904 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
37905       XXMIST=(PHKT(4,5+IIGLU1)**2-
37906      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37907      *PHKT(1,5+IIGLU1)**2)
37908       IF(XXMIST.GT.0.D0)THEN
37909         PHKT(5,5+IIGLU1)  =SQRT(XXMIST)
37910       ELSE
37911         WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
37912         XXMIST=ABS(XXMIST)
37913         PHKT(5,5+IIGLU1)  =SQRT(XXMIST)
37914       ENDIF
37915       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
37916       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
37917       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
37918       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
37919       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
37920       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
37921       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
37922       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
37923       IDHKT(6+IIGLU1)   =88888
37924       ISTHKT(6+IIGLU1)  =96
37925       JMOHKT(1,6+IIGLU1)=4+IIGLU1
37926       JMOHKT(2,6+IIGLU1)=5+IIGLU1
37927       JDAHKT(1,6+IIGLU1)=0
37928       JDAHKT(2,6+IIGLU1)=0
37929       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37930       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37931       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37932       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37933       PHKT(5,6+IIGLU1)
37934      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37935      *            -PHKT(3,6+IIGLU1)**2)
37936       CHAMAL=CHAM1
37937       IF(IPIP.EQ.1)THEN
37938         IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37939       ELSEIF(IPIP.EQ.2)THEN
37940         IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37941       ENDIF
37942 C---------------------------------------------------
37943       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37944         IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
37945 C                    we drop chain 6 and give the energy to chain 3
37946           IDHKT(6+IIGLU1)=22888
37947           XGIVE=1.D0
37948 C         WRITE(6,*)' drop chain 6 xgive=1'
37949           GO TO 7788
37950         ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
37951 C                    we drop chain 6 and give the energy to chain 3
37952 C                    and change KK11 to IDHKT(5)
37953           IDHKT(6+IIGLU1)=22888
37954           XGIVE=1.D0
37955 C         WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
37956           KK11=IDHKT(5+IIGLU1)
37957           GO TO 7788
37958         ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
37959 C                    we drop chain 6 and give the energy to chain 3
37960 C                    and change KK21 to IDHKT(5+IIGLU1)
37961 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
37962           IDHKT(6+IIGLU1)=22888
37963           XGIVE=1.D0
37964 C         WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
37965           KK21=IDHKT(5+IIGLU1)
37966           GO TO 7788
37967         ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
37968 C                    we drop chain 6 and give the energy to chain 3
37969 C                    and change KK22 to IDHKT(5)
37970 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
37971           IDHKT(6+IIGLU1)=22888
37972           XGIVE=1.D0
37973 C         WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
37974           KK22=IDHKT(5+IIGLU1)
37975           GO TO 7788
37976         ENDIF
37977 C       IREJ=1
37978         IPCO=0
37979 C       RETURN
37980         GO TO 3466
37981       ENDIF
37982  7788 CONTINUE
37983 C---------------------------------------------------
37984       IF(IPIP.GE.3)THEN
37985       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37986      * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37987      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37988       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37989      * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37990      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37991       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37992      * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37993      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37994       ENDIF
37995       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
37996       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
37997       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
37998       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
37999       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
38000       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
38001       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
38002       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
38003 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
38004       IF(IPIP.EQ.1)THEN
38005         IDHKT(1)   =1000*KK21+100*KK22+3
38006         IF(IDHKT(1).EQ.1203)IDHKT(1)=2103
38007         IF(IDHKT(1).EQ.1303)IDHKT(1)=3103
38008         IF(IDHKT(1).EQ.2303)IDHKT(1)=3203
38009       ELSEIF(IPIP.EQ.2)THEN
38010         IDHKT(1)   =1000*KK21+100*KK22-3
38011         IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103
38012         IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103
38013         IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203
38014       ENDIF
38015       ISTHKT(1)  =961
38016       JMOHKT(1,1)=NC2P
38017       JMOHKT(2,1)=0
38018       JDAHKT(1,1)=3+IIGLU1
38019       JDAHKT(2,1)=0
38020 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
38021       PHKT(1,1)  =PHKK(1,NC2P)
38022      *+XGIVE*PHKT(1,4+IIGLU1)
38023       PHKT(2,1)  =PHKK(2,NC2P)
38024      *+XGIVE*PHKT(2,4+IIGLU1)
38025       PHKT(3,1)  =PHKK(3,NC2P)
38026      *+XGIVE*PHKT(3,4+IIGLU1)
38027       PHKT(4,1)  =PHKK(4,NC2P)
38028      *+XGIVE*PHKT(4,4+IIGLU1)
38029 C     PHKT(5,1)  =PHKK(5,NC2P)
38030       XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38031      *PHKT(1,1)**2
38032       IF(XXMIST.GT.0.D0)THEN
38033         PHKT(5,1)  =SQRT(XXMIST)
38034       ELSE
38035         WRITE(LOUT,*)'MGSQBS2',XXMIST
38036         XXMIST=ABS(XXMIST)
38037         PHKT(5,1)  =SQRT(XXMIST)
38038       ENDIF
38039       VHKT(1,1)  =VHKK(1,NC2P)
38040       VHKT(2,1)  =VHKK(2,NC2P)
38041       VHKT(3,1)  =VHKK(3,NC2P)
38042       VHKT(4,1)  =VHKK(4,NC2P)
38043       WHKT(1,1)  =WHKK(1,NC2P)
38044       WHKT(2,1)  =WHKK(2,NC2P)
38045       WHKT(3,1)  =WHKK(3,NC2P)
38046       WHKT(4,1)  =WHKK(4,NC2P)
38047 C     Add here IIGLU1 gluons to this chaina
38048       PG1=0.D0
38049       PG2=0.D0
38050       PG3=0.D0
38051       PG4=0.D0
38052       IF(IIGLU1.GE.1)THEN
38053       JJG=NC1P
38054       DO 61 IIG=2,2+IIGLU1-1
38055         KKG=JJG+IIG-1
38056         IDHKT(IIG)   =IDHKK(KKG)
38057         ISTHKT(IIG)  =921
38058         JMOHKT(1,IIG)=KKG
38059         JMOHKT(2,IIG)=0
38060         JDAHKT(1,IIG)=3+IIGLU1
38061         JDAHKT(2,IIG)=0
38062         PHKT(1,IIG)=PHKK(1,KKG)
38063         PG1=PG1+ PHKT(1,IIG)
38064         PHKT(2,IIG)=PHKK(2,KKG)
38065         PG2=PG2+ PHKT(2,IIG)
38066         PHKT(3,IIG)=PHKK(3,KKG)
38067         PG3=PG3+ PHKT(3,IIG)
38068         PHKT(4,IIG)=PHKK(4,KKG)
38069         PG4=PG4+ PHKT(4,IIG)
38070         PHKT(5,IIG)=PHKK(5,KKG)
38071         VHKT(1,IIG)  =VHKK(1,KKG)
38072         VHKT(2,IIG)  =VHKK(2,KKG)
38073         VHKT(3,IIG)  =VHKK(3,KKG)
38074         VHKT(4,IIG)  =VHKK(4,KKG)
38075         WHKT(1,IIG)  =WHKK(1,KKG)
38076         WHKT(2,IIG)  =WHKK(2,KKG)
38077         WHKT(3,IIG)  =WHKK(3,KKG)
38078         WHKT(4,IIG)  =WHKK(4,KKG)
38079    61 CONTINUE
38080       ENDIF
38081 C     IDHKT(2)   =IP21
38082       IDHKT(2+IIGLU1)   =KK11
38083       ISTHKT(2+IIGLU1)  =962
38084       JMOHKT(1,2+IIGLU1)=NC1T
38085       JMOHKT(2,2+IIGLU1)=0
38086       JDAHKT(1,2+IIGLU1)=3+IIGLU1
38087       JDAHKT(2,2+IIGLU1)=0
38088       PHKT(1,2+IIGLU1)  =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
38089 C    * +0.5D0*PHKK(1,NC2T)
38090      *+XGIVE*PHKT(1,5+IIGLU1)
38091       PHKT(2,2+IIGLU1)  =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
38092 C    *+0.5D0*PHKK(2,NC2T)
38093      *+XGIVE*PHKT(2,5+IIGLU1)
38094       PHKT(3,2+IIGLU1)  =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
38095 C    *+0.5D0*PHKK(3,NC2T)
38096      *+XGIVE*PHKT(3,5+IIGLU1)
38097       PHKT(4,2+IIGLU1)  =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
38098 C    *+0.5D0*PHKK(4,NC2T)
38099      *+XGIVE*PHKT(4,5+IIGLU1)
38100 C     PHKT(5,2)  =PHKK(5,NC1T)
38101       XXMIST=(PHKT(4,2+IIGLU1)**2-
38102      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38103      *PHKT(1,2+IIGLU1)**2)
38104       IF(XXMIST.GT.0.D0)THEN
38105         PHKT(5,2+IIGLU1)  =SQRT(XXMIST)
38106       ELSE
38107         WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
38108         XXMIST=ABS(XXMIST)
38109         PHKT(5,2+IIGLU1)  =SQRT(XXMIST)
38110       ENDIF
38111       VHKT(1,2+IIGLU1)  =VHKK(1,NC1T)
38112       VHKT(2,2+IIGLU1)  =VHKK(2,NC1T)
38113       VHKT(3,2+IIGLU1)  =VHKK(3,NC1T)
38114       VHKT(4,2+IIGLU1)  =VHKK(4,NC1T)
38115       WHKT(1,2+IIGLU1)  =WHKK(1,NC1T)
38116       WHKT(2,2+IIGLU1)  =WHKK(2,NC1T)
38117       WHKT(3,2+IIGLU1)  =WHKK(3,NC1T)
38118       WHKT(4,2+IIGLU1)  =WHKK(4,NC1T)
38119       IDHKT(3+IIGLU1)   =88888
38120       ISTHKT(3+IIGLU1)  =96
38121       JMOHKT(1,3+IIGLU1)=1
38122       JMOHKT(2,3+IIGLU1)=2+IIGLU1
38123       JDAHKT(1,3+IIGLU1)=0
38124       JDAHKT(2,3+IIGLU1)=0
38125       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38126       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38127       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38128       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38129       PHKT(5,3+IIGLU1)
38130      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38131      *            -PHKT(3,3+IIGLU1)**2)
38132       IF(IPIP.EQ.3)THEN
38133       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
38134      * JDAHKT(1,1),
38135      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38136       DO 71 IIG=2,2+IIGLU1-1
38137       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38138      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38139      * JDAHKT(1,IIG),
38140      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38141    71 CONTINUE
38142       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
38143      * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38144      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38145       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38146      * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38147      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38148       ENDIF
38149       CHAMAL=CHAB1
38150       IF(IPIP.EQ.1)THEN
38151         IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
38152       ELSEIF(IPIP.EQ.2)THEN
38153         IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
38154       ENDIF
38155       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38156 C       IREJ=1
38157         IPCO=0
38158 C       RETURN
38159         GO TO 3466
38160       ENDIF
38161       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
38162       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
38163       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
38164       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
38165       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
38166       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
38167       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
38168       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
38169 C     IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ+1
38170       IDHKT(7+IIGLU1)   =IP1
38171       ISTHKT(7+IIGLU1)  =961
38172       JMOHKT(1,7+IIGLU1)=NC1P
38173       JMOHKT(2,7+IIGLU1)=0
38174       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38175       JDAHKT(2,7+IIGLU1)=0
38176       PHKT(1,7+IIGLU1)  =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
38177       PHKT(2,7+IIGLU1)  =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
38178       PHKT(3,7+IIGLU1)  =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
38179       PHKT(4,7+IIGLU1)  =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
38180 C     PHKT(5,7+IIGLU1)  =PHKK(5,NC1P)
38181       XXMIST=(PHKT(4,7+IIGLU1)**2-
38182      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38183      *PHKT(1,7+IIGLU1)**2)
38184       IF(XXMIST.GT.0.D0)THEN
38185         PHKT(5,7+IIGLU1)  =SQRT(XXMIST)
38186       ELSE
38187         WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
38188         XXMIST=ABS(XXMIST)
38189         PHKT(5,7+IIGLU1)  =SQRT(XXMIST)
38190       ENDIF
38191       VHKT(1,7+IIGLU1)  =VHKK(1,NC1P)
38192       VHKT(2,7+IIGLU1)  =VHKK(2,NC1P)
38193       VHKT(3,7+IIGLU1)  =VHKK(3,NC1P)
38194       VHKT(4,7+IIGLU1)  =VHKK(4,NC1P)
38195       WHKT(1,7+IIGLU1)  =WHKK(1,NC1P)
38196       WHKT(2,7+IIGLU1)  =WHKK(2,NC1P)
38197       WHKT(3,7+IIGLU1)  =WHKK(3,NC1P)
38198       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
38199 C     IDHKT(7)   =1000*IPP1+100*ISQ+1
38200 C     Insert here the IIGLU2 gluons
38201       PG1=0.D0
38202       PG2=0.D0
38203       PG3=0.D0
38204       PG4=0.D0
38205       IF(IIGLU2.GE.1)THEN
38206       JJG=NC2P
38207       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38208         KKG=JJG+IIG-7-IIGLU1
38209         IDHKT(IIG)   =IDHKK(KKG)
38210         ISTHKT(IIG)  =921
38211         JMOHKT(1,IIG)=KKG
38212         JMOHKT(2,IIG)=0
38213         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38214         JDAHKT(2,IIG)=0
38215         PHKT(1,IIG)=PHKK(1,KKG)
38216         PG1=PG1+ PHKT(1,IIG)
38217         PHKT(2,IIG)=PHKK(2,KKG)
38218         PG2=PG2+ PHKT(2,IIG)
38219         PHKT(3,IIG)=PHKK(3,KKG)
38220         PG3=PG3+ PHKT(3,IIG)
38221         PHKT(4,IIG)=PHKK(4,KKG)
38222         PG4=PG4+ PHKT(4,IIG)
38223         PHKT(5,IIG)=PHKK(5,KKG)
38224         VHKT(1,IIG)  =VHKK(1,KKG)
38225         VHKT(2,IIG)  =VHKK(2,KKG)
38226         VHKT(3,IIG)  =VHKK(3,KKG)
38227         VHKT(4,IIG)  =VHKK(4,KKG)
38228         WHKT(1,IIG)  =WHKK(1,KKG)
38229         WHKT(2,IIG)  =WHKK(2,KKG)
38230         WHKT(3,IIG)  =WHKK(3,KKG)
38231         WHKT(4,IIG)  =WHKK(4,KKG)
38232    81 CONTINUE
38233       ENDIF
38234       IF(IPIP.EQ.1)THEN
38235         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*ISQ1+3
38236         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
38237         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
38238         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
38239       ELSEIF(IPIP.EQ.2)THEN
38240 **NEW
38241 C       IDHKT(8)   =1000*IPP2+100*(-ISQ1+6)-3
38242         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*(-ISQ1+6)-3
38243 **
38244         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
38245         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
38246         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
38247       ENDIF
38248       ISTHKT(8+IIGLU1+IIGLU2)  =962
38249       JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
38250       JMOHKT(2,8+IIGLU1+IIGLU2)=0
38251       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38252       JDAHKT(2,8+IIGLU1+IIGLU2)=0
38253 C     PHKT(1,8)  =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
38254 C     PHKT(2,8)  =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
38255 C     PHKT(3,8)  =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
38256 C     PHKT(4,8)  =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
38257       PHKT(1,8+IIGLU1+IIGLU2)  =
38258      * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
38259       PHKT(2,8+IIGLU1+IIGLU2)  =
38260      * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
38261       PHKT(3,8+IIGLU1+IIGLU2)  =
38262      * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
38263       PHKT(4,8+IIGLU1+IIGLU2)  =
38264      * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
38265 C     WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
38266 C    * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
38267       IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
38268 C       IREJ=1
38269 C       WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
38270         IPCO=0
38271 C       RETURN
38272         GO TO 3466
38273       ENDIF
38274 C     PHKT(5,8)  =PHKK(5,NC2T)
38275       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38276      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38277      *PHKT(1,8+IIGLU1+IIGLU2)**2)
38278       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC2T)
38279       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC2T)
38280       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC2T)
38281       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC2T)
38282       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC2T)
38283       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC2T)
38284       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC2T)
38285       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC2T)
38286       IDHKT(9+IIGLU1+IIGLU2)   =88888
38287       ISTHKT(9+IIGLU1+IIGLU2)  =96
38288       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38289       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38290       JDAHKT(1,9+IIGLU1+IIGLU2)=0
38291       JDAHKT(2,9+IIGLU1+IIGLU2)=0
38292       PHKT(1,9+IIGLU1+IIGLU2)
38293      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
38294       PHKT(2,9+IIGLU1+IIGLU2)
38295      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
38296       PHKT(3,9+IIGLU1+IIGLU2)
38297      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
38298       PHKT(4,9+IIGLU1+IIGLU2)
38299      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
38300       PHKT(5,9+IIGLU1+IIGLU2)
38301      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
38302      * PHKT(2,9+IIGLU1+IIGLU2)**2
38303      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
38304       IF(IPIP.GE.3)THEN
38305       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38306      * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38307      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38308       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38309       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38310      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38311      * JDAHKT(1,IIG),
38312      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38313    91 CONTINUE
38314       WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
38315      * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
38316      *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
38317      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38318       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38319      * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
38320      *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
38321      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38322       ENDIF
38323       CHAMAL=CHAB1
38324       IF(IPIP.EQ.1)THEN
38325         IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38326       ELSEIF(IPIP.EQ.2)THEN
38327         IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38328       ENDIF
38329       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38330 C       IREJ=1
38331         IPCO=0
38332 C       RETURN
38333         GO TO 3466
38334       ENDIF
38335       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
38336       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
38337       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
38338       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
38339       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
38340       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
38341       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
38342       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
38343 C
38344       IPCO=0
38345       IGCOUN=9+IIGLU1+IIGLU2
38346        RETURN
38347        END
38348
38349 *$ CREATE MUSQBS1.FOR
38350 *COPY MUSQBS1
38351 C
38352 C
38353 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38354       SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38355      *              IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
38356 C
38357 C                  USQBS-1 diagram (split projectile diquark)
38358 C
38359       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38360       SAVE
38361
38362       PARAMETER ( LINP = 10 ,
38363      &            LOUT = 6 ,
38364      &            LDAT = 9 )
38365 * event history
38366       PARAMETER (NMXHKK=200000)
38367       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38368      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38369      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38370 * extended event history
38371       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38372      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38373      &                IHIST(2,NMXHKK)
38374 * Lorentz-parameters of the current interaction
38375       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
38376      &                UMO,PPCM,EPROJ,PPROJ
38377 * diquark-breaking mechanism
38378       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
38379
38380 C
38381       PARAMETER (NTMHKK= 300)
38382       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38383      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38384      +(4,NTMHKK)
38385 *KEEP,XSEADI.
38386       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
38387      +SSMIMQ,VVMTHR
38388 *KEEP,DPRIN.
38389       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
38390       COMMON /EVFLAG/ NUMEV
38391 C
38392 C                  USQBS-1 diagram (split projectile diquark)
38393 C
38394 C     Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
38395 C     Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
38396 C
38397 C     Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
38398 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
38399 C
38400 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38401 C                   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38402 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38403 C
38404 C       Put new chains into COMMON /HKKTMP/
38405 C
38406       IIGLU1=NC1T-NC1P-1
38407       IIGLU2=NC2T-NC2P-1
38408       IGCOUN=0
38409 C     WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
38410       CVQ=1.D0
38411       IREJ=0
38412       IF(IPIP.EQ.3)THEN
38413 C     IF(NUMEV.EQ.-324)THEN
38414       WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
38415      *             ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
38416      *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38417      *              IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
38418       ENDIF
38419 C
38420 C
38421 C
38422 C     determine x-values of NC1P diquark
38423       XDIQP=PHKK(4,NC1P)*2.D0/UMO
38424       XVQT=PHKK(4,NC1T)*2.D0/UMO
38425 C
38426 C     determine x-values of sea quark pair
38427 C
38428       IPCO=1
38429       ICOU=0
38430  2234 CONTINUE
38431       ICOU=ICOU+1
38432       IF(ICOU.GE.500)THEN
38433         IREJ=1
38434         IF(ISQ.EQ.3)IREJ=3
38435         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
38436         IPCO=0
38437         RETURN
38438       ENDIF
38439       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call  XSEAPA: UMO,XDIQP,XVQT ',
38440      * UMO, XDIQP,XVQT
38441       XSQ=0.D0
38442       XSAQ=0.D0
38443 **NEW
38444 C     CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
38445       IF (IPIP.EQ.1) THEN
38446          XQMAX  = XDIQP/2.0D0
38447          XAQMAX = 2.D0*XVQT/3.0D0
38448       ELSE
38449          XQMAX  = 2.D0*XVQT/3.0D0
38450          XAQMAX = XDIQP/2.0D0
38451       ENDIF
38452       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
38453       ISAQ = 6+ISQ
38454 C     write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
38455 **
38456       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
38457       IF(IREJ.GE.1)THEN
38458         IF(IPCO.GE.3)
38459      &     WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
38460         IPCO=0
38461         RETURN
38462       ENDIF
38463       IF(IPIP.EQ.1)THEN
38464         IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
38465       ELSEIF(IPIP.EQ.2)THEN
38466         IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
38467       ENDIF
38468       IF(IPCO.GE.3)THEN
38469         WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
38470      *  XDIQP,XVQT,XSQ,XSAQ
38471       ENDIF
38472 C
38473 C     subtract xsq,xsaq from NC1P diquark and NC1T quark
38474 C
38475 C     XSQ=0.D0
38476       IF(IPIP.EQ.1)THEN
38477         XDIQP=XDIQP-XSQ
38478         XVQT =XVQT -XSAQ
38479       ELSEIF(IPIP.EQ.2)THEN
38480         XDIQP=XDIQP-XSAQ
38481         XVQT =XVQT -XSQ
38482       ENDIF
38483       IF(IPCO.GE.3)
38484      &   WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
38485 C
38486 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
38487 C
38488       XVTHRO=CVQ/UMO
38489       IVTHR=0
38490  3466 CONTINUE
38491       IF(IVTHR.EQ.10)THEN
38492         IREJ=1
38493         IF(ISQ.EQ.3)IREJ=3
38494         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
38495         IPCO=0
38496         RETURN
38497       ENDIF
38498       IVTHR=IVTHR+1
38499       XVTHR=XVTHRO/(201-IVTHR)
38500       UNOPRV=UNON
38501  380  CONTINUE
38502       IF(XVTHR.GT.0.66D0*XDIQP)THEN
38503         IREJ=1
38504         IF(ISQ.EQ.3)IREJ=3
38505         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR  large ',
38506      *  XVTHR
38507         IPCO=0
38508         RETURN
38509       ENDIF
38510       IF(DT_RNDM(V).LT.0.5D0)THEN
38511         XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
38512         XVPQII=XDIQP-XVPQI
38513       ELSE
38514         XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
38515         XVPQI=XDIQP-XVPQII
38516       ENDIF
38517       IF(IPCO.GE.3)THEN
38518         WRITE(LOUT,'(A,2E12.4)')'  MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
38519       ENDIF
38520 C
38521 C     Prepare 4 momenta of new chains and chain ends
38522 C
38523 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38524 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38525 C    +(4,NTMHKK)
38526 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38527 C                   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38528 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38529       IF(IPIP.EQ.1)THEN
38530         XSQ1=XSQ
38531         XSAQ1=XSAQ
38532         ISQ1=ISQ
38533         ISAQ1=ISAQ
38534       ELSEIF(IPIP.EQ.2)THEN
38535         XSQ1=XSAQ
38536         XSAQ1=XSQ
38537         ISQ1=ISAQ
38538         ISAQ1=ISQ
38539       ENDIF
38540       IDHKT(1)   =IP11
38541       ISTHKT(1)  =931
38542       JMOHKT(1,1)=NC1P
38543       JMOHKT(2,1)=0
38544       JDAHKT(1,1)=3+IIGLU1
38545       JDAHKT(2,1)=0
38546 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38547       PHKT(1,1)  =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
38548       PHKT(2,1)  =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
38549       PHKT(3,1)  =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
38550       PHKT(4,1)  =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
38551 C     PHKT(5,1)  =PHKK(5,NC1P)
38552       XMIST  =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38553      *PHKT(1,1)**2)
38554       IF(XMIST.GE.0.D0)THEN
38555       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38556      *PHKT(1,1)**2)
38557       ELSE
38558 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38559        PHKT(5,1)=0.D0
38560       ENDIF
38561       VHKT(1,1)  =VHKK(1,NC1P)
38562       VHKT(2,1)  =VHKK(2,NC1P)
38563       VHKT(3,1)  =VHKK(3,NC1P)
38564       VHKT(4,1)  =VHKK(4,NC1P)
38565       WHKT(1,1)  =WHKK(1,NC1P)
38566       WHKT(2,1)  =WHKK(2,NC1P)
38567       WHKT(3,1)  =WHKK(3,NC1P)
38568       WHKT(4,1)  =WHKK(4,NC1P)
38569 C     Add here IIGLU1 gluons to this chaina
38570       PG1=0.D0
38571       PG2=0.D0
38572       PG3=0.D0
38573       PG4=0.D0
38574       IF(IIGLU1.GE.1)THEN
38575       JJG=NC1P
38576       DO 61 IIG=2,2+IIGLU1-1
38577         KKG=JJG+IIG-1
38578         IDHKT(IIG)   =IDHKK(KKG)
38579         ISTHKT(IIG)  =921
38580         JMOHKT(1,IIG)=KKG
38581         JMOHKT(2,IIG)=0
38582         JDAHKT(1,IIG)=3+IIGLU1
38583         JDAHKT(2,IIG)=0
38584         PHKT(1,IIG)=PHKK(1,KKG)
38585         PG1=PG1+ PHKT(1,IIG)
38586         PHKT(2,IIG)=PHKK(2,KKG)
38587         PG2=PG2+ PHKT(2,IIG)
38588         PHKT(3,IIG)=PHKK(3,KKG)
38589         PG3=PG3+ PHKT(3,IIG)
38590         PHKT(4,IIG)=PHKK(4,KKG)
38591         PG4=PG4+ PHKT(4,IIG)
38592         PHKT(5,IIG)=PHKK(5,KKG)
38593         VHKT(1,IIG)  =VHKK(1,KKG)
38594         VHKT(2,IIG)  =VHKK(2,KKG)
38595         VHKT(3,IIG)  =VHKK(3,KKG)
38596         VHKT(4,IIG)  =VHKK(4,KKG)
38597         WHKT(1,IIG) =WHKK(1,KKG)
38598         WHKT(2,IIG) =WHKK(2,KKG)
38599         WHKT(3,IIG) =WHKK(3,KKG)
38600         WHKT(4,IIG) =WHKK(4,KKG)
38601    61 CONTINUE
38602       ENDIF
38603       IDHKT(2+IIGLU1)   =IPP2
38604       ISTHKT(2+IIGLU1)  =932
38605       JMOHKT(1,2+IIGLU1)=NC2T
38606       JMOHKT(2,2+IIGLU1)=0
38607       JDAHKT(1,2+IIGLU1)=3+IIGLU1
38608       JDAHKT(2,2+IIGLU1)=0
38609       PHKT(1,2+IIGLU1)  =PHKK(1,NC2T)
38610       PHKT(2,2+IIGLU1)  =PHKK(2,NC2T)
38611       PHKT(3,2+IIGLU1)  =PHKK(3,NC2T)
38612       PHKT(4,2+IIGLU1)  =PHKK(4,NC2T)
38613 C     PHKT(5,2+IIGLU1)  =PHKK(5,NC2T)
38614       XMIST=(PHKT(4,2+IIGLU1)**2-
38615      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38616      *PHKT(1,2+IIGLU1)**2)
38617       IF(XMIST.GT.0.D0)THEN
38618       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
38619      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38620      *PHKT(1,2+IIGLU1)**2)
38621       ELSE
38622 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38623         PHKT(5,2+IIGLU1)=0.D0
38624       ENDIF
38625       VHKT(1,2+IIGLU1)  =VHKK(1,NC2T)
38626       VHKT(2,2+IIGLU1)  =VHKK(2,NC2T)
38627       VHKT(3,2+IIGLU1)  =VHKK(3,NC2T)
38628       VHKT(4,2+IIGLU1)  =VHKK(4,NC2T)
38629       WHKT(1,2+IIGLU1)  =WHKK(1,NC2T)
38630       WHKT(2,2+IIGLU1)  =WHKK(2,NC2T)
38631       WHKT(3,2+IIGLU1)  =WHKK(3,NC2T)
38632       WHKT(4,2+IIGLU1)  =WHKK(4,NC2T)
38633       IDHKT(3+IIGLU1)   =88888
38634       ISTHKT(3+IIGLU1)  =94
38635       JMOHKT(1,3+IIGLU1)=1
38636       JMOHKT(2,3+IIGLU1)=2+IIGLU1
38637       JDAHKT(1,3+IIGLU1)=0
38638       JDAHKT(2,3+IIGLU1)=0
38639       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38640       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38641       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38642       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38643       XMIST
38644      * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38645      *            -PHKT(3,3+IIGLU1)**2)
38646       IF(XMIST.GE.0.D0)THEN
38647       PHKT(5,3+IIGLU1)
38648      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38649      *            -PHKT(3,3+IIGLU1)**2)
38650       ELSE
38651 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38652        PHKT(5,1)=0.D0
38653       ENDIF
38654       IF(IPIP.GE.3)THEN
38655 C     IF(NUMEV.EQ.-324)THEN
38656       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
38657      * JMOHKT(2,1),JDAHKT(1,1),
38658      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38659       DO 71 IIG=2,2+IIGLU1-1
38660       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38661      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38662      * JDAHKT(1,IIG),
38663      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38664    71 CONTINUE
38665       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
38666      * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38667      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38668       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38669      * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38670      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38671       ENDIF
38672       CHAMAL=CHAM1
38673       IF(IPIP.EQ.1)THEN
38674         IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
38675       ELSEIF(IPIP.EQ.2)THEN
38676         IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
38677       ENDIF
38678       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38679 C       IREJ=1
38680         IPCO=0
38681 C       RETURN
38682 C       WRITE(6,*)' MUSQBS1 jump back from chain 3'
38683         GO TO 3466
38684       ENDIF
38685       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
38686       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
38687       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
38688       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
38689       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
38690       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
38691       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
38692       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
38693       IDHKT(4+IIGLU1)   =IP12
38694       ISTHKT(4+IIGLU1)  =931
38695       JMOHKT(1,4+IIGLU1)=NC1P
38696       JMOHKT(2,4+IIGLU1)=0
38697       JDAHKT(1,4+IIGLU1)=6+IIGLU1
38698       JDAHKT(2,4+IIGLU1)=0
38699 C   create  chain   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38700       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
38701       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
38702       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
38703       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
38704 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
38705       XMIST  =(PHKT(4,4+IIGLU1)**2-
38706      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
38707      *PHKT(1,4+IIGLU1)**2)
38708       IF(XMIST.GT.0.D0)THEN
38709       PHKT(5,4+IIGLU1)  =SQRT(PHKT(4,4+IIGLU1)**2-
38710      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
38711      *PHKT(1,4+IIGLU1)**2)
38712       ELSE
38713 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38714         PHKT(5,4+IIGLU1)=0.D0
38715       ENDIF
38716       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
38717       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
38718       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
38719       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
38720       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
38721       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
38722       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
38723       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
38724       IF(IPIP.EQ.1)THEN
38725         IDHKT(5+IIGLU1)   =-(ISAQ1-6)
38726       ELSEIF(IPIP.EQ.2)THEN
38727         IDHKT(5+IIGLU1)   =ISAQ1
38728       ENDIF
38729       ISTHKT(5+IIGLU1)  =932
38730       JMOHKT(1,5+IIGLU1)=NC1T
38731       JMOHKT(2,5+IIGLU1)=0
38732       JDAHKT(1,5+IIGLU1)=6+IIGLU1
38733       JDAHKT(2,5+IIGLU1)=0
38734       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
38735       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
38736       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
38737       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
38738 C     IF( PHKT(4,5).EQ.0.D0)THEN
38739 C       IREJ=1
38740 CIPCO=0
38741 CRETURN
38742 C     ENDIF
38743 C     PHKT(5,5)  =PHKK(5,NC1T)
38744       XMIST=(PHKT(4,5+IIGLU1)**2-
38745      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
38746      *PHKT(1,5+IIGLU1)**2)
38747       IF(XMIST.GT.0.D0)THEN
38748       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
38749      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
38750      *PHKT(1,5+IIGLU1)**2)
38751       ELSE
38752 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38753         PHKT(5,5+IIGLU1)=0.D0
38754       ENDIF
38755       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
38756       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
38757       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
38758       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
38759       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
38760       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
38761       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
38762       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
38763       IDHKT(6+IIGLU1)   =88888
38764       ISTHKT(6+IIGLU1)  =94
38765       JMOHKT(1,6+IIGLU1)=4+IIGLU1
38766       JMOHKT(2,6+IIGLU1)=5+IIGLU1
38767       JDAHKT(1,6+IIGLU1)=0
38768       JDAHKT(2,6+IIGLU1)=0
38769       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
38770       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
38771       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
38772       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
38773       XMIST
38774      * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
38775      *            -PHKT(3,6+IIGLU1)**2)
38776       IF(XMIST.GE.0.D0)THEN
38777       PHKT(5,6+IIGLU1)
38778      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
38779      *            -PHKT(3,6+IIGLU1)**2)
38780       ELSE
38781 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38782        PHKT(5,1)=0.D0
38783       ENDIF
38784 C     IF(IPIP.EQ.3)THEN
38785       CHAMAL=CHAM1
38786       IF(IPIP.EQ.1)THEN
38787         IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
38788       ELSEIF(IPIP.EQ.2)THEN
38789         IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
38790       ENDIF
38791       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
38792 C       IREJ=1
38793         IPCO=0
38794 C       RETURN
38795 C       WRITE(6,*)' MGSQBS1 jump back from chain 6',
38796 C    *  CHAMAL,PHKT(5,6+IIGLU1)
38797         GO TO 3466
38798       ENDIF
38799       IF(IPIP.GE.3)THEN
38800 C     IF(NUMEV.EQ.-324)THEN
38801       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
38802      * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
38803      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
38804       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
38805      * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
38806      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
38807       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
38808      * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
38809      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
38810       ENDIF
38811       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
38812       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
38813       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
38814       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
38815       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
38816       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
38817       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
38818       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
38819       IF(IPIP.EQ.1)THEN
38820         IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ+3
38821         IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
38822         IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
38823         IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
38824       ELSEIF(IPIP.EQ.2)THEN
38825         IDHKT(7+IIGLU1)   =1000*IPP1+100*(-ISQ1+6)-3
38826         IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
38827         IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
38828         IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
38829 C       WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
38830       ENDIF
38831       ISTHKT(7+IIGLU1)  =931
38832       JMOHKT(1,7+IIGLU1)=NC2P
38833       JMOHKT(2,7+IIGLU1)=0
38834       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38835       JDAHKT(2,7+IIGLU1)=0
38836 C    create chain     9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38837       PHKT(1,7+IIGLU1)  =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
38838       PHKT(2,7+IIGLU1)  =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
38839       PHKT(3,7+IIGLU1)  =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
38840       PHKT(4,7+IIGLU1)  =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
38841 C     WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
38842 C    * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
38843       IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
38844 C       IREJ=1
38845 C       WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
38846         IPCO=0
38847 C       RETURN
38848         GO TO 3466
38849       ENDIF
38850 C     PHKT(5,7)  =PHKK(5,NC2P)
38851       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
38852      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38853      *PHKT(1,7+IIGLU1)**2)
38854       VHKT(1,7+IIGLU1)  =VHKK(1,NC2P)
38855       VHKT(2,7+IIGLU1)  =VHKK(2,NC2P)
38856       VHKT(3,7+IIGLU1)  =VHKK(3,NC2P)
38857       VHKT(4,7+IIGLU1)  =VHKK(4,NC2P)
38858       WHKT(1,7+IIGLU1)  =WHKK(1,NC2P)
38859       WHKT(2,7+IIGLU1)  =WHKK(2,NC2P)
38860       WHKT(3,7+IIGLU1)  =WHKK(3,NC2P)
38861       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
38862 C     Insert here the IIGLU2 gluons
38863       PG1=0.D0
38864       PG2=0.D0
38865       PG3=0.D0
38866       PG4=0.D0
38867       IF(IIGLU2.GE.1)THEN
38868       JJG=NC2P
38869       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38870         KKG=JJG+IIG-7-IIGLU1
38871         IDHKT(IIG)   =IDHKK(KKG)
38872         ISTHKT(IIG)  =921
38873         JMOHKT(1,IIG)=KKG
38874         JMOHKT(2,IIG)=0
38875         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38876         JDAHKT(2,IIG)=0
38877         PHKT(1,IIG)=PHKK(1,KKG)
38878         PG1=PG1+ PHKT(1,IIG)
38879         PHKT(2,IIG)=PHKK(2,KKG)
38880         PG2=PG2+ PHKT(2,IIG)
38881         PHKT(3,IIG)=PHKK(3,KKG)
38882         PG3=PG3+ PHKT(3,IIG)
38883         PHKT(4,IIG)=PHKK(4,KKG)
38884         PG4=PG4+ PHKT(4,IIG)
38885         PHKT(5,IIG)=PHKK(5,KKG)
38886         VHKT(1,IIG)  =VHKK(1,KKG)
38887         VHKT(2,IIG)  =VHKK(2,KKG)
38888         VHKT(3,IIG)  =VHKK(3,KKG)
38889         VHKT(4,IIG)  =VHKK(4,KKG)
38890         WHKT(1,IIG)  =WHKK(1,KKG)
38891         WHKT(2,IIG) =WHKK(2,KKG)
38892         WHKT(3,IIG) =WHKK(3,KKG)
38893         WHKT(4,IIG) =WHKK(4,KKG)
38894    81 CONTINUE
38895       ENDIF
38896       IDHKT(8+IIGLU1+IIGLU2)   =IP2
38897       ISTHKT(8+IIGLU1+IIGLU2)  =932
38898       JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
38899       JMOHKT(2,8+IIGLU1+IIGLU2)=0
38900       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38901       JDAHKT(2,8+IIGLU1+IIGLU2)=0
38902       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
38903       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
38904       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
38905       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
38906 C     PHKT(5,8+IIGLU1+IIGLU2)  =PHKK(5,NC1T)
38907       XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
38908      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38909      *PHKT(1,8+IIGLU1+IIGLU2)**2)
38910       IF(XMIST.GT.0.D0)THEN
38911       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38912      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38913      *PHKT(1,8+IIGLU1+IIGLU2)**2)
38914       ELSE
38915 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38916         PHKT(5,8+IIGLU1+IIGLU2)=0.D0
38917       ENDIF
38918       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC1T)
38919       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC1T)
38920       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC1T)
38921       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC1T)
38922       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC1T)
38923       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC1T)
38924       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC1T)
38925       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC1T)
38926       IDHKT(9+IIGLU1+IIGLU2)   =88888
38927       ISTHKT(9+IIGLU1+IIGLU2)  =94
38928       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38929       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38930       JDAHKT(1,9+IIGLU1+IIGLU2)=0
38931       JDAHKT(2,9+IIGLU1+IIGLU2)=0
38932       PHKT(1,9+IIGLU1+IIGLU2)
38933      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
38934       PHKT(2,9+IIGLU1+IIGLU2)
38935      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
38936       PHKT(3,9+IIGLU1+IIGLU2)
38937      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
38938       PHKT(4,9+IIGLU1+IIGLU2)
38939      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
38940       XMIST
38941      *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
38942      * -PHKT(2,9+IIGLU1+IIGLU2)**2
38943      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
38944       IF(XMIST.GE.0.D0)THEN
38945       PHKT(5,9+IIGLU1+IIGLU2)
38946      *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
38947      * -PHKT(2,9+IIGLU1+IIGLU2)**2
38948      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
38949       ELSE
38950 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38951        PHKT(5,1)=0.D0
38952       ENDIF
38953       IF(IPIP.GE.3)THEN
38954 C     IF(NUMEV.EQ.-324)THEN
38955       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38956      * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38957      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38958       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38959       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38960      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38961      * JDAHKT(1,IIG),
38962      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38963    91 CONTINUE
38964       WRITE(LOUT,*)8+IIGLU1+IIGLU2,
38965      * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
38966      * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
38967      *JDAHKT(1,8+IIGLU1+IIGLU2),
38968      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38969       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38970      * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
38971      *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
38972      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38973       ENDIF
38974       CHAMAL=CHAB1
38975       IF(IPIP.EQ.1)THEN
38976         IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38977       ELSEIF(IPIP.EQ.2)THEN
38978         IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38979       ENDIF
38980       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38981 C       IREJ=1
38982         IPCO=0
38983 C       RETURN
38984 C       WRITE(6,*)' MGSQBS1 jump back from chain 9',
38985 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
38986         GO TO 3466
38987       ENDIF
38988       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
38989       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
38990       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
38991       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
38992       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
38993       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
38994       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
38995       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
38996 C
38997       IPCO=0
38998       IGCOUN=9+IIGLU1+IIGLU2
38999        RETURN
39000        END
39001
39002 *$ CREATE MGSQBS1.FOR
39003 *COPY MGSQBS1
39004 C
39005 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
39006       SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
39007      *              IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
39008 C
39009 C                  GSQBS-1 diagram (split projectile diquark)
39010 C
39011       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39012       SAVE
39013
39014       PARAMETER ( LINP = 10 ,
39015      &            LOUT = 6 ,
39016      &            LDAT = 9 )
39017 * event history
39018       PARAMETER (NMXHKK=200000)
39019       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39020      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39021      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39022 * extended event history
39023       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39024      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39025      &                IHIST(2,NMXHKK)
39026 * Lorentz-parameters of the current interaction
39027       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
39028      &                UMO,PPCM,EPROJ,PPROJ
39029 * diquark-breaking mechanism
39030       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
39031
39032 C
39033       PARAMETER (NTMHKK= 300)
39034       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39035      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39036      +(4,NTMHKK)
39037 *KEEP,XSEADI.
39038       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
39039      +SSMIMQ,VVMTHR
39040 *KEEP,DPRIN.
39041       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
39042 C
39043 C                  GSQBS-1 diagram (split projectile diquark)
39044 C
39045 C
39046 C     Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
39047 C     Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
39048 C
39049 C     Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
39050 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
39051 C
39052 C     Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
39053 C                   6 valence quark(vq2P 4)-sea-quark(aqsP 5)
39054 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
39055 C
39056 C       Put new chains into COMMON /HKKTMP/
39057 C
39058       IIGLU1=NC1T-NC1P-1
39059       IIGLU2=NC2T-NC2P-1
39060       IGCOUN=0
39061 C     WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
39062       CVQ=1.D0
39063       NNNC1=IDHKK(NC1)/1000
39064       MMMC1=IDHKK(NC1)-NNNC1*1000
39065       KKKC1=ISTHKK(NC1)
39066       NNNC2=IDHKK(NC2)/1000
39067       MMMC2=IDHKK(NC2)-NNNC2*1000
39068       KKKC2=ISTHKK(NC2)
39069       IREJ=0
39070       IF(IPIP.EQ.3)THEN
39071       WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
39072      *             ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
39073      *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
39074      *              IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
39075       ENDIF
39076 C
39077 C
39078 C
39079 C     determine x-values of NC1P diquark
39080       XDIQP=PHKK(4,NC1P)*2.D0/UMO
39081       XVQT=PHKK(4,NC1T)*2.D0/UMO
39082 C
39083 C     determine x-values of sea quark pair
39084 C
39085       IPCO=1
39086       ICOU=0
39087  2234 CONTINUE
39088       ICOU=ICOU+1
39089       IF(ICOU.GE.500)THEN
39090         IREJ=1
39091         IF(ISQ.EQ.3)IREJ=3
39092         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
39093       IPCO=0
39094         RETURN
39095       ENDIF
39096       IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call  XSEAPA: UMO,XDIQP,XVQT ',
39097      * UMO, XDIQP,XVQT
39098       XSQ=0.D0
39099       XSAQ=0.D0
39100 **NEW
39101 C     CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
39102       IF (IPIP.EQ.1) THEN
39103          XQMAX  = XDIQP/2.0D0
39104          XAQMAX = 2.D0*XVQT/3.0D0
39105       ELSE
39106          XQMAX  = 2.D0*XVQT/3.0D0
39107          XAQMAX = XDIQP/2.0D0
39108       ENDIF
39109       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
39110       ISAQ = 6+ISQ
39111 C     write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
39112 **
39113         IF(IPCO.GE.3)
39114      &     WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
39115       IF(IREJ.GE.1)THEN
39116         IF(IPCO.GE.3)
39117      &     WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
39118       IPCO=0
39119         RETURN
39120       ENDIF
39121       IF(IPIP.EQ.1)THEN
39122         IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
39123       ELSEIF(IPIP.EQ.2)THEN
39124         IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
39125       ENDIF
39126       IF(IPCO.GE.3)THEN
39127         WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
39128      *  XDIQP,XVQT,XSQ,XSAQ
39129       ENDIF
39130 C
39131 C     subtract xsq,xsaq from NC1P diquark and NC1T quark
39132 C
39133 C     XSQ=0.D0
39134       IF(IPIP.EQ.1)THEN
39135         XDIQP=XDIQP-XSQ
39136 **NEW
39137 C       IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
39138 **
39139         XVQT =XVQT -XSAQ
39140       ELSEIF(IPIP.EQ.2)THEN
39141         XDIQP=XDIQP-XSAQ
39142         XVQT =XVQT -XSQ
39143       ENDIF
39144       IF(IPCO.GE.3)
39145      &   WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
39146 C
39147 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
39148 C
39149       XVTHRO=CVQ/UMO
39150       IVTHR=0
39151  3466 CONTINUE
39152       IF(IVTHR.EQ.10)THEN
39153         IREJ=1
39154         IF(ISQ.EQ.3)IREJ=3
39155         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
39156       IPCO=0
39157         RETURN
39158       ENDIF
39159       IVTHR=IVTHR+1
39160       XVTHR=XVTHRO/(201-IVTHR)
39161       UNOPRV=UNON
39162  380  CONTINUE
39163       IF(XVTHR.GT.0.66D0*XDIQP)THEN
39164         IREJ=1
39165         IF(ISQ.EQ.3)IREJ=3
39166         IF(IPCO.GE.3)
39167      &     WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR  large ',
39168      *  XVTHR
39169       IPCO=0
39170         RETURN
39171       ENDIF
39172       IF(DT_RNDM(V).LT.0.5D0)THEN
39173         XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
39174         XVPQII=XDIQP-XVPQI
39175       ELSE
39176         XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
39177         XVPQI=XDIQP-XVPQII
39178       ENDIF
39179       IF(IPCO.GE.3)THEN
39180         WRITE(LOUT,'(A,4E12.4)')'  MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
39181      *  XVTHR,XDIQP,XVPQI,XVPQII
39182       ENDIF
39183 C
39184 C     Prepare 4 momenta of new chains and chain ends
39185 C
39186 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39187 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39188 C    +(4,NTMHKK)
39189 C     Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
39190 C                   6 valence quark(vq2P 4)-sea-quark(aqsP 5)
39191 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
39192       IF(IPIP.EQ.1)THEN
39193         XSQ1=XSQ
39194         XSAQ1=XSAQ
39195         ISQ1=ISQ
39196         ISAQ1=ISAQ
39197       ELSEIF(IPIP.EQ.2)THEN
39198         XSQ1=XSAQ
39199         XSAQ1=XSQ
39200         ISQ1=ISAQ
39201         ISAQ1=ISQ
39202       ENDIF
39203       KK11=IP11
39204 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
39205       KK21= IPP21
39206       KK22= IPP22
39207       XGIVE=0.D0
39208       IDHKT(4+IIGLU1)   =IP12
39209       ISTHKT(4+IIGLU1)  =921
39210       JMOHKT(1,4+IIGLU1)=NC1P
39211       JMOHKT(2,4+IIGLU1)=0
39212       JDAHKT(1,4+IIGLU1)=6+IIGLU1
39213       JDAHKT(2,4+IIGLU1)=0
39214 **NEW
39215       IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
39216      &    (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
39217 **
39218       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
39219       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
39220       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
39221       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
39222 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
39223       XXMIST=(PHKT(4,4+IIGLU1)**2-
39224      *              PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
39225      *              PHKT(1,4+IIGLU1)**2)
39226       IF(XXMIST.GT.0.D0)THEN
39227         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
39228       ELSE
39229         WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
39230         XXMIST=ABS(XXMIST)
39231         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
39232       ENDIF
39233       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
39234       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
39235       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
39236       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
39237       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
39238       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
39239       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
39240       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
39241       IF(IPIP.EQ.1)THEN
39242         IDHKT(5+IIGLU1)   =-(ISAQ1-6)
39243       ELSEIF(IPIP.EQ.2)THEN
39244         IDHKT(5+IIGLU1)   =ISAQ1
39245       ENDIF
39246       ISTHKT(5+IIGLU1)  =922
39247       JMOHKT(1,5+IIGLU1)=NC1T
39248       JMOHKT(2,5+IIGLU1)=0
39249       JDAHKT(1,5+IIGLU1)=6+IIGLU1
39250       JDAHKT(2,5+IIGLU1)=0
39251 **NEW
39252       IF ((XSAQ1.LT.0.0D0).OR.(XVQT  .LT.0.0D0))
39253      &    WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
39254 **
39255       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
39256       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
39257       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
39258       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
39259 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
39260       XMIST=(PHKT(4,5+IIGLU1)**2-
39261      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
39262      *PHKT(1,5+IIGLU1)**2)
39263       IF(XMIST.GT.0.D0)THEN
39264       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
39265      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
39266      *PHKT(1,5+IIGLU1)**2)
39267       ELSE
39268 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
39269         PHKT(5,5+IIGLU1)=0.D0
39270       ENDIF
39271       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
39272       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
39273       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
39274       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
39275       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
39276       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
39277       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
39278       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
39279       IDHKT(6+IIGLU1)   =88888
39280 C     IDHKT(6)   =1000*NNNC1+MMMC1
39281       ISTHKT(6+IIGLU1)  =93
39282 C     ISTHKT(6)  =KKKC1
39283       JMOHKT(1,6+IIGLU1)=4+IIGLU1
39284       JMOHKT(2,6+IIGLU1)=5+IIGLU1
39285       JDAHKT(1,6+IIGLU1)=0
39286       JDAHKT(2,6+IIGLU1)=0
39287       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
39288       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
39289       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
39290       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
39291       PHKT(5,6+IIGLU1)
39292      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
39293      *            -PHKT(3,6+IIGLU1)**2)
39294       CHAMAL=CHAM1
39295       IF(IPIP.EQ.1)THEN
39296         IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
39297       ELSEIF(IPIP.EQ.2)THEN
39298         IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
39299       ENDIF
39300       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
39301         IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
39302 C                    we drop chain 6 and give the energy to chain 3
39303           IDHKT(6+IIGLU1)=33888
39304           XGIVE=1.D0
39305 C         WRITE(6,*)' drop chain 6 xgive=1'
39306           GO TO 7788
39307         ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
39308 C                    we drop chain 6 and give the energy to chain 3
39309 C                    and change KK11 to IDHKT(4)
39310           IDHKT(6+IIGLU1)=33888
39311           XGIVE=1.D0
39312 C         WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
39313           KK11=IDHKT(4+IIGLU1)
39314           GO TO 7788
39315         ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
39316 C                    we drop chain 6 and give the energy to chain 3
39317 C                    and change KK21 to IDHKT(4)
39318 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
39319           IDHKT(6+IIGLU1)=33888
39320           XGIVE=1.D0
39321 C         WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
39322           KK21=IDHKT(4+IIGLU1)
39323           GO TO 7788
39324         ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
39325 C                    we drop chain 6 and give the energy to chain 3
39326 C                    and change KK22 to IDHKT(4)
39327 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
39328           IDHKT(6+IIGLU1)=33888
39329           XGIVE=1.D0
39330 C         WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
39331           KK22=IDHKT(4+IIGLU1)
39332           GO TO 7788
39333         ENDIF
39334 C       IREJ=1
39335         IPCO=0
39336 C       RETURN
39337 C       WRITE(6,*)' MGSQBS1 jump back from chain 6'
39338         GO TO 3466
39339       ENDIF
39340  7788 CONTINUE
39341       IF(IPIP.GE.3)THEN
39342       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
39343      * JMOHKT(1,4+IIGLU1),
39344      * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
39345      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
39346       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
39347      * JMOHKT(1,5+IIGLU1),
39348      * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
39349      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
39350       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
39351      * JMOHKT(1,6+IIGLU1),
39352      * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
39353      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
39354       ENDIF
39355       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
39356       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
39357       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
39358       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
39359       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
39360       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
39361       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
39362       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
39363 C     IDHKT(1)   =IP11
39364       IDHKT(1)   =KK11
39365       ISTHKT(1)  =921
39366       JMOHKT(1,1)=NC1P
39367       JMOHKT(2,1)=0
39368       JDAHKT(1,1)=3+IIGLU1
39369       JDAHKT(2,1)=0
39370       PHKT(1,1)  =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
39371 C    * +0.5D0*PHKK(1,NC2P)
39372      *+XGIVE*PHKT(1,4+IIGLU1)
39373       PHKT(2,1)  =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
39374 C    * +0.5D0*PHKK(2,NC2P)
39375      *+XGIVE*PHKT(2,4+IIGLU1)
39376       PHKT(3,1)  =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
39377 C    * +0.5D0*PHKK(3,NC2P)
39378      *+XGIVE*PHKT(3,4+IIGLU1)
39379       PHKT(4,1)  =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
39380 C    * +0.5D0*PHKK(4,NC2P)
39381      *+XGIVE*PHKT(4,4+IIGLU1)
39382 C     PHKT(5,1)  =PHKK(5,NC1P)
39383       XMIST  =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
39384      *PHKT(1,1)**2)
39385       IF(XMIST.GE.0.D0)THEN
39386       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
39387      *PHKT(1,1)**2)
39388       ELSE
39389 C      WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
39390        PHKT(5,1)=0.D0
39391       ENDIF
39392       VHKT(1,1)  =VHKK(1,NC1P)
39393       VHKT(2,1)  =VHKK(2,NC1P)
39394       VHKT(3,1)  =VHKK(3,NC1P)
39395       VHKT(4,1)  =VHKK(4,NC1P)
39396       WHKT(1,1)  =WHKK(1,NC1P)
39397       WHKT(2,1)  =WHKK(2,NC1P)
39398       WHKT(3,1)  =WHKK(3,NC1P)
39399       WHKT(4,1)  =WHKK(4,NC1P)
39400 C     Add here IIGLU1 gluons to this chaina
39401       PG1=0.D0
39402       PG2=0.D0
39403       PG3=0.D0
39404       PG4=0.D0
39405       IF(IIGLU1.GE.1)THEN
39406       JJG=NC1P
39407       DO 61 IIG=2,2+IIGLU1-1
39408         KKG=JJG+IIG-1
39409         IDHKT(IIG)   =IDHKK(KKG)
39410         ISTHKT(IIG)  =921
39411         JMOHKT(1,IIG)=KKG
39412         JMOHKT(2,IIG)=0
39413         JDAHKT(1,IIG)=3+IIGLU1
39414         JDAHKT(2,IIG)=0
39415         PHKT(1,IIG)=PHKK(1,KKG)
39416         PG1=PG1+ PHKT(1,IIG)
39417         PHKT(2,IIG)=PHKK(2,KKG)
39418         PG2=PG2+ PHKT(2,IIG)
39419         PHKT(3,IIG)=PHKK(3,KKG)
39420         PG3=PG3+ PHKT(3,IIG)
39421         PHKT(4,IIG)=PHKK(4,KKG)
39422         PG4=PG4+ PHKT(4,IIG)
39423         PHKT(5,IIG)=PHKK(5,KKG)
39424         VHKT(1,IIG)  =VHKK(1,KKG)
39425         VHKT(2,IIG)  =VHKK(2,KKG)
39426         VHKT(3,IIG)  =VHKK(3,KKG)
39427         VHKT(4,IIG)  =VHKK(4,KKG)
39428         WHKT(1,IIG)  =WHKK(1,KKG)
39429         WHKT(2,IIG)  =WHKK(2,KKG)
39430         WHKT(3,IIG)  =WHKK(3,KKG)
39431         WHKT(4,IIG)  =WHKK(4,KKG)
39432    61 CONTINUE
39433       ENDIF
39434 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
39435       IF(IPIP.EQ.1)THEN
39436         IDHKT(2+IIGLU1)   =1000*KK21+100*KK22+3
39437         IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103
39438         IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103
39439         IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203
39440       ELSEIF(IPIP.EQ.2)THEN
39441         IDHKT(2+IIGLU1)   =1000*KK21+100*KK22-3
39442         IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103
39443         IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103
39444         IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203
39445       ENDIF
39446       ISTHKT(2+IIGLU1)  =922
39447       JMOHKT(1,2+IIGLU1)=NC2T
39448       JMOHKT(2,2+IIGLU1)=0
39449       JDAHKT(1,2+IIGLU1)=3+IIGLU1
39450       JDAHKT(2,2+IIGLU1)=0
39451       PHKT(1,2+IIGLU1)  =PHKK(1,NC2T)
39452      *+XGIVE*PHKT(1,5+IIGLU1)
39453       PHKT(2,2+IIGLU1)  =PHKK(2,NC2T)
39454      *+XGIVE*PHKT(2,5+IIGLU1)
39455       PHKT(3,2+IIGLU1)  =PHKK(3,NC2T)
39456      *+XGIVE*PHKT(3,5+IIGLU1)
39457       PHKT(4,2+IIGLU1)  =PHKK(4,NC2T)
39458      *+XGIVE*PHKT(4,5+IIGLU1)
39459 C     PHKT(5,2)  =PHKK(5,NC2T)
39460       XMIST=(PHKT(4,2+IIGLU1)**2-
39461      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
39462      *PHKT(1,2+IIGLU1)**2)
39463       IF(XMIST.GT.0.D0)THEN
39464       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
39465      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
39466      *PHKT(1,2+IIGLU1)**2)
39467       ELSE
39468 C     WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
39469       PHKT(5,2+IIGLU1)=0.D0
39470       ENDIF
39471       VHKT(1,2+IIGLU1)  =VHKK(1,NC2T)
39472       VHKT(2,2+IIGLU1)  =VHKK(2,NC2T)
39473       VHKT(3,2+IIGLU1)  =VHKK(3,NC2T)
39474       VHKT(4,2+IIGLU1)  =VHKK(4,NC2T)
39475       WHKT(1,2+IIGLU1)  =WHKK(1,NC2T)
39476       WHKT(2,2+IIGLU1)  =WHKK(2,NC2T)
39477       WHKT(3,2+IIGLU1)  =WHKK(3,NC2T)
39478       WHKT(4,2+IIGLU1)  =WHKK(4,NC2T)
39479       IDHKT(3+IIGLU1)   =88888
39480 C     IDHKT(3)   =1000*NNNC1+MMMC1+10
39481       ISTHKT(3+IIGLU1)  =93
39482 C     ISTHKT(3)  =KKKC1
39483       JMOHKT(1,3+IIGLU1)=1
39484       JMOHKT(2,3+IIGLU1)=2+IIGLU1
39485       JDAHKT(1,3+IIGLU1)=0
39486       JDAHKT(2,3+IIGLU1)=0
39487       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
39488       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
39489       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
39490       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
39491       PHKT(5,3+IIGLU1)
39492      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
39493      *            -PHKT(3,3+IIGLU1)**2)
39494       IF(IPIP.GE.3)THEN
39495       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
39496      * JDAHKT(1,1),
39497      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
39498       DO 71 IIG=2,2+IIGLU1-1
39499       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
39500      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
39501      * JDAHKT(1,IIG),
39502      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
39503    71 CONTINUE
39504       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
39505      &             IDHKT(2),JMOHKT(1,2+IIGLU1),
39506      * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
39507      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
39508       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
39509      * JMOHKT(1,3+IIGLU1),
39510      * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
39511      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
39512       ENDIF
39513       CHAMAL=CHAB1
39514 **NEW
39515 C     IF(IPIP.EQ.1)THEN
39516 C       IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
39517 C     ELSEIF(IPIP.EQ.2)THEN
39518 C       IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
39519 C     ENDIF
39520       IF(IPIP.EQ.1)THEN
39521         IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
39522       ELSEIF(IPIP.EQ.2)THEN
39523         IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
39524       ENDIF
39525 **
39526       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
39527 C       IREJ=1
39528         IPCO=0
39529 C       RETURN
39530 C       WRITE(6,*)' MGSQBS1 jump back from chain 3'
39531         GO TO 3466
39532       ENDIF
39533       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
39534       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
39535       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
39536       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
39537       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
39538       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
39539       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
39540       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
39541       IF(IPIP.EQ.1)THEN
39542         IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ1+3
39543         IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
39544         IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
39545         IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
39546       ELSEIF(IPIP.EQ.2)THEN
39547         IDHKT(7+IIGLU1)   =1000*IPP1+100*(-ISQ1+6)-3
39548         IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
39549         IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
39550         IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
39551 C       WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
39552       ENDIF
39553       ISTHKT(7+IIGLU1)  =921
39554       JMOHKT(1,7+IIGLU1)=NC2P
39555       JMOHKT(2,7+IIGLU1)=0
39556       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
39557       JDAHKT(2,7+IIGLU1)=0
39558 C     PHKT(1,7)  =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
39559 C     PHKT(2,7)  =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
39560 C     PHKT(3,7)  =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
39561 C     PHKT(4,7+IIGLU1)  =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
39562 **NEW
39563       IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
39564      &    WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
39565 **
39566       PHKT(1,7+IIGLU1)  =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
39567       PHKT(2,7+IIGLU1)  =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
39568       PHKT(3,7+IIGLU1)  =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
39569       PHKT(4,7+IIGLU1)  =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
39570 C     WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
39571 C    * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
39572       IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
39573 C       IREJ=1
39574 C       WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
39575         IPCO=0
39576 C       RETURN
39577         GO TO 3466
39578       ENDIF
39579 C     PHKT(5,7)  =PHKK(5,NC2P)
39580       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
39581      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
39582      *PHKT(1,7+IIGLU1)**2)
39583       VHKT(1,7+IIGLU1)  =VHKK(1,NC2P)
39584       VHKT(2,7+IIGLU1)  =VHKK(2,NC2P)
39585       VHKT(3,7+IIGLU1)  =VHKK(3,NC2P)
39586       VHKT(4,7+IIGLU1)  =VHKK(4,NC2P)
39587       WHKT(1,7+IIGLU1)  =WHKK(1,NC2P)
39588       WHKT(2,7+IIGLU1)  =WHKK(2,NC2P)
39589       WHKT(3,7+IIGLU1)  =WHKK(3,NC2P)
39590       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
39591 C     Insert here the IIGLU2 gluons
39592       PG1=0.D0
39593       PG2=0.D0
39594       PG3=0.D0
39595       PG4=0.D0
39596       IF(IIGLU2.GE.1)THEN
39597       JJG=NC2P
39598       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
39599         KKG=JJG+IIG-7-IIGLU1
39600         IDHKT(IIG)   =IDHKK(KKG)
39601         ISTHKT(IIG)  =921
39602         JMOHKT(1,IIG)=KKG
39603         JMOHKT(2,IIG)=0
39604         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
39605         JDAHKT(2,IIG)=0
39606         PHKT(1,IIG)=PHKK(1,KKG)
39607         PG1=PG1+ PHKT(1,IIG)
39608         PHKT(2,IIG)=PHKK(2,KKG)
39609         PG2=PG2+ PHKT(2,IIG)
39610         PHKT(3,IIG)=PHKK(3,KKG)
39611         PG3=PG3+ PHKT(3,IIG)
39612         PHKT(4,IIG)=PHKK(4,KKG)
39613         PG4=PG4+ PHKT(4,IIG)
39614         PHKT(5,IIG)=PHKK(5,KKG)
39615         VHKT(1,IIG)  =VHKK(1,KKG)
39616         VHKT(2,IIG)  =VHKK(2,KKG)
39617         VHKT(3,IIG)  =VHKK(3,KKG)
39618         VHKT(4,IIG)  =VHKK(4,KKG)
39619         WHKT(1,IIG)  =WHKK(1,KKG)
39620         WHKT(2,IIG)  =WHKK(2,KKG)
39621         WHKT(3,IIG)  =WHKK(3,KKG)
39622         WHKT(4,IIG)  =WHKK(4,KKG)
39623    81 CONTINUE
39624       ENDIF
39625       IDHKT(8+IIGLU1+IIGLU2)   =IP2
39626       ISTHKT(8+IIGLU1+IIGLU2)  =922
39627       JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
39628       JMOHKT(2,8+IIGLU1+IIGLU2)=0
39629       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
39630       JDAHKT(2,8+IIGLU1+IIGLU2)=0
39631 **NEW
39632       IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
39633      &    WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
39634 **
39635       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
39636       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
39637       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
39638       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
39639 C     PHKT(5,8+IIGLU1+IIGLU2)  =PHKK(5,NC1T)
39640       XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
39641      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
39642      *PHKT(1,8+IIGLU1+IIGLU2)**2)
39643       IF(XMIST.GT.0.D0)THEN
39644       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
39645      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
39646      *PHKT(1,8+IIGLU1+IIGLU2)**2)
39647       ELSE
39648 C     WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
39649       PHKT(5,8+IIGLU1+IIGLU2)=0.D0
39650       ENDIF
39651       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC1T)
39652       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC1T)
39653       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC1T)
39654       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC1T)
39655       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC1T)
39656       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC1T)
39657       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC1T)
39658       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC1T)
39659       IDHKT(9+IIGLU1+IIGLU2)   =88888
39660 C     IDHKT(9)   =1000*NNNC2+MMMC2+10
39661       ISTHKT(9+IIGLU1+IIGLU2)  =93
39662 C     ISTHKT(9)  =KKKC2
39663       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
39664       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
39665       JDAHKT(1,9+IIGLU1+IIGLU2)=0
39666       JDAHKT(2,9+IIGLU1+IIGLU2)=0
39667       PHKT(1,9+IIGLU1+IIGLU2)  =PHKT(1,7+IIGLU1)
39668      * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
39669       PHKT(2,9+IIGLU1+IIGLU2)  =PHKT(2,7+IIGLU1)
39670      * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
39671       PHKT(3,9+IIGLU1+IIGLU2)  =PHKT(3,7+IIGLU1)
39672      * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
39673       PHKT(4,9+IIGLU1+IIGLU2)  =PHKT(4,7+IIGLU1)
39674      * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
39675       PHKT(5,9+IIGLU1+IIGLU2)
39676      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
39677      * PHKT(2,9+IIGLU1+IIGLU2)**2
39678      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
39679       IF(IPIP.GE.3)THEN
39680       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
39681      * JMOHKT(1,7+IIGLU1),
39682      * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
39683      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
39684       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
39685       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
39686      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
39687      * JDAHKT(1,IIG),
39688      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
39689    91 CONTINUE
39690       WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
39691      * IDHKT(8+IIGLU1+IIGLU2),
39692      * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
39693      * JDAHKT(1,8+IIGLU1+IIGLU2),
39694      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
39695       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
39696      * IDHKT(9+IIGLU1+IIGLU2),
39697      * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
39698      * JDAHKT(1,9+IIGLU1+IIGLU2),
39699      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
39700       ENDIF
39701       CHAMAL=CHAB1
39702       IF(IPIP.EQ.1)THEN
39703         IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
39704       ELSEIF(IPIP.EQ.2)THEN
39705         IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
39706       ENDIF
39707       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
39708 C       IREJ=1
39709         IPCO=0
39710 C       RETURN
39711 C       WRITE(6,*)' MGSQBS1 jump back from chain 9',
39712 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
39713         GO TO 3466
39714       ENDIF
39715       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
39716       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
39717       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
39718       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
39719       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
39720       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
39721       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
39722       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
39723 C
39724       IGCOUN=9+IIGLU1+IIGLU2
39725       IPCO=0
39726        RETURN
39727        END
39728
39729 *$ CREATE HKKHKT.FOR
39730 *COPY HKKHKT
39731 C
39732 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
39733 C
39734       SUBROUTINE HKKHKT(I,J)
39735       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39736       SAVE
39737
39738 * event history
39739       PARAMETER (NMXHKK=200000)
39740       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39741      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39742      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39743 * extended event history
39744       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39745      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39746      &                IHIST(2,NMXHKK)
39747
39748       PARAMETER (NTMHKK= 300)
39749       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39750      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39751      +(4,NTMHKK)
39752 C
39753       ISTHKK(I)  =ISTHKT(J)
39754       IDHKK(I)   =IDHKT(J)
39755 C     IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
39756       IF(IDHKK(I).EQ.88888)THEN
39757 C       JMOHKK(1,I)=I-2
39758 C       JMOHKK(2,I)=I-1
39759         JMOHKK(1,I)=I-(J-JMOHKT(1,J))
39760         JMOHKK(2,I)=I-(J-JMOHKT(2,J))
39761       ELSE
39762         JMOHKK(1,I)=JMOHKT(1,J)
39763         JMOHKK(2,I)=JMOHKT(2,J)
39764       ENDIF
39765       JDAHKK(1,I)=JDAHKT(1,J)
39766       JDAHKK(2,I)=JDAHKT(2,J)
39767 C       IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
39768 C       JDAHKK(1,I)=I+2
39769 C     ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
39770 C       JDAHKK(1,I)=I+1
39771 C     ENDIF
39772       IF(JDAHKT(1,J).GT.0)THEN
39773         JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
39774       ENDIF
39775       PHKK(1,I)  =PHKT(1,J)
39776       PHKK(2,I)  =PHKT(2,J)
39777       PHKK(3,I)  =PHKT(3,J)
39778       PHKK(4,I)  =PHKT(4,J)
39779       PHKK(5,I)  =PHKT(5,J)
39780       VHKK(1,I)  =VHKT(1,J)
39781       VHKK(2,I)  =VHKT(2,J)
39782       VHKK(3,I)  =VHKT(3,J)
39783       VHKK(4,I)  =VHKT(4,J)
39784       WHKK(1,I)  =WHKT(1,J)
39785       WHKK(2,I)  =WHKT(2,J)
39786       WHKK(3,I)  =WHKT(3,J)
39787       WHKK(4,I)  =WHKT(4,J)
39788       RETURN
39789       END
39790
39791 *$ CREATE DT_DBREAK.FOR
39792 *COPY DT_DBREAK
39793 *
39794 *===dbreak=============================================================*
39795 *
39796       SUBROUTINE DT_DBREAK(MODE)
39797
39798 ************************************************************************
39799 * This is the steering subroutine for the different diquark breaking   *
39800 * mechanisms.                                                          *
39801 *                                                                      *
39802 * MODE = 1  breaking of projectile diquark in qq-q chain using         *
39803 *           a sea quark (q-qq chain) of the same projectile            *
39804 *      = 2  breaking of target     diquark in q-qq chain using         *
39805 *           a sea quark (qq-q chain) of the same target                *
39806 *      = 3  breaking of projectile diquark in qq-q chain using         *
39807 *           a sea quark (q-aq chain) of the same projectile            *
39808 *      = 4  breaking of target     diquark in q-qq chain using         *
39809 *           a sea quark (aq-q chain) of the same target                *
39810 *      = 5  breaking of projectile anti-diquark in aqaq-aq chain using *
39811 *           a sea anti-quark (aq-aqaq chain) of the same projectile    *
39812 *      = 6  breaking of target     anti-diquark in aq-aqaq chain using *
39813 *           a sea anti-quark (aqaq-aq chain) of the same target        *
39814 *      = 7  breaking of projectile anti-diquark in aqaq-aq chain using *
39815 *           a sea anti-quark (aq-q chain) of the same projectile       *
39816 *      = 8  breaking of target     anti-diquark in aq-aqaq chain using *
39817 *           a sea anti-quark (q-aq chain) of the same target           *
39818 *                                                                      *
39819 * Original version by J. Ranft.                                        *
39820 * This version dated 17.5.00  is written by S. Roesler.                *
39821 ************************************************************************
39822
39823       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39824       SAVE
39825       PARAMETER ( LINP = 10 ,
39826      &            LOUT = 6 ,
39827      &            LDAT = 9 )
39828
39829 * event history
39830       PARAMETER (NMXHKK=200000)
39831       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39832      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39833      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39834 * extended event history
39835       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39836      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39837      &                IHIST(2,NMXHKK)
39838 * flags for input different options
39839       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
39840       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
39841      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
39842 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
39843       PARAMETER (MAXCHN=10000)
39844       COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
39845 * diquark-breaking mechanism
39846       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
39847 * flags for particle decays
39848       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
39849      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
39850      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
39851
39852 *
39853 * chain identifiers
39854 * ( 1 = q-aq,   2 = aq-q,   3 = q-qq,   4 = qq-q,
39855 *   5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
39856       DIMENSION IDCHN1(8),IDCHN2(8)
39857       DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
39858       DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
39859 *
39860 * parton identifiers
39861 * ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
39862 *   +-51/52 = unitarity-sea, +-61/62 = gluons )
39863       DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
39864       DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
39865      &             31, 31, 31, 31, 31, 31, 31, 31,
39866      &             41, 41, 41, 41, 51, 51, 51, 51/
39867       DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
39868      &             32, 32, 32, 32, 32, 32, 32, 32,
39869      &             42, 42, 42, 42, 52, 52, 52, 52/
39870       DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
39871      &             51, 31, 41, 41, 31, 31, 31, 31,
39872      &              0, 41, 51, 51, 51, 51, 51, 51/
39873       DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
39874      &             32, 52, 42, 42, 32, 32, 32, 32,
39875      &             42,  0, 52, 52, 52, 52, 52, 52/
39876
39877       IF (NCHAIN.LE.0) RETURN
39878       DO 1 I=1,NCHAIN
39879          IDX1 = IDXCHN(1,I)
39880          IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
39881          IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
39882          IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
39883      &       .AND.
39884      &        ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
39885      &                                    (IS1P.EQ.ISP1P(MODE,3)))
39886      &       .AND.
39887      &        ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
39888      &                                    (IS1T.EQ.ISP1T(MODE,3)))
39889      &      ) THEN
39890             DO 2 J=1,NCHAIN
39891                IDX2 = IDXCHN(1,J)
39892                IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
39893                IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
39894                IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
39895      &             .AND.
39896      &              ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
39897      &                                      .OR.(IS2P.EQ.ISP2P(MODE,3)))
39898      &             .AND.
39899      &              ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
39900      &                                      .OR.(IS2T.EQ.ISP2T(MODE,3)))
39901      &            ) THEN
39902 *   find mother nucleons of the diquark to be splitted and of the
39903 *   sea-quark and reject this combination if it is not the same
39904                   IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
39905      &                (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
39906                      IANCES = 1
39907                   ELSE
39908                      IANCES = 2
39909                   ENDIF
39910                   IDXMO1 = JMOHKK(IANCES,IDX1)
39911     4             CONTINUE
39912                   IF ((JMOHKK(1,IDXMO1).NE.0).AND.
39913      &                (JMOHKK(2,IDXMO1).NE.0)) THEN
39914                      IANC = IANCES
39915                   ELSE
39916                      IANC = 1
39917                   ENDIF
39918                   IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
39919                      IDXMO1 = JMOHKK(IANC,IDXMO1)
39920                      GOTO 4
39921                   ENDIF
39922                   IDXMO2 = JMOHKK(IANCES,IDX2)
39923     5             CONTINUE
39924                   IF ((JMOHKK(1,IDXMO2).NE.0).AND.
39925      &                (JMOHKK(2,IDXMO2).NE.0)) THEN
39926                      IANC = IANCES
39927                   ELSE
39928                      IANC = 1
39929                   ENDIF
39930                   IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
39931                      IDXMO2 = JMOHKK(IANC,IDXMO2)
39932                      GOTO 5
39933                   ENDIF
39934                   IF (IDXMO1.NE.IDXMO2) GOTO 2
39935 *   quark content of projectile parton
39936                   IP1   = IDHKK(JMOHKK(1,IDX1))
39937                   IP11  = IP1/1000
39938                   IP12  = (IP1-1000*IP11)/100
39939                   IP2   = IDHKK(JMOHKK(2,IDX1))
39940                   IP21  = IP2/1000
39941                   IP22  = (IP2-1000*IP21)/100
39942 *   quark content of target parton
39943                   IT1  = IDHKK(JMOHKK(1,IDX2))
39944                   IT11 = IT1/1000
39945                   IT12 = (IT1-1000*IT11)/100
39946                   IT2  = IDHKK(JMOHKK(2,IDX2))
39947                   IT21 = IT2/1000
39948                   IT22 = (IT2-1000*IT21)/100
39949 *   split diquark and form new chains
39950                   IF (MODE.EQ.1) THEN
39951                      IF (IT1.EQ.4) GOTO 2
39952                      CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39953      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39954      &                         IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
39955                   ELSEIF (MODE.EQ.2) THEN
39956                      IF (IT2.EQ.4) GOTO 2
39957                      CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39958      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39959      &                         IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
39960                   ELSEIF (MODE.EQ.3) THEN
39961                      IF (IT1.EQ.4) GOTO 2
39962                      CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39963      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39964      &                         IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
39965                   ELSEIF (MODE.EQ.4) THEN
39966                      IF (IT2.EQ.4) GOTO 2
39967                      CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39968      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39969      &                         IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
39970                   ELSEIF (MODE.EQ.5) THEN
39971                      CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39972      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39973      &                         IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
39974                   ELSEIF (MODE.EQ.6) THEN
39975                      CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39976      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39977      &                         IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN)
39978                   ELSEIF (MODE.EQ.7) THEN
39979                      CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39980      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39981      &                         IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
39982                   ELSEIF (MODE.EQ.8) THEN
39983                      CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39984      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39985      &                         IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
39986                   ENDIF
39987                   IF (IREJ.GE.1) THEN
39988                      if ((ipq.lt.0).or.(ipq.ge.4))
39989      &                  write(LOUT,*) 'ipq !!!',ipq,mode
39990                      DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
39991 *   accept or reject new chains corresponding to PDBSEA
39992                   ELSE
39993                      IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
39994                         ACC   = DBRKA(1,MODE)+DBRKA(2,MODE)
39995                         REJ   = DBRKR(1,MODE)+DBRKR(2,MODE)
39996                      ELSEIF (IPQ.EQ.3) THEN
39997                         ACC   = DBRKA(3,MODE)
39998                         REJ   = DBRKR(3,MODE)
39999                      ELSE
40000                         WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
40001                         STOP
40002                      ENDIF
40003                      IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
40004                         DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
40005                         IACC = 1
40006                      ELSE
40007                         DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
40008                         IACC = 0
40009                      ENDIF
40010 *   new chains have been accepted and are now copied into HKKEVT
40011                      IF (IACC.EQ.1) THEN
40012                         IF (LEMCCK) THEN
40013                            CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
40014      &                                    PHKK(3,IDX1),PHKK(4,IDX1),
40015      &                                    1,IDUM1,IDUM2)
40016                            CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
40017      &                                    PHKK(3,IDX2),PHKK(4,IDX2),
40018      &                                    2,IDUM1,IDUM2)
40019                         ENDIF
40020                         IDHKK(IDX1) = 99888
40021                         IDHKK(IDX2) = 99888
40022                         IDXCHN(2,I) = -1
40023                         IDXCHN(2,J) = -1
40024                         DO 3 K=1,IGCOUN
40025                            NHKK = NHKK+1
40026                            CALL HKKHKT(NHKK,K)
40027                            IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
40028                               PX = -PHKK(1,NHKK)
40029                               PY = -PHKK(2,NHKK)
40030                               PZ = -PHKK(3,NHKK)
40031                               PE = -PHKK(4,NHKK)
40032                               CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
40033                            ENDIF
40034     3                   CONTINUE
40035                         IF (LEMCCK) THEN
40036                            CHKLEV = 0.1D0
40037                            CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
40038      &                                                             IREJ)
40039                            IF (IREJ.NE.0) CALL DT_EVTOUT(4)
40040                         ENDIF
40041                         GOTO 1
40042                      ENDIF
40043                   ENDIF
40044                ENDIF
40045     2       CONTINUE
40046          ENDIF
40047     1 CONTINUE
40048       RETURN
40049       END
40050
40051 *$ CREATE DT_CQPAIR.FOR
40052 *COPY DT_CQPAIR
40053 *
40054 *===cqpair=============================================================*
40055 *
40056       SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
40057
40058 ************************************************************************
40059 * This subroutine Creates a Quark-antiquark PAIR from the sea.         *
40060 *                                                                      *
40061 *   XQMAX   maxium energy fraction of quark (input)                    *
40062 *   XAQMAX  maxium energy fraction of antiquark (input)                *
40063 *   XQ      energy fraction of quark (output)                          *
40064 *   XAQ     energy fraction of antiquark (output)                      *
40065 *   IFLV    quark flavour (- antiquark flavor) (output)                *
40066 *                                                                      *
40067 * This version dated 14.5.00  is written by S. Roesler.                *
40068 ************************************************************************
40069
40070       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
40071       SAVE
40072       PARAMETER ( LINP = 10 ,
40073      &            LOUT = 6 ,
40074      &            LDAT = 9 )
40075
40076 * Lorentz-parameters of the current interaction
40077       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
40078      &                UMO,PPCM,EPROJ,PPROJ
40079
40080 *
40081       IREJ = 0
40082       XQ   = 0.0D0
40083       XAQ  = 0.0D0
40084 *
40085 * sample quark flavour
40086 *
40087 *  set seasq here (the one from DTCHAI should be used in the future)
40088       SEASQ = 0.5D0
40089       IFLV  = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
40090 *
40091 * sample energy fractions of sea pair
40092 * we first sample the energy fraction of a gluon and then split the gluon
40093 *
40094 *  maximum energy fraction of the gluon forced via input
40095       XGMAXI = XQMAX+XAQMAX
40096 *  minimum energy fraction of the gluon
40097       XTHR1 = 4.0D0 /UMO**2
40098       XTHR2 = 0.54D0/UMO**1.5D0
40099       XGMIN = MAX(XTHR1,XTHR2)
40100 *  maximum energy fraction of the gluon
40101       XGMAX = 0.3D0
40102       XGMAX = MIN(XGMAXI,XGMAX)
40103       IF (XGMIN.GE.XGMAX) THEN
40104          IREJ = 1
40105          RETURN
40106       ENDIF
40107 *
40108 *  sample energy fraction of the gluon
40109       NLOOP = 0
40110     1 CONTINUE
40111       NLOOP = NLOOP+1
40112       IF (NLOOP.GE.50) THEN
40113          IREJ = 1
40114          RETURN
40115       ENDIF
40116       XGLUON = DT_SAMSQX(XGMIN,XGMAX)
40117       EGLUON = XGLUON*UMO/2.0D0
40118 *
40119 *  split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
40120       ZMIN = MIN(0.1D0,0.5D0/EGLUON)
40121       ZMAX = 1.0D0-ZMIN
40122       RZ   = DT_RNDM(ZMAX)
40123       XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
40124       RQ   = DT_RNDM(ZMAX)
40125       IF (RQ.LT.0.5D0) THEN
40126          XQ  = XGLUON*XHLP
40127          XAQ = XGLUON-XQ
40128       ELSE
40129          XAQ = XGLUON*XHLP
40130          XQ  = XGLUON-XAQ
40131       ENDIF
40132       IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1
40133
40134       RETURN
40135       END