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.(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       PARAMETER (NMXHKK=200000)
2170       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2171      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2172      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2173 * extended event history
2174       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2175      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2176      &                IHIST(2,NMXHKK)
2177 * particle properties (BAMJET index convention)
2178       CHARACTER*8  ANAME
2179       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2180      &                IICH(210),IIBAR(210),K1(210),K2(210)
2181 * properties of interacting particles
2182       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2183 * Lorentz-parameters of the current interaction
2184       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
2185      &                UMO,PPCM,EPROJ,PPROJ
2186 * flags for input different options
2187       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2188       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2189      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2190 * flags for particle decays
2191       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2192      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2193      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2194 * cuts for variable energy runs
2195       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2196 * Glauber formalism: flags and parameters for statistics
2197       LOGICAL LPROD
2198       CHARACTER*8 CGLB
2199       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2200
2201       DIMENSION WHAT(6)
2202
2203       IREJ  = 0
2204       ILOOP = 0
2205   100 CONTINUE
2206       IF (ILOOP.EQ.4) THEN
2207          WRITE(LOUT,1000) NEVHKK
2208  1000    FORMAT(1X,'KKINC: event ',I8,' rejected!')
2209          GOTO 9999
2210       ENDIF
2211       ILOOP = ILOOP+1
2212
2213 * variable energy-runs, recalculate parameters for LT's
2214       IF ((ABS(VAREHI).GT.ZERO).OR.(IOGLB.EQ.100)) THEN
2215          PDUM = ZERO
2216          CDUM = ZERO
2217          CALL DT_LTINI(IDP,1,EPN,PDUM,CDUM,1)
2218       ENDIF
2219       IF (EPN.GT.EPROJ) THEN
2220          WRITE(LOUT,'(A,E9.3,2A,E9.3,A)')
2221      &      ' Requested energy (',EPN,'GeV) exceeds',
2222      &      ' initialization energy (',EPROJ,'GeV) !'
2223          STOP
2224       ENDIF
2225
2226 * re-initialize /DTPRTA/
2227       IP  = NPMASS
2228       IPZ = NPCHAR
2229       IT  = NTMASS
2230       ITZ = NTCHAR
2231       IJPROJ = IDP
2232       IBPROJ = IIBAR(IJPROJ)
2233
2234 * calculate nuclear potentials (common /DTNPOT/)
2235       CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
2236
2237 * initialize treatment for residual nuclei
2238       CALL DT_RESNCL(EPN,NLOOP,1)
2239
2240 * sample hadron/nucleus-nucleus interaction
2241       CALL DT_KKEVNT(KKMAT,IREJ1)
2242       IF (IREJ1.GT.0) THEN
2243          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKINC'
2244          GOTO 9999
2245       ENDIF
2246
2247       IF ((NPMASS.GT.1).OR.(NTMASS.GT.1)) THEN
2248
2249 * intranuclear cascade of final state particles for KTAUGE generations
2250 * of secondaries
2251          CALL DT_FOZOCA(LFZC,IREJ1)
2252          IF (IREJ1.GT.0) THEN
2253             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKINC'
2254             GOTO 9999
2255          ENDIF
2256
2257 * baryons unable to escape the nuclear potential are treated as
2258 * excited nucleons (ISTHKK=15,16)
2259          CALL DT_SCN4BA
2260
2261 * decay of resonances produced in intranuclear cascade processes
2262 **sr 15-11-95 should be obsolete
2263 C        IF (LFZC) CALL DT_DECAY1
2264
2265   101    CONTINUE
2266 * treatment of residual nuclei
2267          CALL DT_RESNCL(EPN,NLOOP,2)
2268
2269 * evaporation / fission / fragmentation
2270 * (if intranuclear cascade was sampled only)
2271          IF (LFZC) THEN
2272             CALL DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ1)
2273             IF (IREJ1.GT.1) GOTO 101
2274             IF (IREJ1.EQ.1) GOTO 100
2275          ENDIF
2276
2277       ENDIF
2278
2279 * rejection of unphysical configurations
2280       CALL DT_REJUCO(1,IREJ1)
2281       IF (IREJ1.GT.0) THEN
2282          IF (IOULEV(1).GT.0)
2283      &      WRITE(LOUT,*) 'rejected 3 in KKINC: too large x'
2284          GOTO 100
2285       ENDIF
2286
2287 * transform finale state into Lab.
2288       IFLAG = 2
2289       CALL DT_BEAMPR(WHAT,DUM,IFLAG)
2290       IF ((IFRAME.EQ.1).AND.(IFLAG.EQ.-1)) CALL DT_LT2LAB
2291
2292       IF (IPI0.EQ.1) CALL DT_DECPI0
2293
2294 C     IF (NEVHKK.EQ.5) CALL DT_EVTOUT(4)
2295
2296       RETURN
2297  9999 CONTINUE
2298       IREJ = 1
2299       RETURN
2300       END
2301
2302 *$ CREATE DT_DEFAUL.FOR
2303 *COPY DT_DEFAUL
2304 *
2305 *===defaul=============================================================*
2306 *
2307       SUBROUTINE DT_DEFAUL(EPN,PPN)
2308
2309 ************************************************************************
2310 * Variables are set to default values.                                 *
2311 * This version dated 8.5.95 is written by S. Roesler.                  *
2312 ************************************************************************
2313
2314       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2315       SAVE
2316       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
2317       PARAMETER (TWOPI  = 6.283185307179586454D+00)
2318
2319 * particle properties (BAMJET index convention)
2320       CHARACTER*8  ANAME
2321       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2322      &                IICH(210),IIBAR(210),K1(210),K2(210)
2323 * nuclear potential
2324       LOGICAL LFERMI
2325       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
2326      &                EBINDP(2),EBINDN(2),EPOT(2,210),
2327      &                ETACOU(2),ICOUL,LFERMI
2328 * interface HADRIN-DPM
2329       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
2330 * central particle production, impact parameter biasing
2331       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
2332 * properties of interacting particles
2333       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2334 * properties of photon/lepton projectiles
2335       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2336       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2337 * emulsion treatment
2338       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2339      &                NCOMPO,IEMUL
2340 * parameter for intranuclear cascade
2341       LOGICAL LPAULI
2342       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
2343 * various options for treatment of partons (DTUNUC 1.x)
2344 * (chain recombination, Cronin,..)
2345       LOGICAL LCO2CR,LINTPT
2346       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
2347      &                LCO2CR,LINTPT
2348 * threshold values for x-sampling (DTUNUC 1.x)
2349       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
2350      &                SSMIMQ,VVMTHR
2351 * flags for input different options
2352       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2353       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2354      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2355 * n-n cross section fluctuations
2356       PARAMETER (NBINS = 1000)
2357       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
2358 * flags for particle decays
2359       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2360      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2361      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2362 * diquark-breaking mechanism
2363       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
2364 * nucleon-nucleon event-generator
2365       CHARACTER*8 CMODEL
2366       LOGICAL LPHOIN
2367       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2368 * flags for diffractive interactions (DTUNUC 1.x)
2369       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
2370 * VDM parameter for photon-nucleus interactions
2371       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
2372 * Glauber formalism: flags and parameters for statistics
2373       LOGICAL LPROD
2374       CHARACTER*8 CGLB
2375       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2376 * kinematical cuts for lepton-nucleus interactions
2377       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2378      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2379 * flags for activated histograms
2380       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2381 * cuts for variable energy runs
2382       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2383 * parameters for hA-diffraction
2384       COMMON /DTDIHA/ DIBETA,DIALPH
2385 * LEPTO
2386       REAL RPPN
2387       COMMON /LEPTOI/ RPPN,LEPIN,INTER
2388 * steering flags for qel neutrino scattering modules
2389       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
2390 * event flag
2391       COMMON /DTEVNO/ NEVENT,ICASCA
2392
2393       DATA POTMES /0.002D0/
2394
2395 * common /DTNPOT/
2396       DO 10 I=1,2
2397          PFERMP(I) = ZERO
2398          PFERMN(I) = ZERO
2399          EBINDP(I) = ZERO
2400          EBINDN(I) = ZERO
2401          DO 11 J=1,210
2402             EPOT(I,J) = ZERO
2403    11    CONTINUE
2404 * nucleus independent meson potential
2405          EPOT(I,13) = POTMES
2406          EPOT(I,14) = POTMES
2407          EPOT(I,15) = POTMES
2408          EPOT(I,16) = POTMES
2409          EPOT(I,23) = POTMES
2410          EPOT(I,24) = POTMES
2411          EPOT(I,25) = POTMES
2412    10 CONTINUE
2413       FERMOD    = 0.55D0
2414       ETACOU(1) = ZERO
2415       ETACOU(2) = ZERO
2416       ICOUL     = 1
2417       LFERMI    = .TRUE.
2418
2419 * common /HNTHRE/
2420       EHADTH = -99.0D0
2421       EHADLO = 4.06D0
2422       EHADHI = 6.0D0
2423       INTHAD = 1
2424       IDXTA  = 2
2425
2426 * common /DTIMPA/
2427       ICENTR = 0
2428       BIMIN  = ZERO
2429       BIMAX  = 1.0D10
2430       XSFRAC = 1.0D0
2431
2432 * common /DTPRTA/
2433       IP  = 1
2434       IPZ = 1
2435       IT  = 1
2436       ITZ = 1
2437       IJPROJ = 1
2438       IBPROJ = 1
2439       IJTARG = 1
2440       IBTARG = 1
2441 * common /DTGPRO/
2442       VIRT = ZERO
2443       DO 14 I=1,4
2444          PGAMM(I)  = ZERO
2445          PLEPT0(I) = ZERO
2446          PLEPT1(I) = ZERO
2447          PNUCL(I)  = ZERO
2448    14 CONTINUE
2449       IDIREC   = 0
2450
2451 * common /DTFOTI/
2452 **sr 7.4.98: changed after corrected B-sampling
2453 C     TAUFOR = 4.4D0
2454       TAUFOR = 3.5D0
2455       KTAUGE = 25
2456       ITAUVE = 1
2457       INCMOD = 1
2458       LPAULI = .TRUE.
2459
2460 * common /DTCHAI/
2461       SEASQ  = ONE
2462       MKCRON = 1
2463       CRONCO = 0.64D0
2464       ISICHA = 0
2465       CUTOF  = 100.0D0
2466       LCO2CR = .FALSE.
2467       IRECOM = 1
2468       LINTPT = .TRUE.
2469
2470 * common /DTXCUT/
2471 *  definition of soft quark distributions
2472       XSEACU = 0.05D0
2473       UNON   = 2.0D0
2474       UNOM   = 1.5D0
2475       UNOSEA = 5.0D0
2476 *  cutoff parameters for x-sampling
2477       CVQ    = 1.0D0
2478       CDQ    = 2.0D0
2479 C     CSEA   = 0.3D0
2480       CSEA   = 0.1D0
2481       SSMIMA = 1.2D0
2482       SSMIMQ = SSMIMA**2
2483       VVMTHR = 2.0D0
2484
2485 * common /DTXSFL/
2486       IFLUCT = 0
2487
2488 * common /DTFRPA/
2489       PDB = 0.15D0
2490       PDBSEA(1) = 0.0D0
2491       PDBSEA(2) = 0.0D0
2492       PDBSEA(3) = 0.0D0
2493       ISIG0 = 0
2494       IPI0  = 0
2495       NMSTU = 0
2496       NPARU = 0
2497       NMSTJ = 0
2498       NPARJ = 0
2499
2500 * common /DTDIQB/
2501       DO 15 I=1,8
2502          DBRKR(1,I) = 5.0D0
2503          DBRKR(2,I) = 5.0D0
2504          DBRKR(3,I) = 10.0D0
2505          DBRKA(1,I) = ZERO
2506          DBRKA(2,I) = ZERO
2507          DBRKA(3,I) = ZERO
2508    15 CONTINUE
2509       CHAM1 = 0.2D0
2510       CHAM3 = 0.5D0
2511       CHAB1 = 0.7D0
2512       CHAB3 = 1.0D0
2513
2514 * common /DTFLG3/
2515       ISINGD = 0
2516       IDOUBD = 0
2517       IFLAGD = 0
2518       IDIFF  = 0
2519
2520 * common /DTMODL/
2521       MCGENE    = 2
2522       CMODEL(1) = 'DTUNUC  '
2523       CMODEL(2) = 'PHOJET  '
2524       CMODEL(3) = 'LEPTO   '
2525       CMODEL(4) = 'QNEUTRIN'
2526       LPHOIN    = .TRUE.
2527       ELOJET    = 5.0D0
2528
2529 * common /DTLCUT/
2530       ECMIN  = 3.5D0
2531       ECMAX  = 1.0D10
2532       XBJMIN = ZERO
2533       ELMIN = ZERO
2534       EGMIN = ZERO
2535       EGMAX = 1.0D10
2536       YMIN  = TINY10
2537       YMAX  = 0.999D0
2538       Q2MIN = TINY10
2539       Q2MAX = 10.0D0
2540       THMIN = ZERO
2541       THMAX = TWOPI
2542       Q2LI  = ZERO
2543       Q2HI  = 1.0D10
2544       ECMLI = ZERO
2545       ECMHI = 1.0D10
2546
2547 * common /DTVDMP/
2548       RL2       = 2.0D0
2549       INTRGE(1) = 1
2550       INTRGE(2) = 3
2551       IDPDF     = 2212
2552       MODEGA    = 4
2553       ISHAD(1)  = 1
2554       ISHAD(2)  = 1
2555       ISHAD(3)  = 1
2556       EPSPOL    = ZERO
2557
2558 * common /DTGLGP/
2559       JSTATB = 1000
2560       JBINSB = 49
2561       CGLB   = '        '
2562       IF (ITRSPT.EQ.1) THEN
2563          IOGLB  = 100
2564       ELSE
2565          IOGLB  = 0
2566       ENDIF
2567       LPROD  = .TRUE.
2568
2569 * common /DTHIS3/
2570       DO 16 I=1,50
2571          IHISPP(I) = 0
2572          IHISXS(I) = 0
2573    16 CONTINUE
2574       IXSTBL = 0
2575
2576 * common /DTVARE/
2577       VARELO = ZERO
2578       VAREHI = ZERO
2579       VARCLO = ZERO
2580       VARCHI = ZERO
2581
2582 * common /DTDIHA/
2583       DIBETA = -1.0D0
2584       DIALPH = ZERO
2585
2586 * common /LEPTOI/
2587       RPPN  = 0.0
2588       LEPIN = 0
2589       INTER = 0
2590
2591 * common /QNEUTO/
2592       NEUTYP = 1
2593       NEUDEC = 0
2594
2595 * common /DTEVNO/
2596       NEVENT = 1
2597       IF (ITRSPT.EQ.1) THEN
2598          ICASCA = 1
2599       ELSE
2600          ICASCA = 0
2601       ENDIF
2602
2603 * default Lab.-energy
2604       EPN = 200.0D0
2605       PPN = SQRT((EPN-AAM(IJPROJ))*(EPN+AAM(IJPROJ)))
2606
2607       RETURN
2608       END
2609
2610 *$ CREATE DT_AAEVT.FOR
2611 *COPY DT_AAEVT
2612 *
2613 *===aaevt==============================================================*
2614 *
2615       SUBROUTINE DT_AAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2616      &                                             IDP,IGLAU)
2617
2618 ************************************************************************
2619 * This version dated 22.03.96 is written by S. Roesler.                *
2620 ************************************************************************
2621
2622       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2623       SAVE
2624       PARAMETER ( LINP = 10 ,
2625      &            LOUT = 6 ,
2626      &            LDAT = 9 )
2627
2628       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2629 * emulsion treatment
2630       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2631      &                NCOMPO,IEMUL
2632 * event flag
2633       COMMON /DTEVNO/ NEVENT,ICASCA
2634
2635       CHARACTER*8 DATE,HHMMSS
2636       DIMENSION IDMNYR(3)
2637
2638       KKMAT  = 1
2639       NMSG   = MAX(NEVTS/100,1)
2640
2641 * initialization of run-statistics and histograms
2642       CALL DT_STATIS(1)
2643       CALL PHO_PHIST(1000,DUM)
2644
2645 * initialization of Glauber-formalism
2646       IF (NCOMPO.LE.0) THEN
2647          CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2648       ELSE
2649          DO 1 I=1,NCOMPO
2650             CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2651     1    CONTINUE
2652       ENDIF
2653       CALL DT_SIGEMU
2654
2655       CALL IDATE(IDMNYR)
2656       WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2657      &   IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2658       CALL ITIME(IDMNYR)
2659       WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2660      &   IDMNYR(1),IDMNYR(2),IDMNYR(3)
2661       WRITE(LOUT,1001) DATE,HHMMSS
2662  1001 FORMAT(/,' DT_AAEVT: Initialisation finished. ( Date: ',A8,
2663      &       '   Time: ',A8,' )')
2664
2665 * generate NEVTS events
2666       DO 2 IEVT=1,NEVTS
2667
2668 *  print run-status message
2669          IF (MOD(IEVT,NMSG).EQ.0) THEN
2670             CALL IDATE(IDMNYR)
2671             WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2672      &         IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2673             CALL ITIME(IDMNYR)
2674             WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2675      &         IDMNYR(1),IDMNYR(2),IDMNYR(3)
2676             WRITE(LOUT,1000) IEVT-1,NEVTS,DATE,HHMMSS
2677  1000       FORMAT(/,1X,I8,' out of ',I8,' events sampled ( Date: ',A,
2678      &             '   Time: ',A,' )',/)
2679 C           WRITE(LOUT,1000) IEVT-1
2680 C1000       FORMAT(1X,I8,' events sampled')
2681          ENDIF
2682          NEVENT = IEVT
2683 *  treat nuclear emulsions
2684          IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
2685 *  composite targets only
2686          KKMAT = -KKMAT
2687 *  sample this event
2688          CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,IREJ)
2689
2690          CALL PHO_PHIST(2000,DUM)
2691
2692     2 CONTINUE
2693
2694 * print run-statistics and histograms to output-unit 6
2695       CALL PHO_PHIST(3000,DUM)
2696       CALL DT_STATIS(2)
2697
2698       RETURN
2699       END
2700
2701 *$ CREATE DT_LAEVT.FOR
2702 *COPY DT_LAEVT
2703 *
2704 *===laevt==============================================================*
2705 *
2706       SUBROUTINE DT_LAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2707      &                                             IDP,IGLAU)
2708
2709 ************************************************************************
2710 * Interface to run DPMJET for lepton-nucleus interactions.             *
2711 * Kinematics is sampled using the equivalent photon approximation      *
2712 * Based on GPHERA-routine by R. Engel.                                 *
2713 * This version dated 23.03.96 is written by S. Roesler.                *
2714 ************************************************************************
2715
2716       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2717       SAVE
2718       PARAMETER ( LINP = 10 ,
2719      &            LOUT = 6 ,
2720      &            LDAT = 9 )
2721       PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,
2722      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
2723       PARAMETER (TWOPI  = 6.283185307179586454D+00,
2724      &           PI     = TWOPI/TWO,
2725      &           ALPHEM = ONE/137.0D0)
2726
2727 C     CHARACTER*72 HEADER
2728
2729 * particle properties (BAMJET index convention)
2730       CHARACTER*8  ANAME
2731       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2732      &                IICH(210),IIBAR(210),K1(210),K2(210)
2733 * event history
2734       PARAMETER (NMXHKK=200000)
2735       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2736      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2737      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2738 * extended event history
2739       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2740      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2741      &                IHIST(2,NMXHKK)
2742 * kinematical cuts for lepton-nucleus interactions
2743       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2744      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2745 * properties of interacting particles
2746       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2747 * properties of photon/lepton projectiles
2748       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2749 * kinematics at lepton-gamma vertex
2750       COMMON /DTLGVX/ PPL0(4),PPL1(4),PPG(4),PPA(4)
2751 * flags for activated histograms
2752       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2753       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2754 * emulsion treatment
2755       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2756      &                NCOMPO,IEMUL
2757 * Glauber formalism: cross sections
2758       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
2759      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
2760      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
2761      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
2762      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
2763      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
2764      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
2765      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
2766      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
2767      &                BSLOPE,NEBINI,NQBINI
2768 * nucleon-nucleon event-generator
2769       CHARACTER*8 CMODEL
2770       LOGICAL LPHOIN
2771       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2772 * flags for input different options
2773       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2774       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2775      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2776 * event flag
2777       COMMON /DTEVNO/ NEVENT,ICASCA
2778
2779       DIMENSION XDUMB(40),BGTA(4)
2780
2781 * LEPTO
2782       IF (MCGENE.EQ.3) THEN
2783          STOP ' This version does not contain LEPTO !'
2784       ENDIF
2785
2786       KKMAT  = 1
2787       NMSG   = MAX(NEVTS/10,1)
2788
2789 * mass of incident lepton
2790       AMLPT  = AAM(IDP)
2791       AMLPT2 = AMLPT**2
2792       IDPPDG = IDT_IPDGHA(IDP)
2793
2794 * consistency of kinematical limits
2795       Q2MIN  = MAX(Q2MIN,TINY10)
2796       Q2MAX  = MAX(Q2MAX,TINY10)
2797       YMIN   = MIN(MAX(YMIN,TINY10),0.999D0)
2798       YMAX   = MIN(MAX(YMAX,TINY10),0.999D0)
2799
2800 * total energy of the lepton-nucleon system
2801       PTOTLN = SQRT( (PLEPT0(1)+PNUCL(1))**2+(PLEPT0(2)+PNUCL(2))**2
2802      &                                      +(PLEPT0(3)+PNUCL(3))**2 )
2803       ETOTLN = PLEPT0(4)+PNUCL(4)
2804       ECMLN  = SQRT((ETOTLN-PTOTLN)*(ETOTLN+PTOTLN))
2805       ECMAX  = MIN(ECMAX,ECMLN)
2806       WRITE(LOUT,1003) ECMIN,ECMAX,YMIN,YMAX,Q2MIN,Q2MAX,EGMIN,
2807      &                 THMIN,THMAX,ELMIN
2808  1003 FORMAT(1X,'LAEVT:',16X,'kinematical cuts',/,22X,
2809      &       '------------------',/,9X,'W (min)   =',
2810      &       F7.1,' GeV    (max) =',F7.1,' GeV',/,9X,'y (min)   =',
2811      &       F7.3,8X,'(max) =',F7.3,/,9X,'Q^2 (min) =',F7.1,
2812      &       ' GeV^2  (max) =',F7.1,' GeV^2',/,' (Lab)   E_g (min) ='
2813      &       ,F7.1,' GeV',/,' (Lab) theta (min) =',F7.4,8X,'(max) =',
2814      &       F7.4,'   for E_lpt >',F7.1,' GeV',/)
2815
2816 * Lorentz-parameter for transf. into Lab
2817       BGTA(1) = PNUCL(1)/AAM(1)
2818       BGTA(2) = PNUCL(2)/AAM(1)
2819       BGTA(3) = PNUCL(3)/AAM(1)
2820       BGTA(4) = PNUCL(4)/AAM(1)
2821 * LT of incident lepton into Lab and dump it in DTEVT1
2822       CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
2823      &            PLEPT0(1),PLEPT0(2),PLEPT0(3),PLEPT0(4),
2824      &            PLTOT,PPL0(1),PPL0(2),PPL0(3),PPL0(4))
2825       CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
2826      &            PNUCL(1),PNUCL(2),PNUCL(3),PNUCL(4),
2827      &            PLTOT,PPA(1),PPA(2),PPA(3),PPA(4))
2828 * maximum energy of photon nucleon system
2829       PTOTGN = SQRT((YMAX*PPL0(1)+PPA(1))**2+(YMAX*PPL0(2)+PPA(2))**2
2830      &                                      +(YMAX*PPL0(3)+PPA(3))**2)
2831       ETOTGN = YMAX*PPL0(4)+PPA(4)
2832       EGNMAX = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
2833       EGNMAX = MIN(EGNMAX,ECMAX)
2834 * minimum energy of photon nucleon system
2835       PTOTGN = SQRT((YMIN*PPL0(1)+PPA(1))**2+(YMIN*PPL0(2)+PPA(2))**2
2836      &                                      +(YMIN*PPL0(3)+PPA(3))**2)
2837       ETOTGN = YMIN*PPL0(4)+PPA(4)
2838       EGNMIN = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
2839       EGNMIN = MAX(EGNMIN,ECMIN)
2840
2841 * limits for Glauber-initialization
2842       Q2LI  = Q2MIN
2843       Q2HI  = MAX(Q2LI,MIN(Q2HI,Q2MAX))
2844       ECMLI = MAX(EGNMIN,THREE)
2845       ECMHI = EGNMAX
2846       WRITE(LOUT,1004) EGNMIN,EGNMAX,ECMLI,ECMHI,Q2LI,Q2HI
2847  1004 FORMAT(1X,'resulting limits:',/,9X,'W (min)   =',F7.1,
2848      &       ' GeV    (max) =',F7.1,' GeV',/,/,' limits for ',
2849      &       'Glauber-initialization:',/,9X,'W (min)   =',F7.1,
2850      &       ' GeV    (max) =',F7.1,' GeV',/,9X,'Q^2 (min) =',F7.1,
2851      &       ' GeV^2  (max) =',F7.1,' GeV^2',/)
2852 * initialization of Glauber-formalism
2853       IF (NCOMPO.LE.0) THEN
2854          CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2855       ELSE
2856          DO 9 I=1,NCOMPO
2857             CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2858     9    CONTINUE
2859       ENDIF
2860       CALL DT_SIGEMU
2861
2862 * initialization of run-statistics and histograms
2863       CALL DT_STATIS(1)
2864       CALL PHO_PHIST(1000,DUM)
2865
2866 * maximum photon-nucleus cross section
2867       I1  = 1
2868       I2  = 1
2869       RAT = ONE
2870       IF (EGNMAX.GE.ECMNN(NEBINI)) THEN
2871          I1  = NEBINI
2872          I2  = NEBINI
2873          RAT = ONE
2874       ELSEIF (EGNMAX.GT.ECMNN(1)) THEN
2875          DO 5 I=2,NEBINI
2876             IF (EGNMAX.LT.ECMNN(I)) THEN
2877                I1  = I-1
2878                I2  = I
2879                RAT = (EGNMAX-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
2880                GOTO 6
2881             ENDIF
2882     5    CONTINUE
2883     6    CONTINUE
2884       ENDIF
2885       SIGMAX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
2886       EGNXX  = EGNMAX
2887       I1  = 1
2888       I2  = 1
2889       RAT = ONE
2890       IF (EGNMIN.GE.ECMNN(NEBINI)) THEN
2891          I1  = NEBINI
2892          I2  = NEBINI
2893          RAT = ONE
2894       ELSEIF (EGNMIN.GT.ECMNN(1)) THEN
2895          DO 7 I=2,NEBINI
2896             IF (EGNMIN.LT.ECMNN(I)) THEN
2897                I1  = I-1
2898                I2  = I
2899                RAT = (EGNMIN-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
2900                GOTO 8
2901             ENDIF
2902     7    CONTINUE
2903     8    CONTINUE
2904       ENDIF
2905       SIGXX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
2906       IF (SIGXX.GT.SIGMAX) EGNXX = EGNMIN
2907       SIGMAX = MAX(SIGMAX,SIGXX)
2908       WRITE(LOUT,'(9X,A,F8.3,A)') 'Sigma_tot (max) =',SIGMAX,' mb'
2909
2910 * plot photon flux table
2911       AYMIN = LOG(YMIN)
2912       AYMAX = LOG(YMAX)
2913       AYRGE = AYMAX-AYMIN
2914       MAXTAB = 50
2915       ADY    = LOG(YMAX/YMIN)/DBLE(MAXTAB-1)
2916 C     WRITE(LOUT,'(/,1X,A)') 'LAEVT:   photon flux '
2917       DO 1 I=1,MAXTAB
2918          Y     = EXP(AYMIN+ADY*DBLE(I-1))
2919          Q2LOW = MAX(Q2MIN,AMLPT2*Y**2/(ONE-Y))
2920          FF1   = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2921      &                           -TWO*AMLPT2*Y*(ONE/Q2LOW-ONE/Q2MAX))
2922          FF2   = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
2923      &                           -TWO*(ONE-Y)/Y*(ONE-Q2LOW/Q2MAX))
2924 C        WRITE(LOUT,'(5X,3E15.4)') Y,FF1,FF2
2925     1 CONTINUE
2926
2927 * maximum residual weight for flux sampling (dy/y)
2928       YY     = YMIN
2929       Q2LOW  = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
2930       WGHMAX = (ONE+(ONE-YY)**2)*LOG(Q2MAX/Q2LOW)
2931      &         -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
2932
2933       CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY0)
2934       CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY1)
2935       CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY2)
2936       CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ0)
2937       CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ1)
2938       CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ2)
2939       CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE0)
2940       CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE1)
2941       CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE2)
2942       CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU0)
2943       CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU1)
2944       CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU2)
2945       XBLOW = 0.001D0
2946       CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX0)
2947       CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX1)
2948       CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX2)
2949
2950       ITRY = 0
2951       ITRW = 0
2952       NC0  = 0
2953       NC1  = 0
2954
2955 * generate events
2956       DO 2 IEVT=1,NEVTS
2957          IF (MOD(IEVT,NMSG).EQ.0) THEN
2958 C           OPEN(LDAT,FILE='/scrtch3/hr/sroesler/statusd5.out',
2959 C    &                                         STATUS='UNKNOWN')
2960             WRITE(LOUT,'(1X,I8,A)') IEVT-1,' events sampled'
2961 C           CLOSE(LDAT)
2962          ENDIF
2963          NEVENT = IEVT
2964
2965   100    CONTINUE
2966          ITRY = ITRY+1
2967
2968 *  sample y
2969   101    CONTINUE
2970          ITRW  = ITRW+1
2971          YY    = EXP(AYRGE*DT_RNDM(RAT)+AYMIN)
2972          Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
2973          Q2LOG = LOG(Q2MAX/Q2LOW)
2974          WGH   = (ONE+(ONE-YY)**2)*Q2LOG
2975      &           -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
2976          IF (WGHMAX.LT.WGH) WRITE(LOUT,1000) YY,WGHMAX,WGH
2977  1000    FORMAT(1X,'LAEVT:   weight error!',3E12.5)
2978          IF (DT_RNDM(YY)*WGHMAX.GT.WGH) GOTO 101
2979
2980 *  sample Q2
2981          YEFF = ONE+(ONE-YY)**2
2982   102    CONTINUE
2983          Q2  = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
2984          WGH = (YEFF-TWO*(ONE-YY)*Q2LOW/Q2)/YEFF
2985          IF (WGH.LT.DT_RNDM(Q2)) GOTO 102
2986
2987 c        NC0 = NC0+1
2988 c        CALL DT_FILHGR(YY,ONE,IHFLY0,NC0)
2989 c        CALL DT_FILHGR(Q2,ONE,IHFLQ0,NC0)
2990
2991 *  kinematics at lepton-photon vertex
2992 *   scattered electron
2993          YQ2 = SQRT((ONE-YY)*Q2)
2994          Q2E = Q2/(4.0D0*PLEPT0(4))
2995          E1Y = (ONE-YY)*PLEPT0(4)
2996          CALL DT_DSFECF(SIF,COF)
2997          PLEPT1(1) = YQ2*COF
2998          PLEPT1(2) = YQ2*SIF
2999          PLEPT1(3) = E1Y-Q2E
3000          PLEPT1(4) = E1Y+Q2E
3001 C        THETA = ACOS( (E1Y-Q2E)/(E1Y+Q2E) )
3002 *   radiated photon
3003          PGAMM(1) = -PLEPT1(1)
3004          PGAMM(2) = -PLEPT1(2)
3005          PGAMM(3) = PLEPT0(3)-PLEPT1(3)
3006          PGAMM(4) = PLEPT0(4)-PLEPT1(4)
3007 *   E_cm cut
3008          PTOTGN = SQRT( (PGAMM(1)+PNUCL(1))**2+(PGAMM(2)+PNUCL(2))**2
3009      &                                        +(PGAMM(3)+PNUCL(3))**2 )
3010          ETOTGN = PGAMM(4)+PNUCL(4)
3011          ECMGN  = (ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)
3012          IF (ECMGN.LT.0.1D0) GOTO 101
3013          ECMGN  = SQRT(ECMGN)
3014          IF ((ECMGN.LT.ECMIN).OR.(ECMGN.GT.ECMAX)) GOTO 101
3015
3016 *  Lorentz-transformation into nucleon-rest system
3017          CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3018      &               PGAMM(1),PGAMM(2),PGAMM(3),PGAMM(4),
3019      &               PGTOT,PPG(1),PPG(2),PPG(3),PPG(4))
3020          CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3021      &               PLEPT1(1),PLEPT1(2),PLEPT1(3),PLEPT1(4),
3022      &               PLTOT,PPL1(1),PPL1(2),PPL1(3),PPL1(4))
3023 *  temporary checks..
3024          Q2TMP = ABS(PPG(4)**2-PGTOT**2)
3025          IF (ABS(Q2-Q2TMP).GT.0.01D0) WRITE(LOUT,1001) Q2,Q2TMP
3026  1001    FORMAT(1X,'LAEVT:    inconsistent kinematics (Q2,Q2TMP) ',
3027      &          2F10.4)
3028          ECMTMP = SQRT((PPG(4)+AAM(1)-PGTOT)*(PPG(4)+AAM(1)+PGTOT))
3029          IF (ABS(ECMGN-ECMTMP).GT.TINY10) WRITE(LOUT,1002) ECMGN,ECMTMP
3030  1002    FORMAT(1X,'LAEVT:    inconsistent kinematics (ECMGN,ECMTMP) ',
3031      &          2F10.2)
3032          YYTMP = PPG(4)/PPL0(4)
3033          IF (ABS(YY-YYTMP).GT.0.01D0) WRITE(LOUT,1005) YY,YYTMP
3034  1005    FORMAT(1X,'LAEVT:    inconsistent kinematics (YY,YYTMP) ',
3035      &          2F10.4)
3036
3037 *  lepton tagger (Lab)
3038          THETA = ACOS( PPL1(3)/PLTOT )
3039          IF (PPL1(4).GT.ELMIN) THEN
3040             IF ((THETA.LT.THMIN).OR.(THETA.GT.THMAX)) GOTO 101
3041          ENDIF
3042 *  photon energy-cut (Lab)
3043          IF (PPG(4).LT.EGMIN) GOTO 101
3044          IF (PPG(4).GT.EGMAX) GOTO 101
3045 *   x_Bj cut
3046          XBJ = ABS(Q2/(1.876D0*PPG(4)))
3047          IF (XBJ.LT.XBJMIN) GOTO 101
3048
3049          NC0 = NC0+1
3050          CALL DT_FILHGR(    Q2,ONE,IHFLQ0,NC0)
3051          CALL DT_FILHGR(    YY,ONE,IHFLY0,NC0)
3052          CALL DT_FILHGR(   XBJ,ONE,IHFLX0,NC0)
3053          CALL DT_FILHGR(PPG(4),ONE,IHFLU0,NC0)
3054          CALL DT_FILHGR( ECMGN,ONE,IHFLE0,NC0)
3055
3056 *  rotation angles against z-axis
3057          COD = PPG(3)/PGTOT
3058 C        SID = SQRT((ONE-COD)*(ONE+COD))
3059          PPT = SQRT(PPG(1)**2+PPG(2)**2)
3060          SID = PPT/PGTOT
3061          COF = ONE
3062          SIF = ZERO
3063          IF (PGTOT*SID.GT.TINY10) THEN
3064             COF   = PPG(1)/(SID*PGTOT)
3065             SIF   = PPG(2)/(SID*PGTOT)
3066             ANORF = SQRT(COF*COF+SIF*SIF)
3067             COF   = COF/ANORF
3068             SIF   = SIF/ANORF
3069          ENDIF
3070
3071          IF (IXSTBL.EQ.0) THEN
3072 *  change to photon projectile
3073             IJPROJ = 7
3074 *  set virtuality
3075             VIRT = Q2
3076 *  re-initialize LTs with new kinematics
3077 *  !!PGAMM ist set in cms (ECMGN) along z
3078             EPN = ZERO
3079             PPN = ZERO
3080             CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,ECMGN,0)
3081 *  force Lab-system
3082             IFRAME = 1
3083 *  get emulsion component if requested
3084             IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
3085 *  convolute with cross section
3086             CALL DT_SIGGAT(Q2LOW,EGNXX,STOTX,KKMAT)
3087             CALL DT_SIGGAT(Q2,ECMGN,STOT,KKMAT)
3088             IF (STOTX.LT.STOT) WRITE(LOUT,'(1X,A,/,6E12.3)')
3089      &         'LAEVT: warning STOTX<STOT ! ',Q2LOW,EGNMAX,STOTX,
3090      &                                        Q2,ECMGN,STOT
3091             IF (DT_RNDM(Q2)*STOTX.GT.STOT) GOTO 100
3092             NC1 = NC1+1
3093             CALL DT_FILHGR(    Q2,ONE,IHFLQ1,NC1)
3094             CALL DT_FILHGR(    YY,ONE,IHFLY1,NC1)
3095             CALL DT_FILHGR(   XBJ,ONE,IHFLX1,NC1)
3096             CALL DT_FILHGR(PPG(4),ONE,IHFLU1,NC1)
3097             CALL DT_FILHGR( ECMGN,ONE,IHFLE1,NC1)
3098 *  composite targets only
3099             KKMAT = -KKMAT
3100 *  sample this event
3101             CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IJPROJ,EPN,KKMAT,
3102      &                                                            IREJ)
3103 *  rotate momenta of final state particles back in photon-nucleon syst.
3104             DO 4 I=NPOINT(4),NHKK
3105                IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
3106      &                                      (ISTHKK(I).EQ.1001)) THEN
3107                   PX = PHKK(1,I)
3108                   PY = PHKK(2,I)
3109                   PZ = PHKK(3,I)
3110                   CALL DT_MYTRAN(1,PX,PY,PZ,COD,SID,COF,SIF,
3111      &                        PHKK(1,I),PHKK(2,I),PHKK(3,I))
3112                ENDIF
3113     4       CONTINUE
3114          ENDIF
3115
3116          CALL DT_FILHGR(    Q2,ONE,IHFLQ2,NC1)
3117          CALL DT_FILHGR(    YY,ONE,IHFLY2,NC1)
3118          CALL DT_FILHGR(   XBJ,ONE,IHFLX2,NC1)
3119          CALL DT_FILHGR(PPG(4),ONE,IHFLU2,NC1)
3120          CALL DT_FILHGR( ECMGN,ONE,IHFLE2,NC1)
3121
3122 *  dump this event to histograms
3123          CALL PHO_PHIST(2000,DUM)
3124
3125     2 CONTINUE
3126
3127       WGY    = ALPHEM/TWOPI*WGHMAX*DBLE(ITRY)/DBLE(ITRW)
3128       WGY    = WGY*LOG(YMAX/YMIN)
3129       WEIGHT = WGY*SIGMAX*DBLE(NEVTS)/DBLE(ITRY)
3130
3131 C     HEADER = ' LAEVT:  Q^2 distribution 0'
3132 C     CALL DT_OUTHGR(IHFLQ0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3133 C     HEADER = ' LAEVT:  Q^2 distribution 1'
3134 C     CALL DT_OUTHGR(IHFLQ1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3135 C     HEADER = ' LAEVT:  Q^2 distribution 2'
3136 C     CALL DT_OUTHGR(IHFLQ2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3137 C     HEADER = ' LAEVT:  y   distribution 0'
3138 C     CALL DT_OUTHGR(IHFLY0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3139 C     HEADER = ' LAEVT:  y   distribution 1'
3140 C     CALL DT_OUTHGR(IHFLY1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3141 C     HEADER = ' LAEVT:  y   distribution 2'
3142 C     CALL DT_OUTHGR(IHFLY2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3143 C     HEADER = ' LAEVT:  x   distribution 0'
3144 C     CALL DT_OUTHGR(IHFLX0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3145 C     HEADER = ' LAEVT:  x   distribution 1'
3146 C     CALL DT_OUTHGR(IHFLX1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3147 C     HEADER = ' LAEVT:  x   distribution 2'
3148 C     CALL DT_OUTHGR(IHFLX2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3149 C     HEADER = ' LAEVT:  E_g distribution 0'
3150 C     CALL DT_OUTHGR(IHFLU0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3151 C     HEADER = ' LAEVT:  E_g distribution 1'
3152 C     CALL DT_OUTHGR(IHFLU1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3153 C     HEADER = ' LAEVT:  E_g distribution 2'
3154 C     CALL DT_OUTHGR(IHFLU2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3155 C     HEADER = ' LAEVT:  E_c distribution 0'
3156 C     CALL DT_OUTHGR(IHFLE0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3157 C     HEADER = ' LAEVT:  E_c distribution 1'
3158 C     CALL DT_OUTHGR(IHFLE1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3159 C     HEADER = ' LAEVT:  E_c distribution 2'
3160 C     CALL DT_OUTHGR(IHFLE2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3161
3162 * print run-statistics and histograms to output-unit 6
3163       CALL PHO_PHIST(3000,DUM)
3164       IF (IXSTBL.EQ.0) CALL DT_STATIS(2)
3165
3166       RETURN
3167       END
3168
3169 *$ CREATE DT_DTUINI.FOR
3170 *COPY DT_DTUINI
3171 *
3172 *===dtuini=============================================================*
3173 *
3174       SUBROUTINE DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
3175      &                                               IDP,IEMU)
3176
3177       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3178       SAVE
3179
3180       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
3181 * emulsion treatment
3182       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
3183      &                NCOMPO,IEMUL
3184 * Glauber formalism: flags and parameters for statistics
3185       LOGICAL LPROD
3186       CHARACTER*8 CGLB
3187       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
3188
3189       CALL DT_INIT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IGLAU)
3190       CALL DT_STATIS(1)
3191       CALL PHO_PHIST(1000,DUM)
3192       IF (NCOMPO.LE.0) THEN
3193          CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
3194       ELSE
3195          DO 1 I=1,NCOMPO
3196             CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
3197     1    CONTINUE
3198       ENDIF
3199       IF (IOGLB.NE.100) CALL DT_SIGEMU
3200       IEMU = IEMUL
3201
3202       RETURN
3203       END
3204
3205 *$ CREATE DT_DTUOUT.FOR
3206 *COPY DT_DTUOUT
3207 *
3208 *===dtuout=============================================================*
3209 *
3210       SUBROUTINE DT_DTUOUT
3211
3212       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3213       SAVE
3214
3215       CALL PHO_PHIST(3000,DUM)
3216       CALL DT_STATIS(2)
3217
3218       RETURN
3219       END
3220
3221 *$ CREATE DT_BEAMPR.FOR
3222 *COPY DT_BEAMPR
3223 *
3224 *===beampr=============================================================*
3225 *
3226       SUBROUTINE DT_BEAMPR(WHAT,PLAB,MODE)
3227
3228 ************************************************************************
3229 * Initialization of event generation                                   *
3230 * This version dated  7.4.98  is written by S. Roesler.                *
3231 ************************************************************************
3232
3233       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3234       SAVE
3235
3236       PARAMETER ( LINP = 10 ,
3237      &            LOUT = 6 ,
3238      &            LDAT = 9 )
3239       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3240       PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3241
3242       LOGICAL LBEAM
3243
3244 * event history
3245       PARAMETER (NMXHKK=200000)
3246       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3247      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3248      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3249 * extended event history
3250       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3251      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3252      &                IHIST(2,NMXHKK)
3253 * properties of interacting particles
3254       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3255 * particle properties (BAMJET index convention)
3256       CHARACTER*8  ANAME
3257       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3258      &                IICH(210),IIBAR(210),K1(210),K2(210)
3259 * beam momenta
3260       COMMON /DTBEAM/ P1(4),P2(4)
3261
3262 C     DIMENSION WHAT(6),P1(4),P2(4),P1CMS(4),P2CMS(4)
3263       DIMENSION WHAT(6),P1CMS(4),P2CMS(4)
3264
3265       DATA LBEAM /.FALSE./
3266
3267       GOTO (1,2) MODE
3268
3269     1 CONTINUE
3270
3271       E1  = WHAT(1)
3272       IF (E1.LT.ZERO) E1 = DBLE(IPZ)/DBLE(IP)*ABS(WHAT(1))
3273       E2  = WHAT(2)
3274       IF (E2.LT.ZERO) E2 = DBLE(ITZ)/DBLE(IT)*ABS(WHAT(2))
3275       PP1 = SQRT( (E1+AAM(IJPROJ))*(E1-AAM(IJPROJ)) )
3276       PP2 = SQRT( (E2+AAM(IJTARG))*(E2-AAM(IJTARG)) )
3277       TH  = 1.D-6*WHAT(3)/2.D0
3278       PH  = WHAT(4)*BOG
3279       P1(1) = PP1*SIN(TH)*COS(PH)
3280       P1(2) = PP1*SIN(TH)*SIN(PH)
3281       P1(3) = PP1*COS(TH)
3282       P1(4) = E1
3283       P2(1) = PP2*SIN(TH)*COS(PH)
3284       P2(2) = PP2*SIN(TH)*SIN(PH)
3285       P2(3) = -PP2*COS(TH)
3286       P2(4) = E2
3287       ECM  = SQRT( (P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
3288      &                                              -(P1(3)+P2(3))**2 )
3289       ELAB = (ECM**2-AAM(IJPROJ)**2-AAM(IJTARG)**2)/(2.0D0*AAM(IJTARG))
3290       PLAB = SQRT( (ELAB+AAM(IJPROJ))*(ELAB-AAM(IJPROJ)) )
3291       BGX  = (P1(1)+P2(1))/ECM
3292       BGY  = (P1(2)+P2(2))/ECM
3293       BGZ  = (P1(3)+P2(3))/ECM
3294       BGE  = (P1(4)+P2(4))/ECM
3295       CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P1(1),P1(2),P1(3),P1(4),
3296      &            P1TOT,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4))
3297       CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P2(1),P2(2),P2(3),P2(4),
3298      &            P2TOT,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4))
3299       COD = P1CMS(3)/P1TOT
3300 C     SID = SQRT((ONE-COD)*(ONE+COD))
3301       PPT = SQRT(P1CMS(1)**2+P1CMS(2)**2)
3302       SID = PPT/P1TOT
3303       COF = ONE
3304       SIF = ZERO
3305       IF (P1TOT*SID.GT.TINY10) THEN
3306          COF   = P1CMS(1)/(SID*P1TOT)
3307          SIF   = P1CMS(2)/(SID*P1TOT)
3308          ANORF = SQRT(COF*COF+SIF*SIF)
3309          COF   = COF/ANORF
3310          SIF   = SIF/ANORF
3311       ENDIF
3312 **check
3313 C     WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3314 C     WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3315 C     WRITE(LOUT,'(5E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),P1TOT
3316 C     WRITE(LOUT,'(5E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),P2TOT
3317 C     PAX = ZERO
3318 C     PAY = ZERO
3319 C     PAZ = P1TOT
3320 C     PAE = SQRT(AAM(IJPROJ)**2+PAZ**2)
3321 C     PBX = ZERO
3322 C     PBY = ZERO
3323 C     PBZ = -P2TOT
3324 C     PBE = SQRT(AAM(IJTARG)**2+PBZ**2)
3325 C     WRITE(LOUT,'(4E15.4)') PAX,PAY,PAZ,PAE
3326 C     WRITE(LOUT,'(4E15.4)') PBX,PBY,PBZ,PBE
3327 C     CALL DT_MYTRAN(1,PAX,PAY,PAZ,COD,SID,COF,SIF,
3328 C    &            P1CMS(1),P1CMS(2),P1CMS(3))
3329 C     CALL DT_MYTRAN(1,PBX,PBY,PBZ,COD,SID,COF,SIF,
3330 C    &            P2CMS(1),P2CMS(2),P2CMS(3))
3331 C     WRITE(LOUT,'(4E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4)
3332 C     WRITE(LOUT,'(4E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4)
3333 C     CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),
3334 C    &            P1TOT,P1(1),P1(2),P1(3),P1(4))
3335 C     CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),
3336 C    &            P2TOT,P2(1),P2(2),P2(3),P2(4))
3337 C     WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3338 C     WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3339 C     STOP
3340 **
3341
3342       LBEAM = .TRUE.
3343
3344       RETURN
3345
3346     2 CONTINUE
3347
3348       IF (LBEAM) THEN
3349          IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3350          DO 20 I=NPOINT(4),NHKK
3351             IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
3352      &                                   (ISTHKK(I).EQ.1001)) THEN
3353                CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I),
3354      &                     COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS)
3355                PECMS = PHKK(4,I)
3356                CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS,
3357      &                     PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I))
3358             ENDIF
3359    20    CONTINUE
3360       ELSE
3361          MODE = -1
3362       ENDIF
3363
3364       RETURN
3365       END
3366
3367 *$ CREATE DT_REJUCO.FOR
3368 *COPY DT_REJUCO
3369 *
3370 *===rejuco=============================================================*
3371 *
3372       SUBROUTINE DT_REJUCO(MODE,IREJ)
3373
3374 ************************************************************************
3375 * REJection of Unphysical COnfigurations                               *
3376 *     MODE = 1  rejection of particles with unphysically large energy  *
3377 *                                                                      *
3378 * This version dated 27.12.2006 is written by S. Roesler.              *
3379 ************************************************************************
3380
3381       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3382       SAVE
3383
3384       PARAMETER ( LINP = 10 ,
3385      &            LOUT = 6 ,
3386      &            LDAT = 9 )
3387       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3388       PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3389
3390 * maximum x_cms of final state particle
3391       PARAMETER (XCMSMX = 1.4D0)
3392
3393 * event history
3394       PARAMETER (NMXHKK=200000)
3395       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3396      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3397      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3398 * extended event history
3399       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3400      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3401      &                IHIST(2,NMXHKK)
3402 * Lorentz-parameters of the current interaction
3403       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
3404      &                UMO,PPCM,EPROJ,PPROJ
3405
3406       IREJ = 0
3407
3408       IF (MODE.EQ.1) THEN
3409          IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3410          ECMHLF = UMO/2.0D0
3411          DO 10 I=NPOINT(4),NHKK
3412             IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDHKK(I).NE.80000)) THEN
3413                XCMS = ABS(PHKK(4,I))/ECMHLF
3414                IF (XCMS.GT.XCMSMX) GOTO 9999
3415             ENDIF
3416    10    CONTINUE
3417       ENDIF
3418
3419       RETURN
3420  9999 CONTINUE
3421       IREJ = 1
3422       RETURN
3423       END
3424
3425 *$ CREATE DT_EVENTB.FOR
3426 *COPY DT_EVENTB
3427 *
3428 *===eventb=============================================================*
3429 *
3430       SUBROUTINE DT_EVENTB(NCSY,IREJ)
3431
3432 ************************************************************************
3433 * Treatment of nucleon-nucleon interactions with full two-component    *
3434 * Dual Parton Model.                                                   *
3435 *          NCSY     number of nucleon-nucleon interactions             *
3436 *          IREJ     rejection flag                                     *
3437 * This version dated 14.01.2000 is written by S. Roesler               *
3438 ************************************************************************
3439
3440       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3441       SAVE
3442       PARAMETER ( LINP = 10 ,
3443      &            LOUT = 6 ,
3444      &            LDAT = 9 )
3445       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
3446
3447 * event history
3448       PARAMETER (NMXHKK=200000)
3449       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3450      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3451      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3452 * extended event history
3453       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3454      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3455      &                IHIST(2,NMXHKK)
3456 *! uncomment this line for internal phojet-fragmentation
3457 C #include "dtu_dtevtp.inc"
3458 * particle properties (BAMJET index convention)
3459       CHARACTER*8  ANAME
3460       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3461      &                IICH(210),IIBAR(210),K1(210),K2(210)
3462 * flags for input different options
3463       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
3464       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
3465      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
3466 * rejection counter
3467       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
3468      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
3469      &                IREXCI(3),IRDIFF(2),IRINC
3470 * properties of interacting particles
3471       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3472 * properties of photon/lepton projectiles
3473       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
3474 * various options for treatment of partons (DTUNUC 1.x)
3475 * (chain recombination, Cronin,..)
3476       LOGICAL LCO2CR,LINTPT
3477       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
3478      &                LCO2CR,LINTPT
3479 * statistics
3480       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
3481      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
3482      &                ICEVTG(8,0:30)
3483 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
3484       COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
3485 * Glauber formalism: collision properties
3486       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
3487      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
3488 * flags for diffractive interactions (DTUNUC 1.x)
3489       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
3490 * statistics: double-Pomeron exchange
3491       COMMON /DTFLG2/ INTFLG,IPOPO
3492 * flags for particle decays
3493       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
3494      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
3495      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
3496 * nucleon-nucleon event-generator
3497       CHARACTER*8 CMODEL
3498       LOGICAL LPHOIN
3499       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
3500 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
3501       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
3502       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
3503       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
3504      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
3505 C  model switches and parameters
3506       CHARACTER*8 MDLNA
3507       INTEGER ISWMDL,IPAMDL
3508       DOUBLE PRECISION PARMDL
3509       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3510 C  initial state parton radiation (internal part)
3511       INTEGER MXISR3,MXISR4
3512       PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
3513       INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
3514       DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
3515       COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
3516      &                ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
3517      &                IFL1(2,MXISR3),IFL2(2,MXISR3),
3518      &                IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
3519 C  event debugging information
3520       INTEGER NMAXD
3521       PARAMETER (NMAXD=100)
3522       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3523      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3524       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3525      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3526 C  general process information
3527       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3528       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3529
3530       DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4),
3531      &          PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4),
3532      &          PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4),
3533      &          KPRON(15),ISINGL(2000)
3534
3535 * initial values for max. number of phojet scatterings and dtunuc chains
3536 * to be fragmented with one pyexec call
3537       DATA MXPHFR,MXDTFR /10,100/
3538
3539       IREJ      = 0
3540 * pointer to first parton of the first chain in dtevt common
3541       NPOINT(3) = NHKK+1
3542 * special flag for double-Pomeron statistics
3543       IPOPO = 1
3544 * counter for low-mass (DTUNUC) interactions
3545       NDTUSC = 0
3546 * counter for interactions treated by PHOJET
3547       NPHOSC = 0
3548
3549 * scan interactions for single nucleon-nucleon interactions
3550 * (this has to be checked here because Cronin modifies parton momenta)
3551       NC = NPOINT(2)
3552       IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! '
3553       DO 8 I=1,NCSY
3554          ISINGL(I) = 0
3555          MOP = JMOHKK(1,NC)
3556          MOT = JMOHKK(1,NC+1)
3557          DIFF1 = ABS(PHKK(4,MOP)-PHKK(4,  NC)-PHKK(4,NC+2))
3558          DIFF2 = ABS(PHKK(4,MOT)-PHKK(4,NC+1)-PHKK(4,NC+3))
3559          IF ((DIFF1.LT.TINY10).AND.(DIFF2.LT.TINY10)) ISINGL(I) = 1
3560          NC = NC+4
3561     8 CONTINUE
3562
3563 * multiple scattering of chain ends
3564       IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
3565       IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
3566
3567 * switch to PHOJET-settings for JETSET parameter
3568       CALL DT_INITJS(1)
3569
3570 * loop over nucleon-nucleon interaction
3571       NC = NPOINT(2)
3572       DO 2 I=1,NCSY
3573 *
3574 *   pick up one nucleon-nucleon interaction from DTEVT1
3575 *     ppnn  / ptnn   - momenta of the interacting nucleons (cms)
3576 *     ptotnn         - total momentum of the interacting nucleons (cms)
3577 *     pp1,2 / pt1,2  - momenta of the four partons
3578 *     pp    / pt     - total momenta of the proj / targ partons
3579 *     ptot           - total momentum of the four partons
3580          MOP = JMOHKK(1,NC)
3581          MOT = JMOHKK(1,NC+1)
3582          DO 3 K=1,4
3583             PPNN(K)   = PHKK(K,MOP)
3584             PTNN(K)   = PHKK(K,MOT)
3585             PTOTNN(K) = PPNN(K)+PTNN(K)
3586             PP1(K)    = PHKK(K,NC)
3587             PT1(K)    = PHKK(K,NC+1)
3588             PP2(K)    = PHKK(K,NC+2)
3589             PT2(K)    = PHKK(K,NC+3)
3590             PP(K)     = PP1(K)+PP2(K)
3591             PT(K)     = PT1(K)+PT2(K)
3592             PTOT(K)   = PP(K)+PT(K)
3593     3    CONTINUE
3594 *
3595 *-----------------------------------------------------------------------
3596 *   this is a complete nucleon-nucleon interaction
3597 *
3598          IF (ISINGL(I).EQ.1) THEN
3599 *
3600 *     initialize PHOJET-variables for remnant/valence-partons
3601             IHFLD(1,1) = 0
3602             IHFLD(1,2) = 0
3603             IHFLD(2,1) = 0
3604             IHFLD(2,2) = 0
3605             IHFLS(1) = 1
3606             IHFLS(2) = 1
3607 *     save current settings of PHOJET process and min. bias flags
3608             DO 9 K=1,11
3609                KPRON(K) = IPRON(K,1)
3610     9       CONTINUE
3611             ISWSAV   = ISWMDL(2)
3612 *
3613 *     check if forced sampling of diffractive interaction requested
3614             IF (ISINGD.LT.-1) THEN
3615                DO 90 K=1,11
3616                   IPRON(K,1) = 0
3617    90          CONTINUE
3618                IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-3)) IPRON(5,1) = 1
3619                IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-4)) IPRON(6,1) = 1
3620                IF (ISINGD.EQ.-5) IPRON(4,1) = 1
3621             ENDIF
3622 *
3623 *     for photons: a direct/anomalous interaction is not sampled
3624 *     in PHOJET but already in Glauber-formalism. Here we check if such
3625 *     an interaction is requested
3626             IF (IJPROJ.EQ.7) THEN
3627 *       first switch off direct interactions
3628                IPRON(8,1) = 0
3629 *       this is a direct interactions
3630                IF (IDIREC.EQ.1) THEN
3631                   DO 12 K=1,11
3632                      IPRON(K,1) = 0
3633    12             CONTINUE
3634                   IPRON(8,1) = 1
3635 *       this is an anomalous interactions
3636 *         (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) )
3637                ELSEIF (IDIREC.EQ.2) THEN
3638                   ISWMDL(2) = 0
3639                ENDIF
3640             ELSE
3641                IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! '
3642             ENDIF
3643 *
3644 *     make sure that total momenta of partons, pp and pt, are on mass
3645 *     shell (Cronin may have srewed this up..)
3646             CALL DT_MASHEL(PP,PT,PHKK(5,MOP),PHKK(5,MOT),PPNN,PTNN,IR1)
3647             IF (IR1.NE.0) THEN
3648                IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)')
3649      &              'EVENTB:  mass shell correction rejected'
3650                GOTO 9999
3651             ENDIF
3652 *
3653 *     initialize the incoming particles in PHOJET
3654             IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3655                CALL PHO_SETPAR(1,22,0,VIRT)
3656             ELSE
3657                CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO)
3658             ENDIF
3659             CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO)
3660 *
3661 *     initialize rejection loop counter for anomalous processes
3662             IRJANO = 0
3663   800       CONTINUE
3664             IRJANO = IRJANO+1
3665 *
3666 *     temporary fix for ifano problem
3667             IFANO(1) = 0
3668             IFANO(2) = 0
3669 *
3670 *     generate complete hadron/nucleon/photon-nucleon event with PHOJET
3671             CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1)
3672 *
3673 *     for photons: special consistency check for anomalous interactions
3674             IF (IJPROJ.EQ.7) THEN
3675                IF (IRJANO.LT.30) THEN
3676                   IF (IFANO(1).NE.0) THEN
3677 *       here, an anomalous interaction was generated. Check if it
3678 *       was also requested. Otherwise reject this event.
3679                      IF (IDIREC.EQ.0) GOTO 800
3680                   ELSE
3681 *       here, an anomalous interaction was not generated. Check if it
3682 *       was requested in which case we need to reject this event.
3683                      IF (IDIREC.EQ.2) GOTO 800
3684                   ENDIF
3685                ELSE
3686                   WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ',
3687      &                          IRJANO,IDIREC,NEVHKK
3688                ENDIF
3689             ENDIF
3690 *
3691 *     copy back original settings of PHOJET process and min. bias flags
3692             DO 10 K=1,11
3693                IPRON(K,1) = KPRON(K)
3694    10       CONTINUE
3695             ISWMDL(2) = ISWSAV
3696 *
3697 *     check if PHOJET has rejected this event
3698             IF (IREJ1.NE.0) THEN
3699 C              IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3700                WRITE(LOUT,'(1X,A,I4)')
3701      &            'EVENTB:  chain system rejected',IDIREC
3702                CALL PHO_PREVNT(0)
3703                GOTO 9999
3704             ENDIF
3705 *
3706 *     copy partons and strings from PHOJET common back into DTEVT for
3707 *     external fragmentation
3708             MO1 = NC
3709             MO2 = NC+3
3710 *!      uncomment this line for internal phojet-fragmentation
3711 C           CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1)
3712             NPHOSC = NPHOSC+1
3713             CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1)
3714             IF (IREJ1.NE.0) THEN
3715                IF (IOULEV(1).GT.0)
3716      &         WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1'
3717                GOTO 9999
3718             ENDIF
3719 *
3720 *     update statistics counter
3721             ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1
3722 *
3723 *-----------------------------------------------------------------------
3724 *   this interaction involves "remnants"
3725 *
3726          ELSE
3727 *
3728 *     total mass of this system
3729             PPTOT  = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2)
3730             AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT)
3731             IF (AMTOT2.LT.ZERO) THEN
3732                AMTOT = ZERO
3733             ELSE
3734                AMTOT = SQRT(AMTOT2)
3735             ENDIF
3736 *
3737 *     systems with masses larger than elojet are treated with PHOJET
3738             IF (AMTOT.GT.ELOJET) THEN
3739 *
3740 *     initialize PHOJET-variables for remnant/valence-partons
3741 *       projectile parton flavors and valence flag
3742                IHFLD(1,1) = IDHKK(NC)
3743                IHFLD(1,2) = IDHKK(NC+2)
3744                IHFLS(1)   = 0
3745                IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7)
3746      &                            .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1
3747 *       target parton flavors and valence flag
3748                IHFLD(2,1) = IDHKK(NC+1)
3749                IHFLD(2,2) = IDHKK(NC+3)
3750                IHFLS(2)   = 0
3751                IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5)
3752      &                            .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1
3753 *       flag signalizing PHOJET how to treat the remnant:
3754 *         iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld
3755 *         iremn > -1 valence remnant: PHOJET assumes flavors according
3756 *                    to mother particle
3757                IREMN1 = IHFLS(1)-1
3758                IREMN2 = IHFLS(2)-1
3759 *
3760 *     initialize the incoming particles in PHOJET
3761                IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3762                   CALL PHO_SETPAR(1,22,IREMN1,VIRT)
3763                ELSE
3764                   CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO)
3765                ENDIF
3766                CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO)
3767 *
3768 *     calculate Lorentz parameter of the nucleon-nucleon cm-system
3769                PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2)
3770                AMNN   = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) )
3771                BGX    = PTOTNN(1)/AMNN
3772                BGY    = PTOTNN(2)/AMNN
3773                BGZ    = PTOTNN(3)/AMNN
3774                GAM    = PTOTNN(4)/AMNN
3775 *     transform interacting nucleons into nucleon-nucleon cm-system
3776                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3777      &                     PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS,
3778      &                     PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4))
3779                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3780      &                     PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS,
3781      &                     PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4))
3782 *     transform (total) momenta of the proj and targ partons into
3783 *     nucleon-nucleon cm-system
3784                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3785      &                     PP(1),PP(2),PP(3),PP(4),
3786      &                     PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4))
3787                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
3788      &                     PT(1),PT(2),PT(3),PT(4),
3789      &                     PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4))
3790 *     energy fractions of the proj and targ partons
3791                XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE)
3792                XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE)
3793 ***
3794 * testprint
3795 c              PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
3796 c    &                        (PPTCMS(2)+PTTCMS(2))**2 +
3797 c    &                        (PPTCMS(3)+PTTCMS(3))**2 )
3798 c              EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
3799 c    &                        (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
3800 c              PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
3801 c    &                        (PPSUB(2)+PTSUB(2))**2 +
3802 c    &                        (PPSUB(3)+PTSUB(3))**2 )
3803 c              EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
3804 c    &                        (PPSUB(4)+PTSUB(4)+PTOTSU) )
3805 ***
3806 *
3807 *     save current settings of PHOJET process and min. bias flags
3808                DO 7 K=1,11
3809                   KPRON(K) = IPRON(K,1)
3810     7          CONTINUE
3811 *     disallow direct photon int. (does not make sense here anyway)
3812                IPRON(8,1) = 0
3813 *     disallow double pomeron processes (due to technical problems
3814 *     in PHOJET, needs to be solved sometime)
3815                IPRON(4,1) = 0
3816 *     disallow diffraction for sea-diquarks
3817                IF ((IABS(IHFLD(1,1)).GT.1100).AND.
3818      &             (IABS(IHFLD(1,2)).GT.1100)) THEN
3819                   IPRON(3,1) = 0
3820                   IPRON(6,1) = 0
3821                ENDIF
3822                IF ((IABS(IHFLD(2,1)).GT.1100).AND.
3823      &             (IABS(IHFLD(2,2)).GT.1100)) THEN
3824                   IPRON(3,1) = 0
3825                   IPRON(5,1) = 0
3826                ENDIF
3827 *
3828 *     we need massless partons: transform them on mass shell
3829                XMP = ZERO
3830                XMT = ZERO
3831                DO 6 K=1,4
3832                   PPTMP(K) = PPSUB(K)
3833                   PTTMP(K) = PTSUB(K)
3834     6          CONTINUE
3835                CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1)
3836                PPSUTO  = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2)
3837                PTSUTO  = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2)
3838                PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+
3839      &                  (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2)
3840 *     total energy of the subsysten after mass transformation
3841 *      (should be the same as before..)
3842                SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)*
3843      &                      (PPSUB(4)+PTSUB(4)+PSUTOT) )
3844 *
3845 *     after mass shell transformation the x_sub - relation has to be
3846 *     corrected. We therefore create "pseudo-momenta" of mother-nucleons.
3847 *
3848 *     The old version was to scale based on the original x_sub and the
3849 *     4-momenta of the subsystem. At very high energy this could lead to
3850 *     "pseudo-cm energies" of the parent system considerably exceeding
3851 *     the true cm energy. Now we keep the true cm energy and calculate
3852 *     new x_sub instead.
3853 C old version  PPTCMS(4) = PPSUB(4)/XPSUB
3854                PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4))
3855                XPSUB = PPSUB(4)/PPTCMS(4)
3856                IF (IJPROJ.EQ.7) THEN
3857                   AMP2  = PHKK(5,MOT)**2
3858                   PTOT1 = SQRT(PPTCMS(4)**2-AMP2)
3859                ELSE
3860 *???????
3861                   PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP))
3862      &                        *(PPTCMS(4)+PHKK(5,MOP)))
3863 C                 PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT))
3864 C    &                        *(PPTCMS(4)+PHKK(5,MOT)))
3865                ENDIF
3866 C old version  PTTCMS(4) = PTSUB(4)/XTSUB
3867                PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4))
3868                XTSUB = PTSUB(4)/PTTCMS(4)
3869                PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT))
3870      &                     *(PTTCMS(4)+PHKK(5,MOT)))
3871                DO 4 K=1,3
3872                   PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO
3873                   PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO
3874     4          CONTINUE
3875 ***
3876 * testprint
3877 *
3878 *     ppnn  / ptnn   - momenta of the int. nucleons (cms, negl. Fermi)
3879 *     ptotnn         - total momentum of the int. nucleons (cms, negl. Fermi)
3880 *     pptcms/ pttcms - momenta of the interacting nucleons (cms)
3881 *     pp1,2 / pt1,2  - momenta of the four partons
3882 *
3883 *     pp    / pt     - total momenta of the pr/ta partons (cms, negl. Fermi)
3884 *     ptot           - total momentum of the four partons (cms, negl. Fermi)
3885 *     ppsub / ptsub  - total momenta of the proj / targ partons (cms)
3886 *
3887 c              PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
3888 c    &                        (PPTCMS(2)+PTTCMS(2))**2 +
3889 c    &                        (PPTCMS(3)+PTTCMS(3))**2 )
3890 c              ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
3891 c    &                        (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
3892 c              PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
3893 c    &                        (PPSUB(2)+PTSUB(2))**2 +
3894 c    &                        (PPSUB(3)+PTSUB(3))**2 )
3895 c              ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
3896 c    &                        (PPSUB(4)+PTSUB(4)+PTOTSU) )
3897 c              IF (ENEWCM/EOLDCM.GT.1.1D0) THEN
3898 c                 WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM
3899 c                 WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU
3900 c                 WRITE(*,*) ' XPSUB,  XTSUB  : ',XPSUB,XTSUB
3901 c              ENDIF
3902 c              BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM
3903 c              BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM
3904 c              BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM
3905 c              BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM
3906 *     transform interacting nucleons into nucleon-nucleon cm-system
3907 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3908 c    &                    PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT,
3909 c    &                     PPNEW1,PPNEW2,PPNEW3,PPNEW4)
3910 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3911 c    &                    PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT,
3912 c    &                     PTNEW1,PTNEW2,PTNEW3,PTNEW4)
3913 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3914 c    &                     PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT,
3915 c    &                     PPSUB1,PPSUB2,PPSUB3,PPSUB4)
3916 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
3917 c    &                     PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT,
3918 c    &                     PTSUB1,PTSUB2,PTSUB3,PTSUB4)
3919 c              PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 +
3920 c    &                        (PPNEW2+PTNEW2)**2 +
3921 c    &                        (PPNEW3+PTNEW3)**2 )
3922 c              ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) *
3923 c    &                        (PPNEW4+PTNEW4+PTSTCM) )
3924 c              PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 +
3925 c    &                        (PPSUB2+PTSUB2)**2 +
3926 c    &                        (PPSUB3+PTSUB3)**2 )
3927 c              ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) *
3928 c    &                        (PPSUB4+PTSUB4+PTSTSU) )
3929 C              WRITE(*,*) ' mother cmE :'
3930 C              WRITE(*,*) ETSTCM,ENEWCM
3931 C              WRITE(*,*) ' subsystem cmE :'
3932 C              WRITE(*,*) ETSTSU,ENEWSU
3933 C              WRITE(*,*) ' projectile mother :'
3934 C              WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4
3935 C              WRITE(*,*) ' target mother :'
3936 C              WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4
3937 C              WRITE(*,*) ' projectile subsystem:'
3938 C              WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4
3939 C              WRITE(*,*) ' target subsystem:'
3940 C              WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4
3941 C              WRITE(*,*) ' projectile subsystem should be:'
3942 C              WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0,
3943 C    &                    XPSUB*ETSTCM/2.0D0
3944 C              WRITE(*,*) ' target subsystem should be:'
3945 C              WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0,
3946 C    &                    XTSUB*ETSTCM/2.0D0
3947 C              WRITE(*,*) ' subsystem cmE should be: '
3948 C              WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB
3949 ***
3950 *
3951 *     generate complete remnant - nucleon/remnant event with PHOJET
3952                CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1)
3953 *
3954 *     copy back original settings of PHOJET process flags
3955                DO 11 K=1,11
3956                   IPRON(K,1) = KPRON(K)
3957    11          CONTINUE
3958 *
3959 *     check if PHOJET has rejected this event
3960                IF (IREJ1.NE.0) THEN
3961                   IF (IOULEV(1).GT.0)
3962      &            WRITE(LOUT,'(1X,A)') 'EVENTB:  chain system rejected'
3963                   WRITE(LOUT,*)
3964      &                 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT
3965                   CALL PHO_PREVNT(0)
3966                   GOTO 9999
3967                ENDIF
3968 *
3969 *     copy partons and strings from PHOJET common back into DTEVT for
3970 *     external fragmentation
3971                MO1 = NC
3972                MO2 = NC+3
3973 *!      uncomment this line for internal phojet-fragmentation
3974 C              CALL DT_GETFSP(MO1,MO2,PP,PT,1)
3975                NPHOSC = NPHOSC+1
3976                CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1)
3977                IF (IREJ1.NE.0) THEN
3978                   IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3979      &               'EVENTB: chain system rejected 2'
3980                   GOTO 9999
3981                ENDIF
3982 *
3983 *     update statistics counter
3984                ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1
3985 *
3986 *-----------------------------------------------------------------------
3987 * two-chain approx. for smaller systems
3988 *
3989             ELSE
3990 *
3991                NDTUSC = NDTUSC+1
3992 *   special flag for double-Pomeron statistics
3993                IPOPO = 0
3994 *
3995 *   pick up flavors at the ends of the two chains
3996                IFP1 = IDHKK(NC)
3997                IFT1 = IDHKK(NC+1)
3998                IFP2 = IDHKK(NC+2)
3999                IFT2 = IDHKK(NC+3)
4000 *   ..and the indices of the mothers
4001                MOP1 = NC
4002                MOT1 = NC+1
4003                MOP2 = NC+2
4004                MOT2 = NC+3
4005                CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
4006      &                     IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
4007 *
4008 *   check if this chain system was rejected
4009                IF (IREJ1.GT.0) THEN
4010                   IF (IOULEV(1).GT.0) THEN
4011                      WRITE(LOUT,*) 'rejected 1 in EVENTB'
4012                      WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)')
4013      &                  IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT
4014                   ENDIF
4015                   IRHHA = IRHHA+1
4016                   GOTO 9999
4017                ENDIF
4018 *   the following lines are for sea-sea chains rejected in GETCSY
4019                IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1
4020                ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1
4021             ENDIF
4022 *
4023          ENDIF
4024 *
4025 *     update statistics counter
4026          ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1
4027 *
4028          NC = NC+4
4029 *
4030     2 CONTINUE
4031 *
4032 *-----------------------------------------------------------------------
4033 * treatment of low-mass chains (if there are any)
4034 *
4035       IF (NDTUSC.GT.0) THEN
4036 *
4037 *   correct chains of very low masses for possible resonances
4038          IF (IRESCO.EQ.1) THEN
4039             CALL DT_EVTRES(IREJ1)
4040             IF (IREJ1.GT.0) THEN
4041                IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB'
4042                IRRES(1) = IRRES(1)+1
4043                GOTO 9999
4044             ENDIF
4045          ENDIF
4046 *   fragmentation of low-mass chains
4047 *!  uncomment this line for internal phojet-fragmentation
4048 *   (of course it will still be fragmented by DPMJET-routines but it
4049 *    has to be done here instead of further below)
4050 C        CALL DT_EVTFRA(IREJ1)
4051 C        IF (IREJ1.GT.0) THEN
4052 C           IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB'
4053 C           IRFRAG = IRFRAG+1
4054 C           GOTO 9999
4055 C        ENDIF
4056       ELSE
4057 *! uncomment this line for internal phojet-fragmentation
4058 C        NPOINT(4) = NHKK+1
4059          IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
4060       ENDIF
4061 *
4062 *-----------------------------------------------------------------------
4063 * new di-quark breaking mechanisms
4064 *
4065       MXLEFT = 2
4066       CALL DT_CHASTA(0)
4067       IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
4068      &                        .OR.(PDBSEA(3).GT.0.0D0)) THEN
4069          CALL DT_DIQBRK
4070          MXLEFT = 4
4071       ENDIF
4072 *
4073 *-----------------------------------------------------------------------
4074 * hadronize this event
4075 *
4076 *   hadronize PHOJET chain systems
4077       NPYMAX = 0
4078       NPJE   = NPHOSC/MXPHFR
4079       IF (MXPHFR.LT.MXLEFT) MXLEFT = 2
4080       IF (NPJE.GT.1) THEN
4081          NLEFT = NPHOSC-NPJE*MXPHFR
4082          DO 20 JFRG=1,NPJE
4083             NFRG = JFRG*MXPHFR
4084             IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN
4085                CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4086                IF (IREJ1.GT.0) GOTO 22
4087                NLEFT = 0
4088             ELSE
4089                CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1)
4090                IF (IREJ1.GT.0) GOTO 22
4091             ENDIF
4092             IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4093    20    CONTINUE
4094          IF (NLEFT.GT.0) THEN
4095             CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4096             IF (IREJ1.GT.0) GOTO 22
4097             IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4098          ENDIF
4099       ELSE
4100          CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4101          IF (IREJ1.GT.0) GOTO 22
4102          IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4103       ENDIF
4104 *
4105 *   check max. filling level of jetset common and
4106 *   reduce mxphfr if necessary
4107       IF (NPYMAX.GT.3000) THEN
4108          IF (NPYMAX.GT.3500) THEN
4109             MXPHFR = MAX(1,MXPHFR-2)
4110          ELSE
4111             MXPHFR = MAX(1,MXPHFR-1)
4112          ENDIF
4113 C        WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR
4114       ENDIF
4115 *
4116 *   hadronize DTUNUC chain systems
4117    23 CONTINUE
4118       IBACK = MXDTFR
4119       CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2)
4120       IF (IREJ2.GT.0) GOTO 22
4121 *
4122 *   check max. filling level of jetset common and
4123 *   reduce mxdtfr if necessary
4124       IF (NPYMEM.GT.3000) THEN
4125          IF (NPYMEM.GT.3500) THEN
4126             MXDTFR = MAX(1,MXDTFR-20)
4127          ELSE
4128             MXDTFR = MAX(1,MXDTFR-10)
4129          ENDIF
4130 C        WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR
4131       ENDIF
4132 *
4133       IF (IBACK.EQ.-1) GOTO 23
4134 *
4135    22 CONTINUE
4136 C     CALL DT_EVTFRG(1,IREJ1)
4137 C     CALL DT_EVTFRG(2,IREJ2)
4138       IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN
4139          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB'
4140          IRFRAG = IRFRAG+1
4141          GOTO 9999
4142       ENDIF
4143 *
4144 * get final state particles from /DTEVTP/
4145 *! uncomment this line for internal phojet-fragmentation
4146 C     CALL DT_GETFSP(IDUM,IDUM,PP,PT,2)
4147
4148       IF (IJPROJ.NE.7)
4149      &   CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3)
4150 C     IF (IREJ3.NE.0) GOTO 9999
4151
4152       RETURN
4153
4154  9999 CONTINUE
4155       IREVT = IREVT+1
4156       IREJ  = 1
4157       RETURN
4158       END
4159
4160 *$ CREATE DT_GETPJE.FOR
4161 *COPY DT_GETPJE
4162 *
4163 *===getpje=============================================================*
4164 *
4165       SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ)
4166
4167 ************************************************************************
4168 * This subroutine copies PHOJET partons and strings from POEVT1 into   *
4169 * DTEVT1.                                                              *
4170 *      MO1,MO2   indices of first and last mother-parton in DTEVT1     *
4171 *      PP,PT     4-momenta of projectile/target being handled by       *
4172 *                PHOJET                                                *
4173 * This version dated 11.12.99 is written by S. Roesler                 *
4174 ************************************************************************
4175
4176       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4177       SAVE
4178       PARAMETER ( LINP = 10 ,
4179      &            LOUT = 6 ,
4180      &            LDAT = 9 )
4181       PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1,
4182      &           ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0)
4183
4184       LOGICAL LFLIP
4185
4186 * event history
4187       PARAMETER (NMXHKK=200000)
4188       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4189      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4190      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4191 * extended event history
4192       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4193      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4194      &                IHIST(2,NMXHKK)
4195 * Lorentz-parameters of the current interaction
4196       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4197      &                UMO,PPCM,EPROJ,PPROJ
4198 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
4199       COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
4200 * flags for input different options
4201       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4202       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4203      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4204 * statistics: double-Pomeron exchange
4205       COMMON /DTFLG2/ INTFLG,IPOPO
4206 * statistics
4207       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
4208      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
4209      &                ICEVTG(8,0:30)
4210 * rejection counter
4211       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
4212      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
4213      &                IREXCI(3),IRDIFF(2),IRINC
4214 C  standard particle data interface
4215       INTEGER NMXHEP
4216       PARAMETER (NMXHEP=4000)
4217       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
4218       DOUBLE PRECISION PHEP,VHEP
4219       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
4220      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
4221      &                VHEP(4,NMXHEP)
4222 C  extension to standard particle data interface (PHOJET specific)
4223       INTEGER IMPART,IPHIST,ICOLOR
4224       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
4225 C  color string configurations including collapsed strings and hadrons
4226       INTEGER MSTR
4227       PARAMETER (MSTR=500)
4228       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
4229       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
4230      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
4231      &                NNCH(MSTR),IBHAD(MSTR),ISTR
4232 C  general process information
4233       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4234       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4235 C  model switches and parameters
4236       CHARACTER*8 MDLNA
4237       INTEGER ISWMDL,IPAMDL
4238       DOUBLE PRECISION PARMDL
4239       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4240 C  event debugging information
4241       INTEGER NMAXD
4242       PARAMETER (NMAXD=100)
4243       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4244      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4245       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4246      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4247
4248       DIMENSION PP(4),PT(4)
4249       DATA MAXLOP /10000/
4250
4251       INHKK = NHKK
4252       LFLIP = .TRUE.
4253     1 CONTINUE
4254       NPVAL = 0
4255       NTVAL = 0
4256       IREJ  = 0
4257
4258 *   store initial momenta for energy-momentum conservation check
4259       IF (LEMCCK) THEN
4260          CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2)
4261          CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2)
4262       ENDIF
4263 * copy partons and strings from POEVT1 into DTEVT1
4264       DO 11 I=1,ISTR
4265 C        IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN
4266          IF (NCODE(I).EQ.-99) THEN
4267             IDXSTG = NPOS(1,I)
4268             IDSTG  = IDHEP(IDXSTG)
4269             PX = PHEP(1,IDXSTG)
4270             PY = PHEP(2,IDXSTG)
4271             PZ = PHEP(3,IDXSTG)
4272             PE = PHEP(4,IDXSTG)
4273             IF (MODE.LT.0) THEN
4274                ISTAT = 70000+IPJE
4275                CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE,
4276      &                        11,IDSTG,0)
4277                IF (LEMCCK) THEN
4278                   PX = -PX
4279                   PY = -PY
4280                   PZ = -PZ
4281                   PE = -PE
4282                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4283                ENDIF
4284             ELSE
4285                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4286      &                        PPX,PPY,PPZ,PPE)
4287                ISTAT = 70000+IPJE
4288                CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE,
4289      &                        11,IDSTG,0)
4290                IF (LEMCCK) THEN
4291                   PX = -PPX
4292                   PY = -PPY
4293                   PZ = -PPZ
4294                   PE = -PPE
4295                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4296                ENDIF
4297             ENDIF
4298             NOBAM(NHKK)   = 0
4299             IHIST(1,NHKK) = IPHIST(1,IDXSTG)
4300             IHIST(2,NHKK) = 0
4301          ELSEIF (NCODE(I).GE.0) THEN
4302 *   indices of partons and string in POEVT1
4303             IDX1 = ABS(JMOHEP(1,NPOS(1,I)))
4304             IDX2 = ABS(JMOHEP(2,NPOS(1,I)))
4305             IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN
4306                WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2,
4307      &         ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! '
4308                STOP ' GETPJE 1'
4309             ENDIF
4310             IDXSTG = NPOS(1,I)
4311 *   find "mother" string of the string
4312             IDXMS1 = ABS(JMOHEP(1,IDX1))
4313             IDXMS2 = ABS(JMOHEP(1,IDX2))
4314             IF (IDXMS1.NE.IDXMS2) THEN
4315                IDXMS1 = IDXSTG
4316                IDXMS2 = IDXSTG
4317 C              STOP ' GETPJE: IDXMS1.NE.IDXMS2 !'
4318             ENDIF
4319 *   search POEVT1 for the original hadron of the parton
4320             ILOOP = 0
4321             IPOM1 = 0
4322    14       CONTINUE
4323             ILOOP = ILOOP+1
4324             IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1
4325             IDXMS1 = ABS(JMOHEP(1,IDXMS1))
4326             IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND.
4327      &          (ILOOP.LT.MAXLOP)) GOTO 14
4328             IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! '
4329             IPOM2 = 0
4330             ILOOP = 0
4331    15       CONTINUE
4332             ILOOP = ILOOP+1
4333             IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1
4334             IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN
4335                IDXMS2 = ABS(JMOHEP(2,IDXMS2))
4336             ELSE
4337                IDXMS2 = ABS(JMOHEP(1,IDXMS2))
4338             ENDIF
4339             IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND.
4340      &          (ILOOP.LT.MAXLOP)) GOTO 15
4341             IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! '
4342 *   parton 1
4343             IF (IDXMS1.EQ.1) THEN
4344                ISPTN1 = ISTHKK(MO1)
4345                M1PTN1 = MO1
4346                M2PTN1 = MO1+2
4347             ELSE
4348                ISPTN1 = ISTHKK(MO2)
4349                M1PTN1 = MO2-2
4350                M2PTN1 = MO2
4351             ENDIF
4352 *   parton 2
4353             IF (IDXMS2.EQ.1) THEN
4354                ISPTN2 = ISTHKK(MO1)
4355                M1PTN2 = MO1
4356                M2PTN2 = MO1+2
4357             ELSE
4358                ISPTN2 = ISTHKK(MO2)
4359                M1PTN2 = MO2-2
4360                M2PTN2 = MO2
4361             ENDIF
4362 *   check for mis-identified mothers and switch mother indices if necessary
4363             IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6)
4364      &          .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND.
4365      &          (LFLIP)) THEN
4366                IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN
4367                   ISPTN1 = ISTHKK(MO1)
4368                   M1PTN1 = MO1
4369                   M2PTN1 = MO1+2
4370                   ISPTN2 = ISTHKK(MO2)
4371                   M1PTN2 = MO2-2
4372                   M2PTN2 = MO2
4373                ELSE
4374                   ISPTN1 = ISTHKK(MO2)
4375                   M1PTN1 = MO2-2
4376                   M2PTN1 = MO2
4377                   ISPTN2 = ISTHKK(MO1)
4378                   M1PTN2 = MO1
4379                   M2PTN2 = MO1+2
4380                ENDIF
4381             ENDIF
4382 *   register partons in temporary common
4383 *     parton at chain end
4384             PX = PHEP(1,IDX1)
4385             PY = PHEP(2,IDX1)
4386             PZ = PHEP(3,IDX1)
4387             PE = PHEP(4,IDX1)
4388 * flag only partons coming from Pomeron with 41/42
4389 C           IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4390             IF (IPOM1.NE.0) THEN
4391                ISTX = ABS(ISPTN1)/10
4392                IMO  = ABS(ISPTN1)-10*ISTX
4393                ISPTN1 = -(40+IMO)
4394             ELSE
4395                IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN
4396                   ISTX = ABS(ISPTN1)/10
4397                   IMO  = ABS(ISPTN1)-10*ISTX
4398                   IF ((IDHEP(IDX1).EQ.21).OR.
4399      &                (ABS(IPHIST(1,IDX1)).GE.100)) THEN
4400                      ISPTN1 = -(60+IMO)
4401                   ELSE
4402                      ISPTN1 = -(50+IMO)
4403                   ENDIF
4404                ENDIF
4405             ENDIF
4406             IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1
4407             IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1
4408             IF (MODE.LT.0) THEN
4409                CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY,
4410      &                        PZ,PE,0,0,0)
4411             ELSE
4412                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4413      &                        PPX,PPY,PPZ,PPE)
4414                CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY,
4415      &                        PPZ,PPE,0,0,0)
4416             ENDIF
4417             IHIST(1,NHKK) = IPHIST(1,IDX1)
4418             IHIST(2,NHKK) = 0
4419             DO 19 KK=1,4
4420                VHKK(KK,NHKK) = VHKK(KK,M2PTN1)
4421                WHKK(KK,NHKK) = WHKK(KK,M1PTN1)
4422    19       CONTINUE
4423             VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB
4424             WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB
4425             M1STRG = NHKK
4426 *     gluon kinks
4427             NGLUON = IDX2-IDX1-1
4428             IF (NGLUON.GT.0) THEN
4429                DO 17 IGLUON=1,NGLUON
4430                   IDX   = IDX1+IGLUON
4431                   IDXMS = ABS(JMOHEP(1,IDX))
4432                   IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN
4433                      ILOOP = 0
4434    16                CONTINUE
4435                      ILOOP = ILOOP+1
4436                      IDXMS = ABS(JMOHEP(1,IDXMS))
4437                      IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND.
4438      &                   (ILOOP.LT.MAXLOP)) GOTO 16
4439                      IF (ILOOP.EQ.MAXLOP)
4440      &                  WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! '
4441                   ENDIF
4442                   IF (IDXMS.EQ.1) THEN
4443                      ISPTN = ISTHKK(MO1)
4444                      M1PTN = MO1
4445                      M2PTN = MO1+2
4446                   ELSE
4447                      ISPTN = ISTHKK(MO2)
4448                      M1PTN = MO2-2
4449                      M2PTN = MO2
4450                   ENDIF
4451                   PX = PHEP(1,IDX)
4452                   PY = PHEP(2,IDX)
4453                   PZ = PHEP(3,IDX)
4454                   PE = PHEP(4,IDX)
4455                   IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN
4456                      ISTX = ABS(ISPTN)/10
4457                      IMO  = ABS(ISPTN)-10*ISTX
4458                      IF ((IDHEP(IDX).EQ.21).OR.
4459      &                   (ABS(IPHIST(1,IDX)).GE.100)) THEN
4460                         ISPTN = -(60+IMO)
4461                      ELSE
4462                         ISPTN = -(50+IMO)
4463                      ENDIF
4464                   ENDIF
4465                   IF (ISPTN.EQ.-21) NPVAL = NPVAL+1
4466                   IF (ISPTN.EQ.-22) NTVAL = NTVAL+1
4467                   IF (MODE.LT.0) THEN
4468                      CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4469      &                              PX,PY,PZ,PE,0,0,0)
4470                   ELSE
4471                      CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4472      &                              PPX,PPY,PPZ,PPE)
4473                      CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4474      &                              PPX,PPY,PPZ,PPE,0,0,0)
4475                   ENDIF
4476                   IHIST(1,NHKK) = IPHIST(1,IDX)
4477                   IHIST(2,NHKK) = 0
4478                   DO 20 KK=1,4
4479                      VHKK(KK,NHKK) = VHKK(KK,M2PTN)
4480                      WHKK(KK,NHKK) = WHKK(KK,M1PTN)
4481    20             CONTINUE
4482                   VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB
4483                   WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB
4484    17          CONTINUE
4485             ENDIF
4486 *     parton at chain end
4487             PX = PHEP(1,IDX2)
4488             PY = PHEP(2,IDX2)
4489             PZ = PHEP(3,IDX2)
4490             PE = PHEP(4,IDX2)
4491 * flag only partons coming from Pomeron with 41/42
4492 C           IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4493             IF (IPOM2.NE.0) THEN
4494                ISTX = ABS(ISPTN2)/10
4495                IMO  = ABS(ISPTN2)-10*ISTX
4496                ISPTN2 = -(40+IMO)
4497             ELSE
4498                IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN
4499                   ISTX = ABS(ISPTN2)/10
4500                   IMO  = ABS(ISPTN2)-10*ISTX
4501                   IF ((IDHEP(IDX2).EQ.21).OR.
4502      &                (ABS(IPHIST(1,IDX2)).GE.100)) THEN
4503                      ISPTN2 = -(60+IMO)
4504                   ELSE
4505                      ISPTN2 = -(50+IMO)
4506                   ENDIF
4507                ENDIF
4508             ENDIF
4509             IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1
4510             IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1
4511             IF (MODE.LT.0) THEN
4512                CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4513      &                        PX,PY,PZ,PE,0,0,0)
4514             ELSE
4515                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4516      &                        PPX,PPY,PPZ,PPE)
4517                CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4518      &                        PPX,PPY,PPZ,PPE,0,0,0)
4519             ENDIF
4520             IHIST(1,NHKK) = IPHIST(1,IDX2)
4521             IHIST(2,NHKK) = 0
4522             DO 21 KK=1,4
4523                VHKK(KK,NHKK) = VHKK(KK,M2PTN2)
4524                WHKK(KK,NHKK) = WHKK(KK,M1PTN2)
4525    21       CONTINUE
4526             VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB
4527             WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB
4528             M2STRG = NHKK
4529 *   register string
4530             JSTRG = 100*IPROCE+NCODE(I)
4531             PX = PHEP(1,IDXSTG)
4532             PY = PHEP(2,IDXSTG)
4533             PZ = PHEP(3,IDXSTG)
4534             PE = PHEP(4,IDXSTG)
4535             IF (MODE.LT.0) THEN
4536                ISTAT = 70000+IPJE
4537                CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4538      &                        PX,PY,PZ,PE,0,0,0)
4539                IF (LEMCCK) THEN
4540                   PX = -PX
4541                   PY = -PY
4542                   PZ = -PZ
4543                   PE = -PE
4544                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4545                ENDIF
4546             ELSE
4547                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4548      &                        PPX,PPY,PPZ,PPE)
4549                ISTAT = 70000+IPJE
4550                CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4551      &                        PPX,PPY,PPZ,PPE,0,0,0)
4552                IF (LEMCCK) THEN
4553                   PX = -PPX
4554                   PY = -PPY
4555                   PZ = -PPZ
4556                   PE = -PPE
4557                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4558                ENDIF
4559             ENDIF
4560             NOBAM(NHKK)   = 0
4561             IHIST(1,NHKK) = 0
4562             IHIST(2,NHKK) = 0
4563             DO 18 KK=1,4
4564                VHKK(KK,NHKK) = VHKK(KK,MO2)
4565                WHKK(KK,NHKK) = WHKK(KK,MO1)
4566    18       CONTINUE
4567             VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
4568             WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
4569          ENDIF
4570    11 CONTINUE
4571
4572       IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN
4573          NHKK  = INHKK
4574          LFLIP = .FALSE.
4575          GOTO 1
4576       ENDIF
4577
4578       IF (LEMCCK) THEN
4579          IF (UMO.GT.1.0D5) THEN
4580             CHKLEV = 1.0D0
4581          ELSE
4582             CHKLEV = TINY1
4583          ENDIF
4584          CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2)
4585          IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0)
4586       ENDIF
4587
4588 * internal statistics
4589 *   dble-Po statistics.
4590       IF (IPROCE.NE.4) IPOPO = 0
4591
4592       INTFLG = IPROCE
4593       IDCHSY = IDCH(MO1)
4594       IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN
4595          ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1
4596       ELSE
4597          WRITE(LOUT,1000) IPROCE,NEVHKK,MO1
4598  1000    FORMAT(1X,'GETFSP:   warning! incons. process id. (',I2,
4599      &          ') at evt(chain) ',I6,'(',I2,')')
4600       ENDIF
4601       IF (IPROCE.EQ.5) THEN
4602          IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN
4603             ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1
4604          ELSE
4605 C           WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4606  1001       FORMAT(1X,'GETFSP:   warning! incons. diffrac. id. ',
4607      &             '(IPROCE,IDIFR1,IDIFR2=',3I3,')')
4608          ENDIF
4609       ELSEIF (IPROCE.EQ.6) THEN
4610          IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4611             ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1
4612          ELSE
4613 C           WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4614          ENDIF
4615       ELSEIF (IPROCE.EQ.7) THEN
4616          IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND.
4617      &       (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4618             IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1))
4619      &         ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1
4620             IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2))
4621      &         ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1
4622             IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2))
4623      &         ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1
4624             IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1))
4625      &         ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1
4626          ELSE
4627             WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4628          ENDIF
4629       ENDIF
4630       IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3))
4631      &                                                       THEN
4632          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4633          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4634          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4635       ENDIF
4636       ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM
4637       ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM
4638       ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG
4639       ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG)
4640       ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO)
4641
4642       RETURN
4643
4644  9999 CONTINUE
4645       IREJ = 1
4646       RETURN
4647       END
4648
4649 *$ CREATE DT_PHOINI.FOR
4650 *COPY DT_PHOINI
4651 *
4652 *===phoini=============================================================*
4653 *
4654       SUBROUTINE DT_PHOINI
4655
4656 ************************************************************************
4657 * Initialization PHOJET-event generator for nucleon-nucleon interact.  *
4658 * This version dated 16.11.95 is written by S. Roesler                 *
4659 *                                                                      *
4660 * Last change 27.12.2006 by S. Roesler.                                *
4661 ************************************************************************
4662
4663       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4664       SAVE
4665       PARAMETER ( LINP = 10 ,
4666      &            LOUT = 6 ,
4667      &            LDAT = 9 )
4668       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
4669
4670 * nucleon-nucleon event-generator
4671       CHARACTER*8 CMODEL
4672       LOGICAL LPHOIN
4673       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
4674 * particle properties (BAMJET index convention)
4675       CHARACTER*8  ANAME
4676       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
4677      &                IICH(210),IIBAR(210),K1(210),K2(210)
4678 * Lorentz-parameters of the current interaction
4679       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4680      &                UMO,PPCM,EPROJ,PPROJ
4681 * properties of interacting particles
4682       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
4683 * properties of photon/lepton projectiles
4684       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
4685       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
4686 * emulsion treatment
4687       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
4688      &                NCOMPO,IEMUL
4689 * VDM parameter for photon-nucleus interactions
4690       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
4691 * nuclear potential
4692       LOGICAL LFERMI
4693       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
4694      &                EBINDP(2),EBINDN(2),EPOT(2,210),
4695      &                ETACOU(2),ICOUL,LFERMI
4696 * Glauber formalism: flags and parameters for statistics
4697       LOGICAL LPROD
4698       CHARACTER*8 CGLB
4699       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
4700 *
4701 * parameters for cascade calculations:
4702 * maximum mumber of PDF's which can be defined in phojet (limited
4703 * by the dimension of ipdfs in pho_setpdf)
4704       PARAMETER (MAXPDF = 20)
4705 * PDF parametrization and number of set for the first 30 hadrons in
4706 * the bamjet-code list
4707 *   negative numbers mean that the PDF is set in phojet,
4708 *   zero stands for "not a hadron"
4709       DIMENSION IPARPD(30),ISETPD(30)
4710 * PDF parametrization
4711       DATA IPARPD /
4712      &  -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5,
4713      &   5, 5,-5, 5, 5, 0, 0, 0, 0, 0/
4714 * number of set
4715       DATA ISETPD /
4716      &  -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6,
4717      &   6, 6,-2, 2, 2, 0, 0, 0, 0, 0/
4718
4719 **PHOJET105a
4720 C     COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
4721 C     PARAMETER ( MAXPRO = 16 )
4722 C     PARAMETER ( MAXTAB = 20 )
4723 C     COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO),
4724 C    &                MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB
4725 C     CHARACTER*8 MDLNA
4726 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
4727 C     COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15)
4728 **PHOJET110
4729 C  global event kinematics and particle IDs
4730       INTEGER IFPAP,IFPAB
4731       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
4732       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
4733 C  hard cross sections and MC selection weights
4734       INTEGER Max_pro_2
4735       PARAMETER ( Max_pro_2 = 16 )
4736       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
4737      &  MH_acc_1,MH_acc_2
4738       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
4739       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
4740      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
4741      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
4742      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
4743      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
4744 C  model switches and parameters
4745       CHARACTER*8 MDLNA
4746       INTEGER ISWMDL,IPAMDL
4747       DOUBLE PRECISION PARMDL
4748       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4749 C  general process information
4750       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4751       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4752 **
4753       DIMENSION PP(4),PT(4)
4754
4755       LOGICAL LSTART
4756       DATA LSTART /.TRUE./
4757
4758       IJP = IJPROJ
4759       IJT = IJTARG
4760       Q2  = VIRT
4761 * lepton-projectiles: initialize real photon instead
4762       IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN
4763          IJP = 7
4764          Q2  = ZERO
4765       ENDIF
4766       IF (LPHOIN) CALL PHO_INIT(-1,LOUT,IDUM)
4767 * switch Reggeon off
4768 C     IPAMDL(3)= 0
4769       IF (IP.EQ.1) THEN
4770          IFPAP(1) = IDT_IPDGHA(IJP)
4771          IFPAB(1) = IJP
4772       ELSE
4773          IFPAP(1) = 2212
4774          IFPAB(1) = IDT_ICIHAD(IFPAP(1))
4775       ENDIF
4776       PMASS(1) = AAM(IFPAB(1))-SQRT(Q2)
4777       PVIRT(1) = PMASS(1)**2
4778       IF (IT.EQ.1) THEN
4779          IFPAP(2) = IDT_IPDGHA(IJT)
4780          IFPAB(2) = IJT
4781       ELSE
4782          IFPAP(2) = 2212
4783          IFPAB(2) = IDT_ICIHAD(IFPAP(2))
4784       ENDIF
4785       PMASS(2) = AAM(IFPAB(2))
4786       PVIRT(2) = ZERO
4787       DO 1 K=1,4
4788          PP(K) = ZERO
4789          PT(K) = ZERO
4790     1 CONTINUE
4791 * get max. possible momenta of incoming particles to be used for PHOJET ini.
4792       PPF = ZERO
4793       PTF = ZERO
4794       SCPF= 1.5D0
4795       IF (UMO.GE.1.E5) THEN
4796          SCPF= 5.0D0
4797       ENDIF
4798       IF (NCOMPO.GT.0) THEN
4799          DO 2 I=1,NCOMPO
4800             IF (IT.GT.1) THEN
4801                CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0)
4802             ELSE
4803                CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0)
4804             ENDIF
4805             PPFTMP = MAX(PFERMP(1),PFERMN(1))
4806             PTFTMP = MAX(PFERMP(2),PFERMN(2))
4807             IF (PPFTMP.GT.PPF) PPF = PPFTMP
4808             IF (PTFTMP.GT.PTF) PTF = PTFTMP
4809     2    CONTINUE
4810       ELSE
4811          CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
4812          PPF = MAX(PFERMP(1),PFERMN(1))
4813          PTF = MAX(PFERMP(2),PFERMN(2))
4814       ENDIF
4815       PTF = -PTF
4816       PPF = SCPF*PPF
4817       PTF = SCPF*PTF
4818       IF (IJP.EQ.7) THEN
4819          AMP2  = SIGN(PMASS(1)**2,PMASS(1))
4820          PP(3) = PPCM
4821          PP(4) = SQRT(AMP2+PP(3)**2)
4822       ELSE
4823          EPF = SQRT(PPF**2+PMASS(1)**2)
4824          CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2)
4825       ENDIF
4826       ETF = SQRT(PTF**2+PMASS(2)**2)
4827       CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3)
4828       ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
4829      &              (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
4830       IF (LSTART) THEN
4831          WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP
4832  1001    FORMAT(
4833      &      ' DT_PHOINI:    PHOJET initialized for projectile A,Z = ',
4834      &      I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
4835          IF (NCOMPO.GT.0) THEN
4836             WRITE(LOUT,1002) SCPF,PTF,PT
4837          ELSE
4838             WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT
4839          ENDIF
4840  1002    FORMAT(
4841      &      ' DT_PHOINI:    PHOJET initialized for target emulsion  ',
4842      &          /,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
4843  1003    FORMAT(
4844      &      ' DT_PHOINI:    PHOJET initialized for target     A,Z = ',
4845      &      I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
4846          WRITE(LOUT,1004) ECMINI
4847  1004    FORMAT(' E_cm = ',E10.3)
4848          IF (IJP.EQ.8) WRITE(LOUT,1005)
4849  1005    FORMAT(
4850      &      ' DT_PHOINI: warning! proton parameters used for neutron',
4851      &          ' projectile')
4852          LSTART = .FALSE.
4853       ENDIF
4854 * switch off new diffractive cross sections at low energies for nuclei
4855 * (temporary solution)
4856       IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN
4857          WRITE(LOUT,'(1X,A)')
4858      &      ' DT_PHOINI: model-switch 30 for nuclei re-set !'
4859          CALL PHO_SETMDL(30,0,1)
4860       ENDIF
4861 *
4862 C     IF (IJP.EQ.7) THEN
4863 C        AMP2  = SIGN(PMASS(1)**2,PMASS(1))
4864 C        PP(3) = PPCM
4865 C        PP(4) = SQRT(AMP2+PP(3)**2)
4866 C     ELSE
4867 C        PFERMX = ZERO
4868 C        IF (IP.GT.1) PFERMX = 0.5D0
4869 C        EFERMX = SQRT(PFERMX**2+PMASS(1)**2)
4870 C        CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2)
4871 C     ENDIF
4872 C     PFERMX = ZERO
4873 C     IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0
4874 C     EFERMX = SQRT(PFERMX**2+PMASS(2)**2)
4875 C     CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3)
4876 **sr 26.10.96
4877       ISAV = IPAMDL(13)
4878       IF ((ISHAD(2).EQ.1).AND.
4879      &   ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR.
4880      &    (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1
4881 **
4882       CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1)
4883 **sr 26.10.96
4884       IPAMDL(13) = ISAV
4885 **
4886 *
4887 * patch for cascade calculations:
4888 * define parton distribution functions for other hadrons, i.e. other
4889 * then defined already in phojet
4890       IF (IOGLB.EQ.100) THEN
4891          WRITE(LOUT,1006)
4892  1006    FORMAT(/,1X,'PHOINI: additional parton distribution functions',
4893      &          ' assiged (ID,IPAR,ISET)',/)
4894          NPDF = 0
4895          DO 3 I=1,30
4896             IF (IPARPD(I).NE.0) THEN
4897                NPDF = NPDF+1
4898                IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !'
4899                IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN
4900                   IDPDG = IDT_IPDGHA(I)
4901                   IPAR  = IPARPD(I)
4902                   ISET  = ISETPD(I)
4903                   WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET
4904                   CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1)
4905                ENDIF
4906             ENDIF
4907     3    CONTINUE
4908       ENDIF
4909
4910 C     CALL PHO_PHIST(-1,SIGMAX)
4911       IF (IREJ1.NE.0) THEN
4912          WRITE(LOUT,1000)
4913  1000    FORMAT(1X,'PHOINI:   PHOJET event-initialization failed!')
4914          STOP
4915       ENDIF
4916
4917       RETURN
4918       END
4919
4920 *$ CREATE DT_EVENTD.FOR
4921 *COPY DT_EVENTD
4922 *
4923 *===eventd=============================================================*
4924 *
4925       SUBROUTINE DT_EVENTD(IREJ)
4926
4927 ************************************************************************
4928 * Quasi-elastic neutrino nucleus scattering.                           *
4929 * This version dated 29.04.00 is written by S. Roesler.                *
4930 ************************************************************************
4931
4932       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4933       SAVE
4934       PARAMETER ( LINP = 10 ,
4935      &            LOUT = 6 ,
4936      &            LDAT = 9 )
4937       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5)
4938       PARAMETER (SQTINF=1.0D+15)
4939
4940       LOGICAL LFIRST
4941
4942 * event history
4943       PARAMETER (NMXHKK=200000)
4944       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4945      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4946      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4947 * extended event history
4948       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4949      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4950      &                IHIST(2,NMXHKK)
4951 * flags for input different options
4952       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4953       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4954      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4955       PARAMETER (MAXLND=4000)
4956       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
4957 * properties of interacting particles
4958       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
4959 * Lorentz-parameters of the current interaction
4960       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4961      &                UMO,PPCM,EPROJ,PPROJ
4962 * nuclear potential
4963       LOGICAL LFERMI
4964       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
4965      &                EBINDP(2),EBINDN(2),EPOT(2,210),
4966      &                ETACOU(2),ICOUL,LFERMI
4967 * steering flags for qel neutrino scattering modules
4968       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
4969       COMMON /QNPOL/ POLARX(4),PMODUL
4970       INTEGER PYK
4971
4972       DATA LFIRST /.TRUE./
4973
4974       IREJ = 0
4975
4976       IF (LFIRST) THEN
4977          LFIRST = .FALSE.
4978          CALL DT_MASS_INI
4979       ENDIF
4980
4981 * JETSET parameter
4982       CALL DT_INITJS(0)
4983
4984 * interacting target nucleon
4985       LTYP = NEUTYP
4986       IF (NEUDEC.LE.9) THEN
4987          IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN
4988             NUCTYP = 2112
4989             NUCTOP = 2
4990          ELSE
4991             NUCTYP = 2212
4992             NUCTOP = 1
4993          ENDIF
4994       ELSE
4995          RTYP  = DT_RNDM(RTYP)
4996          ZFRAC = DBLE(ITZ)/DBLE(IT)
4997          IF (RTYP.LE.ZFRAC) THEN
4998             NUCTYP = 2212
4999             NUCTOP = 1
5000          ELSE
5001             NUCTYP = 2112
5002             NUCTOP = 2
5003          ENDIF
5004       ENDIF
5005
5006 * select first nucleon in list with matching id and reset all other
5007 * nucleons which have been marked as "wounded" by ININUC
5008       IFOUND = 0
5009       DO 1 I=1,NHKK
5010          IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN
5011             ISTHKK(I) = 12
5012             IFOUND    = 1
5013             IDX = I
5014          ELSE
5015             IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14
5016          ENDIF
5017     1 CONTINUE
5018       IF (IFOUND.EQ.0)
5019      &   STOP ' EVENTD: interacting target nucleon not found! '
5020
5021 * correct position of proj. lepton: assume position of target nucleon
5022       DO 3 I=1,4
5023          VHKK(I,1) = VHKK(I,IDX)
5024          WHKK(I,1) = WHKK(I,IDX)
5025     3 CONTINUE
5026
5027 * load initial momenta for conservation check
5028       IF (LEMCCK) THEN
5029          CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM)
5030          CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX),
5031      &                                                      2,IDUM,IDUM)
5032       ENDIF
5033
5034 * quasi-elastic scattering
5035       IF (NEUDEC.LT.9) THEN
5036          CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),
5037      &                                          PHKK(4,IDX),PHKK(5,IDX))
5038 *  CC event on p or n
5039       ELSEIF (NEUDEC.EQ.10) THEN
5040          CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX),
5041      &                     PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5042 *  NC event on p or n
5043       ELSEIF (NEUDEC.EQ.11) THEN
5044          CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX),
5045      &                     PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5046       ENDIF
5047
5048 * get final state particles from Lund-common and write them into HKKEVT
5049       NPOINT(1) = NHKK+1
5050       NPOINT(4) = NHKK+1
5051       NLINES = PYK(0,1)
5052       NHKK0  = NHKK+1
5053       DO 4 I=4,NLINES
5054          IF (K(I,1).EQ.1) THEN
5055             ID = K(I,2)
5056             PX = P(I,1)
5057             PY = P(I,2)
5058             PZ = P(I,3)
5059             PE = P(I,4)
5060             CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0)
5061             IDBJ = IDT_ICIHAD(ID)
5062             EKIN = PHKK(4,NHKK)-PHKK(5,NHKK)
5063             IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN
5064                IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16
5065             ENDIF
5066             VHKK(1,NHKK) = VHKK(1,IDX)
5067             VHKK(2,NHKK) = VHKK(2,IDX)
5068             VHKK(3,NHKK) = VHKK(3,IDX)
5069             VHKK(4,NHKK) = VHKK(4,IDX)
5070 C           IF (I.EQ.4) THEN
5071 C              WHKK(1,NHKK) = POLARX(1)
5072 C              WHKK(2,NHKK) = POLARX(2)
5073 C              WHKK(3,NHKK) = POLARX(3)
5074 C              WHKK(4,NHKK) = POLARX(4)
5075 C           ELSE
5076                WHKK(1,NHKK) = WHKK(1,IDX)
5077                WHKK(2,NHKK) = WHKK(2,IDX)
5078                WHKK(3,NHKK) = WHKK(3,IDX)
5079                WHKK(4,NHKK) = WHKK(4,IDX)
5080 C           ENDIF
5081             IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
5082          ENDIF
5083     4 CONTINUE
5084
5085       IF (LEMCCK) THEN
5086          CHKLEV = TINY5
5087          CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1)
5088          IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
5089       ENDIF
5090
5091 * transform momenta into cms (as required for inc etc.)
5092       DO 5 I=NHKK0,NHKK
5093          IF (ISTHKK(I).EQ.1) THEN
5094             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3)
5095             PHKK(3,I) = PZ
5096             PHKK(4,I) = PE
5097          ENDIF
5098     5 CONTINUE
5099
5100       RETURN
5101       END
5102
5103 *$ CREATE DT_KKEVNT.FOR
5104 *COPY DT_KKEVNT
5105 *
5106 *===kkevnt=============================================================*
5107 *
5108       SUBROUTINE DT_KKEVNT(KKMAT,IREJ)
5109
5110 ************************************************************************
5111 * Treatment of complete nucleus-nucleus or hadron-nucleus scattering   *
5112 * without nuclear effects (one event).                                 *
5113 * This subroutine is an update of the previous version (KKEVT) written *
5114 * by J. Ranft/ H.-J. Moehring.                                         *
5115 * This version dated 20.04.95 is written by S. Roesler                 *
5116 ************************************************************************
5117
5118       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5119       SAVE
5120       PARAMETER ( LINP = 10 ,
5121      &            LOUT = 6 ,
5122      &            LDAT = 9 )
5123       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10)
5124
5125       PARAMETER ( MAXNCL = 260,
5126      &            MAXVQU = MAXNCL,
5127      &            MAXSQU = 20*MAXVQU,
5128      &            MAXINT = MAXVQU+MAXSQU)
5129 * event history
5130       PARAMETER (NMXHKK=200000)
5131       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5132      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5133      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5134 * extended event history
5135       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5136      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5137      &                IHIST(2,NMXHKK)
5138 * flags for input different options
5139       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5140       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5141      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5142 * rejection counter
5143       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
5144      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
5145      &                IREXCI(3),IRDIFF(2),IRINC
5146 * statistics
5147       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5148      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5149      &                ICEVTG(8,0:30)
5150 * properties of interacting particles
5151       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5152 * Lorentz-parameters of the current interaction
5153       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5154      &                UMO,PPCM,EPROJ,PPROJ
5155 * flags for diffractive interactions (DTUNUC 1.x)
5156       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5157 * interface HADRIN-DPM
5158       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5159 * nucleon-nucleon event-generator
5160       CHARACTER*8 CMODEL
5161       LOGICAL LPHOIN
5162       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
5163 * coordinates of nucleons
5164       COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
5165 * interface between Glauber formalism and DPM
5166       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
5167      &                INTER1(MAXINT),INTER2(MAXINT)
5168 * Glauber formalism: collision properties
5169       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5170      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5171 * central particle production, impact parameter biasing
5172       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5173 **temporary
5174 * statistics: Glauber-formalism
5175       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5176 **
5177
5178       DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/
5179
5180       IREJ   = 0
5181       ICREQU = ICREQU+1
5182       NC     = 0
5183
5184     1 CONTINUE
5185       ICSAMP = ICSAMP+1
5186       NC     = NC+1
5187       IF (MOD(NC,10).EQ.0) THEN
5188          WRITE(LOUT,1000) NEVHKK
5189  1000    FORMAT(1X,'KKEVNT: event ',I8,' rejected!')
5190          GOTO 9999
5191       ENDIF
5192
5193 * initialize DTEVT1/DTEVT2
5194       CALL DT_EVTINI
5195
5196 * We need the following only in order to sample nucleon coordinates.
5197 * However we don't have parameters (cross sections, slope etc.)
5198 * for neutrinos available. Therefore switch projectile to proton
5199 * in this case.
5200       IF (MCGENE.EQ.4) THEN
5201          JJPROJ = 1
5202       ELSE
5203          JJPROJ = IJPROJ
5204       ENDIF
5205
5206    10 CONTINUE
5207       IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR.
5208 * make sure that Glauber-formalism is called each time the interaction
5209 * configuration changed
5210      &     (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR.
5211      &     (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN
5212 * sample number of nucleon-nucleon coll. according to Glauber-form.
5213          CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT)
5214          NWTSAM = NN
5215          NWASAM = NP
5216          NWBSAM = NT
5217          NEVOLD = NEVHKK
5218          IPOLD  = IP
5219          ITOLD  = IT
5220          JJPOLD = JJPROJ
5221          EPROLD = EPROJ
5222       ENDIF
5223
5224 * force diffractive particle production in h-K interactions
5225       IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND.
5226      &    (IP.EQ.1).AND.(NN.NE.1)) THEN
5227          NEVOLD = 0
5228          GOTO 10
5229       ENDIF
5230
5231 * check number of involved proj. nucl. (NP) if central prod.is requested
5232       IF (ICENTR.GT.0) THEN
5233          CALL DT_CHKCEN(IP,IT,NP,NT,IBACK)
5234          IF (IBACK.GT.0) GOTO 10
5235       ENDIF
5236
5237 * get initial nucleon-configuration in projectile and target
5238 * rest-system (including Fermi-momenta if requested)
5239       CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1)
5240       MODE = 2
5241       IF (EPROJ.LE.EHADTH) MODE = 3
5242       CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE)
5243
5244       IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN
5245
5246 * activate HADRIN at low energies (implemented for h-N scattering only)
5247          IF (EPROJ.LE.EHADHI) THEN
5248             IF (EHADTH.LT.ZERO) THEN
5249 *   smooth transition btwn. DPM and HADRIN
5250                FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO)
5251                RR   = DT_RNDM(FRAC)
5252                IF (RR.GT.FRAC) THEN
5253                   IF (IP.EQ.1) THEN
5254                      CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5255                      IF (IREJ1.GT.0) GOTO 1
5256                      RETURN
5257                   ELSE
5258                      WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5259                   ENDIF
5260                ENDIF
5261             ELSE
5262 *   fixed threshold for onset of production via HADRIN
5263                IF (EPROJ.LE.EHADTH) THEN
5264                   IF (IP.EQ.1) THEN
5265                      CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5266                      IF (IREJ1.GT.0) GOTO 1
5267                      RETURN
5268                   ELSE
5269                      WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5270                   ENDIF
5271                ENDIF
5272             ENDIF
5273          ENDIF
5274  1001    FORMAT(1X,'KKEVNT:   warning! interaction of proj. (m=',
5275      &          I3,') with target (m=',I3,')',/,11X,
5276      &          'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1,
5277      &          'GeV) cannot be handled')
5278
5279 * sampling of momentum-x fractions & flavors of chain ends
5280          CALL DT_SPLPTN(NN)
5281
5282 * Lorentz-transformation of wounded nucleons into nucl.-nucl. cms
5283          CALL DT_NUC2CM
5284
5285 * collect momenta of chain ends and put them into DTEVT1
5286          CALL DT_GETPTN(IP,NN,NCSY,IREJ1)
5287          IF (IREJ1.NE.0) GOTO 1
5288
5289       ENDIF
5290
5291 * handle chains including fragmentation (two-chain approximation)
5292       IF (MCGENE.EQ.1) THEN
5293 *  two-chain approximation
5294          CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1)
5295          IF (IREJ1.NE.0) THEN
5296             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT'
5297             GOTO 1
5298          ENDIF
5299       ELSEIF (MCGENE.EQ.2) THEN
5300 *  multiple-Po exchange including minijets
5301          CALL DT_EVENTB(NCSY,IREJ1)
5302          IF (IREJ1.NE.0) THEN
5303             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT'
5304             GOTO 1
5305          ENDIF
5306       ELSEIF (MCGENE.EQ.3) THEN
5307          STOP ' This version does not contain LEPTO !'
5308       ELSEIF (MCGENE.EQ.4) THEN
5309 *  quasi-elastic neutrino scattering
5310          CALL DT_EVENTD(IREJ1)
5311          IF (IREJ1.NE.0) THEN
5312             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT'
5313             GOTO 1
5314          ENDIF
5315       ELSE
5316          WRITE(LOUT,1002) MCGENE
5317  1002    FORMAT(1X,'KKEVNT:   warning! event-generator',I4,
5318      &         ' not available - program stopped')
5319          STOP
5320       ENDIF
5321
5322       RETURN
5323
5324  9999 CONTINUE
5325       IREJ = 1
5326       RETURN
5327       END
5328
5329 *$ CREATE DT_CHKCEN.FOR
5330 *COPY DT_CHKCEN
5331 *
5332 *===chkcen=============================================================*
5333 *
5334       SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK)
5335
5336 ************************************************************************
5337 * Check of number of involved projectile nucleons if central production*
5338 * is requested.                                                        *
5339 * Adopted from a part of the old KKEVT routine which was written by    *
5340 * J. Ranft/H.-J.Moehring.                                              *
5341 * This version dated 13.01.95 is written by S. Roesler                 *
5342 ************************************************************************
5343
5344       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5345       SAVE
5346       PARAMETER ( LINP = 10 ,
5347      &            LOUT = 6 ,
5348      &            LDAT = 9 )
5349
5350 * statistics
5351       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5352      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5353      &                ICEVTG(8,0:30)
5354 * central particle production, impact parameter biasing
5355       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5356
5357       IBACK = 0
5358
5359 * old version
5360       IF (ICENTR.EQ.2) THEN
5361          IF (IP.LT.IT) THEN
5362             IF (IP.LE.8) THEN
5363                IF (NP.LT.IP-1) IBACK = 1
5364             ELSEIF (IP.LE.16) THEN
5365                IF (NP.LT.IP-2) IBACK = 1
5366             ELSEIF (IP.LE.32) THEN
5367                IF (NP.LT.IP-3) IBACK = 1
5368             ELSEIF (IP.GE.33) THEN
5369                IF (NP.LT.IP-5) IBACK = 1
5370             ENDIF
5371          ELSEIF (IP.EQ.IT) THEN
5372             IF (IP.EQ.32) THEN
5373                IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5374             ELSE
5375                IF (NP.LT.IP-IP/8) IBACK = 1
5376             ENDIF
5377          ELSEIF (ABS(IP-IT).LT.3) THEN
5378             IF (NP.LT.IP-IP/8) IBACK = 1
5379          ENDIF
5380       ELSE
5381 * new version (DPMJET, 5.6.99)
5382          IF (IP.LT.IT) THEN
5383             IF (IP.LE.8) THEN
5384                IF (NP.LT.IP-1) IBACK = 1
5385             ELSEIF (IP.LE.16) THEN
5386                IF (NP.LT.IP-2) IBACK = 1
5387             ELSEIF (IP.LT.32) THEN
5388                IF (NP.LT.IP-3) IBACK = 1
5389             ELSEIF (IP.GE.32) THEN
5390                IF (IT.LE.150) THEN
5391 *   Example: S-Ag
5392                   IF (NP.LT.IP-1) IBACK = 1
5393                ELSE
5394 *   Example: S-Au
5395                   IF (NP.LT.IP) IBACK = 1
5396                ENDIF
5397             ENDIF
5398          ELSEIF (IP.EQ.IT) THEN
5399 *   Example: S-S
5400            IF (IP.EQ.32) THEN
5401               IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5402 *   Example: Pb-Pb
5403            ELSE
5404               IF (NP.LT.IP-IP/4) IBACK = 1
5405            ENDIF
5406          ELSEIF (ABS(IP-IT).LT.3) THEN
5407             IF (NP.LT.IP-IP/8) IBACK = 1
5408          ENDIF
5409       ENDIF
5410
5411       ICCPRO = ICCPRO+1
5412
5413       RETURN
5414       END
5415
5416 *$ CREATE DT_ININUC.FOR
5417 *COPY DT_ININUC
5418 *
5419 *===ininuc=============================================================*
5420 *
5421       SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE)
5422
5423 ************************************************************************
5424 * Samples initial configuration of nucleons in nucleus with mass NMASS *
5425 * including Fermi-momenta (if reqested).                               *
5426 *          ID             BAMJET-code for hadrons (instead of nuclei)  *
5427 *          NMASS          mass number of nucleus (number of nucleons)  *
5428 *          NCH            charge of nucleus                            *
5429 *          COORD(3,NMASS) coordinates of nucleons inside nucleus in fm *
5430 *          JS(NMASS) > 0  nucleon undergoes nucleon-nucleon interact.  *
5431 *          IMODE = 1      projectile nucleus                           *
5432 *                = 2      target     nucleus                           *
5433 *                = 3      target     nucleus (E_lab<E_thr for HADRIN)  *
5434 * Adopted from a part of the old KKEVT routine which was written by    *
5435 * J. Ranft/H.-J.Moehring.                                              *
5436 * This version dated 13.01.95 is written by S. Roesler                 *
5437 ************************************************************************
5438
5439       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5440       SAVE
5441       PARAMETER ( LINP = 10 ,
5442      &            LOUT = 6 ,
5443      &            LDAT = 9 )
5444       PARAMETER (FM2MM=1.0D-12)
5445
5446       PARAMETER ( MAXNCL = 260,
5447      &            MAXVQU = MAXNCL,
5448      &            MAXSQU = 20*MAXVQU,
5449      &            MAXINT = MAXVQU+MAXSQU)
5450 * event history
5451       PARAMETER (NMXHKK=200000)
5452       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5453      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5454      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5455 * extended event history
5456       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5457      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5458      &                IHIST(2,NMXHKK)
5459 * flags for input different options
5460       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5461       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5462      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5463 * auxiliary common for chain system storage (DTUNUC 1.x)
5464       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5465 * nuclear potential
5466       LOGICAL LFERMI
5467       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5468      &                EBINDP(2),EBINDN(2),EPOT(2,210),
5469      &                ETACOU(2),ICOUL,LFERMI
5470 * properties of photon/lepton projectiles
5471       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5472 * particle properties (BAMJET index convention)
5473       CHARACTER*8  ANAME
5474       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5475      &                IICH(210),IIBAR(210),K1(210),K2(210)
5476 * Glauber formalism: collision properties
5477       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5478      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5479 * flavors of partons (DTUNUC 1.x)
5480       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5481      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5482      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
5483      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5484      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
5485      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5486      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
5487 * interface HADRIN-DPM
5488       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5489
5490       DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL)
5491
5492 * number of neutrons
5493       NNEU = NMASS-NCH
5494 * initializations
5495       NP = 0
5496       NN = 0
5497       DO 1 K=1,4
5498          PFTOT(K) = 0.0D0
5499     1 CONTINUE
5500       MODE   = IMODE
5501       IF (IMODE.GT.2) MODE = 2
5502 **sr 29.5. new NPOINT(1)-definition
5503 C     IF (IMODE.GE.2) NPOINT(1) = NHKK+1
5504 **
5505       NHADRI = 0
5506       NC     = NHKK
5507
5508 * get initial configuration
5509       DO 2 I=1,NMASS
5510          NHKK = NHKK+1
5511          IF (JS(I).GT.0) THEN
5512             ISTHKK(NHKK) = 10+MODE
5513             IF (IMODE.EQ.3) THEN
5514 *   additional treatment if HADRIN-generator is requested
5515                NHADRI = NHADRI+1
5516                IF (NHADRI.EQ.1) IDXTA  = NHKK
5517                IF (NHADRI.GT.1) ISTHKK(NHKK) = 14
5518             ENDIF
5519          ELSE
5520             ISTHKK(NHKK) = 12+MODE
5521          ENDIF
5522          IF (NMASS.GE.2) THEN
5523 *   treatment for nuclei
5524             FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS)
5525             RR   = DT_RNDM(FRAC)
5526             IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN
5527                IDX = 8
5528                NN  = NN+1
5529             ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN
5530                IDX = 1
5531                NP  = NP+1
5532             ELSEIF (NN.LT.NNEU) THEN
5533                IDX = 8
5534                NN  = NN+1
5535             ELSEIF (NP.LT.NCH)  THEN
5536                IDX = 1
5537                NP  = NP+1
5538             ENDIF
5539             IDHKK(NHKK) = IDT_IPDGHA(IDX)
5540             IDBAM(NHKK) = IDX
5541             IF (MODE.EQ.1) THEN
5542                IPOSP(I)  = NHKK
5543                KKPROJ(I) = IDX
5544             ELSE
5545                IPOST(I)  = NHKK
5546                KKTARG(I) = IDX
5547             ENDIF
5548             IF (IDX.EQ.1) THEN
5549                PFER = PFERMP(MODE)
5550                PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1))
5551             ELSE
5552                PFER = PFERMN(MODE)
5553                PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8))
5554             ENDIF
5555             CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX)
5556             DO 3 K=1,4
5557                PFTOT(K) = PFTOT(K)+PF(K)
5558                PHKK(K,NHKK) = PF(K)
5559     3       CONTINUE
5560             PHKK(5,NHKK) = AAM(IDX)
5561          ELSE
5562 *   treatment for hadrons
5563             IDHKK(NHKK)  = IDT_IPDGHA(ID)
5564             IDBAM(NHKK)  = ID
5565             PHKK(4,NHKK) = AAM(ID)
5566             PHKK(5,NHKK) = AAM(ID)
5567 C* VDM assumption
5568 C            IF (IDHKK(NHKK).EQ.22) THEN
5569 C               PHKK(4,NHKK) = AAM(33)
5570 C               PHKK(5,NHKK) = AAM(33)
5571 C            ENDIF
5572             IF (MODE.EQ.1) THEN
5573                IPOSP(I)  = NHKK
5574                KKPROJ(I) = ID
5575                PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
5576             ELSE
5577                IPOST(I)  = NHKK
5578                KKTARG(I) = ID
5579             ENDIF
5580          ENDIF
5581          DO 4 K=1,3
5582             VHKK(K,NHKK) = COORD(K,I)*FM2MM
5583             WHKK(K,NHKK) = COORD(K,I)*FM2MM
5584     4    CONTINUE
5585          IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM
5586          IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM
5587          VHKK(4,NHKK) = 0.0D0
5588          WHKK(4,NHKK) = 0.0D0
5589     2 CONTINUE
5590
5591 * balance Fermi-momenta
5592       IF (NMASS.GE.2) THEN
5593          DO 5 I=1,NMASS
5594             NC = NC+1
5595             DO 6 K=1,3
5596                PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
5597     6       CONTINUE
5598             PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
5599      &                        PHKK(2,NC)**2+PHKK(3,NC)**2)
5600     5    CONTINUE
5601       ENDIF
5602
5603       RETURN
5604       END
5605
5606 *$ CREATE DT_FER4M.FOR
5607 *COPY DT_FER4M
5608 *
5609 *===fer4m==============================================================*
5610 *
5611       SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
5612
5613 ************************************************************************
5614 * Sampling of nucleon Fermi-momenta from distributions at T=0.         *
5615 *                                   processed by S. Roesler, 17.10.95  *
5616 ************************************************************************
5617
5618       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5619       SAVE
5620       PARAMETER ( LINP = 10 ,
5621      &            LOUT = 6 ,
5622      &            LDAT = 9 )
5623
5624       LOGICAL LSTART
5625
5626 * particle properties (BAMJET index convention)
5627       CHARACTER*8  ANAME
5628       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5629      &                IICH(210),IIBAR(210),K1(210),K2(210)
5630 * nuclear potential
5631       LOGICAL LFERMI
5632       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5633      &                EBINDP(2),EBINDN(2),EPOT(2,210),
5634      &                ETACOU(2),ICOUL,LFERMI
5635
5636       DATA LSTART /.TRUE./
5637
5638       ILOOP = 0
5639       IF (LFERMI) THEN
5640          IF (LSTART) THEN
5641             WRITE(LOUT,1000)
5642  1000       FORMAT(/,1X,'FER4M:   sampling of Fermi-momenta activated')
5643             LSTART = .FALSE.
5644          ENDIF
5645     1    CONTINUE
5646          CALL DT_DFERMI(PABS)
5647          PABS = PFERM*PABS
5648 C        IF (PABS.GE.PBIND) THEN
5649 C           ILOOP = ILOOP+1
5650 C           IF (MOD(ILOOP,500).EQ.0) THEN
5651 C              WRITE(LOUT,1001) PABS,PBIND,ILOOP
5652 C1001          FORMAT(1X,'FER4M:    Fermi-mom. corr. for binding',
5653 C    &                ' energy ',2E12.3,I6)
5654 C           ENDIF
5655 C           GOTO 1
5656 C        ENDIF
5657          CALL DT_DPOLI(POLC,POLS)
5658          CALL DT_DSFECF(SFE,CFE)
5659          CXTA = POLS*CFE
5660          CYTA = POLS*SFE
5661          CZTA = POLC
5662          ET   = SQRT(PABS*PABS+AAM(KT)**2)
5663          PXT  = CXTA*PABS
5664          PYT  = CYTA*PABS
5665          PZT  = CZTA*PABS
5666       ELSE
5667          ET   = AAM(KT)
5668          PXT  = 0.0D0
5669          PYT  = 0.0D0
5670          PZT  = 0.0D0
5671       ENDIF
5672
5673       RETURN
5674       END
5675
5676 *$ CREATE DT_NUC2CM.FOR
5677 *COPY DT_NUC2CM
5678 *
5679 *===nuc2cm=============================================================*
5680 *
5681       SUBROUTINE DT_NUC2CM
5682
5683 ************************************************************************
5684 * Lorentz-transformation of all wounded nucleons from Lab. to nucl.-   *
5685 * nucl. cms. (This subroutine replaces NUCMOM.)                        *
5686 * This version dated 15.01.95 is written by S. Roesler                 *
5687 ************************************************************************
5688
5689       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5690       SAVE
5691       PARAMETER ( LINP = 10 ,
5692      &            LOUT = 6 ,
5693      &            LDAT = 9 )
5694       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
5695
5696 * event history
5697       PARAMETER (NMXHKK=200000)
5698       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5699      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5700      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5701 * extended event history
5702       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5703      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5704      &                IHIST(2,NMXHKK)
5705 * statistics
5706       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5707      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5708      &                ICEVTG(8,0:30)
5709 * properties of photon/lepton projectiles
5710       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5711 * particle properties (BAMJET index convention)
5712       CHARACTER*8  ANAME
5713       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5714      &                IICH(210),IIBAR(210),K1(210),K2(210)
5715 * Glauber formalism: collision properties
5716       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5717      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5718 **temporary
5719 * statistics: Glauber-formalism
5720       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5721 **
5722
5723       ICWP = 0
5724       ICWT = 0
5725       NWTACC = 0
5726       NWAACC = 0
5727       NWBACC = 0
5728
5729       NPOINT(1) = NHKK+1
5730       NEND      = NHKK
5731       DO 1 I=1,NEND
5732          IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN
5733             IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1
5734             IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1
5735             MODE = ISTHKK(I)-9
5736 C            IF (IDHKK(I).EQ.22) THEN
5737 C* VDM assumption
5738 C               PEIN = AAM(33)
5739 C               IDB  = 33
5740 C            ELSE
5741 C               PEIN = PHKK(4,I)
5742 C               IDB  = IDBAM(I)
5743 C            ENDIF
5744 C            CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
5745 C     &           PX,PY,PZ,PE,IDB,MODE)
5746             IF (PHKK(5,I).GT.ZERO) THEN
5747                CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
5748      &              PX,PY,PZ,PE,IDBAM(I),MODE)
5749             ELSE
5750                PX = PGAMM(1)
5751                PY = PGAMM(2)
5752                PZ = PGAMM(3)
5753                PE = PGAMM(4)
5754             ENDIF
5755             IST = ISTHKK(I)-2
5756             ID  = IDHKK(I)
5757 C* VDM assumption
5758 C            IF (ID.EQ.22) ID = 113
5759             CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0)
5760             IF (ISTHKK(I).EQ.11) ICWP = ICWP+1
5761             IF (ISTHKK(I).EQ.12) ICWT = ICWT+1
5762          ENDIF
5763     1 CONTINUE
5764
5765       NWTACC = MAX(NWAACC,NWBACC)
5766       ICDPR  = ICDPR+ICWP
5767       ICDTA  = ICDTA+ICWT
5768 **temporary
5769       IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
5770          CALL DT_EVTOUT(4)
5771          STOP
5772       ENDIF
5773
5774       RETURN
5775       END
5776
5777 *$ CREATE DT_SPLPTN.FOR
5778 *COPY DT_SPLPTN
5779 *
5780 *===splptn=============================================================*
5781 *
5782       SUBROUTINE DT_SPLPTN(NN)
5783
5784 ************************************************************************
5785 * SamPLing of ParToN momenta and flavors.                              *
5786 * This version dated 15.01.95 is written by S. Roesler                 *
5787 ************************************************************************
5788
5789       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5790       SAVE
5791       PARAMETER ( LINP = 10 ,
5792      &            LOUT = 6 ,
5793      &            LDAT = 9 )
5794
5795 * Lorentz-parameters of the current interaction
5796       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5797      &                UMO,PPCM,EPROJ,PPROJ
5798
5799 * sample flavors of sea-quarks
5800       CALL DT_SPLFLA(NN,1)
5801
5802 * sample x-values of partons at chain ends
5803       ECM = UMO
5804       CALL DT_XKSAMP(NN,ECM)
5805
5806 * samle flavors
5807       CALL DT_SPLFLA(NN,2)
5808
5809       RETURN
5810       END
5811
5812 *$ CREATE DT_SPLFLA.FOR
5813 *COPY DT_SPLFLA
5814 *
5815 *===splfla=============================================================*
5816 *
5817       SUBROUTINE DT_SPLFLA(NN,MODE)
5818
5819 ************************************************************************
5820 * SamPLing of FLAvors of partons at chain ends.                        *
5821 * This subroutine replaces FLKSAA/FLKSAM.                              *
5822 *            NN            number of nucleon-nucleon interactions      *
5823 *            MODE = 1      sea-flavors                                 *
5824 *                 = 2      valence-flavors                             *
5825 * Based on the original version written by J. Ranft/H.-J. Moehring.    *
5826 * This version dated 16.01.95 is written by S. Roesler                 *
5827 ************************************************************************
5828
5829       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5830       SAVE
5831       PARAMETER ( LINP = 10 ,
5832      &            LOUT = 6 ,
5833      &            LDAT = 9 )
5834
5835       PARAMETER ( MAXNCL = 260,
5836      &            MAXVQU = MAXNCL,
5837      &            MAXSQU = 20*MAXVQU,
5838      &            MAXINT = MAXVQU+MAXSQU)
5839 * flavors of partons (DTUNUC 1.x)
5840       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5841      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5842      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
5843      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5844      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
5845      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5846      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
5847 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5848       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
5849      &                IXPV,IXPS,IXTV,IXTS,
5850      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
5851      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
5852      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
5853      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
5854      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
5855      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
5856      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
5857      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
5858 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5859       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
5860      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
5861 * particle properties (BAMJET index convention)
5862       CHARACTER*8  ANAME
5863       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5864      &                IICH(210),IIBAR(210),K1(210),K2(210)
5865 * various options for treatment of partons (DTUNUC 1.x)
5866 * (chain recombination, Cronin,..)
5867       LOGICAL LCO2CR,LINTPT
5868       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
5869      &                LCO2CR,LINTPT
5870
5871       IF (MODE.EQ.1) THEN
5872 * sea-flavors
5873          DO 1 I=1,NN
5874             IPSQ(I)  = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5875             IPSAQ(I) = -IPSQ(I)
5876     1    CONTINUE
5877          DO 2 I=1,NN
5878             ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
5879             ITSAQ(I)= -ITSQ(I)
5880     2    CONTINUE
5881       ELSEIF (MODE.EQ.2) THEN
5882 * valence flavors
5883          DO 3 I=1,IXPV
5884             CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
5885     3    CONTINUE
5886          DO 4 I=1,IXTV
5887             CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
5888     4    CONTINUE
5889       ENDIF
5890
5891       RETURN
5892       END
5893
5894 *$ CREATE DT_GETPTN.FOR
5895 *COPY DT_GETPTN
5896 *
5897 *===getptn=============================================================*
5898 *
5899       SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
5900
5901 ************************************************************************
5902 * This subroutine collects partons at chain ends from temporary        *
5903 * commons and puts them into DTEVT1.                                   *
5904 * This version dated 15.01.95 is written by S. Roesler                 *
5905 ************************************************************************
5906
5907       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5908       SAVE
5909       PARAMETER ( LINP = 10 ,
5910      &            LOUT = 6 ,
5911      &            LDAT = 9 )
5912       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
5913
5914       LOGICAL LCHK
5915
5916       PARAMETER ( MAXNCL = 260,
5917      &            MAXVQU = MAXNCL,
5918      &            MAXSQU = 20*MAXVQU,
5919      &            MAXINT = MAXVQU+MAXSQU)
5920 * event history
5921       PARAMETER (NMXHKK=200000)
5922       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5923      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5924      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5925 * extended event history
5926       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5927      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5928      &                IHIST(2,NMXHKK)
5929 * flags for input different options
5930       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5931       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5932      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5933 * auxiliary common for chain system storage (DTUNUC 1.x)
5934       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5935 * statistics
5936       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5937      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5938      &                ICEVTG(8,0:30)
5939 * flags for diffractive interactions (DTUNUC 1.x)
5940       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5941 * x-values of partons (DTUNUC 1.x)
5942       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
5943      &                XTVQ(MAXVQU),XTVD(MAXVQU),
5944      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
5945      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
5946 * flavors of partons (DTUNUC 1.x)
5947       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5948      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5949      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
5950      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5951      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
5952      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5953      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
5954 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5955       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
5956      &                IXPV,IXPS,IXTV,IXTS,
5957      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
5958      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
5959      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
5960      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
5961      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
5962      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
5963      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
5964      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
5965 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
5966       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
5967      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
5968
5969       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
5970
5971       DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
5972
5973       IREJ      = 0
5974       NCSY      = 0
5975       NPOINT(2) = NHKK+1
5976
5977 * sea-sea chains
5978       DO 10 I=1,NSS
5979          IF (ISKPCH(1,I).EQ.99) GOTO 10
5980          ICCHAI(1,1) = ICCHAI(1,1)+2
5981          IDXP = INTSS1(I)
5982          IDXT = INTSS2(I)
5983          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
5984          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
5985          DO 11 K=1,4
5986             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
5987             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
5988             PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
5989             PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
5990    11    CONTINUE
5991          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
5992      &                                  +(PP1(3)+PT1(3))**2)
5993          ECH   = PP1(4)+PT1(4)
5994          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
5995          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
5996      &                                  +(PP2(3)+PT2(3))**2)
5997          ECH   = PP2(4)+PT2(4)
5998          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
5999          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6000             AM1 = SQRT(AM1)
6001             AM2 = SQRT(AM2)
6002             IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
6003 C              WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6004  5000          FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
6005             ENDIF
6006          ELSE
6007             WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6008          ENDIF
6009          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6010          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6011          IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6012          IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6013          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6014      &                                                    0,0,1)
6015          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6016      &                                                    0,0,1)
6017          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6018      &                                                    0,0,1)
6019          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6020      &                                                    0,0,1)
6021          NCSY = NCSY+1
6022    10 CONTINUE
6023
6024 * disea-sea chains
6025       DO 20 I=1,NDS
6026          IF (ISKPCH(2,I).EQ.99) GOTO 20
6027          ICCHAI(1,2) = ICCHAI(1,2)+2
6028          IDXP = INTDS1(I)
6029          IDXT = INTDS2(I)
6030          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6031          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6032          DO 21 K=1,4
6033             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6034             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6035             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6036             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6037    21    CONTINUE
6038          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6039      &                                  +(PP1(3)+PT1(3))**2)
6040          ECH   = PP1(4)+PT1(4)
6041          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6042          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6043      &                                  +(PP2(3)+PT2(3))**2)
6044          ECH   = PP2(4)+PT2(4)
6045          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6046          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6047             AM1 = SQRT(AM1)
6048             AM2 = SQRT(AM2)
6049             IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6050 C              WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6051  5001          FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
6052             ENDIF
6053          ELSE
6054             WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6055          ENDIF
6056          IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6057          IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6058          IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6059          IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6060          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6061      &                                                    0,0,2)
6062          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6063      &                                                    0,0,2)
6064          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6065      &                                                    0,0,2)
6066          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6067      &                                                    0,0,2)
6068          NCSY = NCSY+1
6069    20 CONTINUE
6070
6071 * sea-disea chains
6072       DO 30 I=1,NSD
6073          IF (ISKPCH(3,I).EQ.99) GOTO 30
6074          ICCHAI(1,3) = ICCHAI(1,3)+2
6075          IDXP = INTSD1(I)
6076          IDXT = INTSD2(I)
6077          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6078          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6079          DO 31 K=1,4
6080             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6081             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6082             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6083             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6084    31    CONTINUE
6085          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6086      &                                  +(PP1(3)+PT1(3))**2)
6087          ECH   = PP1(4)+PT1(4)
6088          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6089          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6090      &                                  +(PP2(3)+PT2(3))**2)
6091          ECH   = PP2(4)+PT2(4)
6092          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6093          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6094             AM1 = SQRT(AM1)
6095             AM2 = SQRT(AM2)
6096             IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6097 C              WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6098  5002          FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
6099             ENDIF
6100          ELSE
6101             WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6102          ENDIF
6103          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6104          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6105          IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6106          IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6107          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6108      &                                                    0,0,3)
6109          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6110      &                                                    0,0,3)
6111          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6112      &                                                    0,0,3)
6113          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6114      &                                                    0,0,3)
6115          NCSY = NCSY+1
6116    30 CONTINUE
6117
6118 * disea-valence chains
6119       DO 50 I=1,NDV
6120          IF (ISKPCH(5,I).EQ.99) GOTO 50
6121          ICCHAI(1,5) = ICCHAI(1,5)+2
6122          IDXP = INTDV1(I)
6123          IDXT = INTDV2(I)
6124          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6125          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6126          DO 51 K=1,4
6127             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6128             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6129             PT1(K) = XTVQ(IDXT) *PHKK(K,MOT)
6130             PT2(K) = XTVD(IDXT) *PHKK(K,MOT)
6131    51    CONTINUE
6132          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6133      &                                  +(PP1(3)+PT1(3))**2)
6134          ECH   = PP1(4)+PT1(4)
6135          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6136          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6137      &                                  +(PP2(3)+PT2(3))**2)
6138          ECH   = PP2(4)+PT2(4)
6139          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6140          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6141             AM1 = SQRT(AM1)
6142             AM2 = SQRT(AM2)
6143             IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6144 C              WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6145  5003          FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
6146             ENDIF
6147          ELSE
6148             WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6149          ENDIF
6150          IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6151          IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6152          IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6153          IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6154          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6155      &                                                    0,0,5)
6156          CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6157      &                                                    0,0,5)
6158          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6159      &                                                    0,0,5)
6160          CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6161      &                                                    0,0,5)
6162          NCSY = NCSY+1
6163    50 CONTINUE
6164
6165 * valence-sea chains
6166       DO 60 I=1,NVS
6167          IF (ISKPCH(6,I).EQ.99) GOTO 60
6168          ICCHAI(1,6) = ICCHAI(1,6)+2
6169          IDXP = INTVS1(I)
6170          IDXT = INTVS2(I)
6171          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6172          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6173          DO 61 K=1,4
6174             PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6175             PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6176             PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6177             PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6178    61    CONTINUE
6179          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6180          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6181          IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6182          IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6183          CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6184          IF (LCHK) THEN
6185             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6186      &                                                       0,0,6)
6187             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6188      &                                                       0,0,6)
6189             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6190      &                                                       0,0,6)
6191             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6192      &                                                       0,0,6)
6193             PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6194      &                                     +(PP1(3)+PT1(3))**2)
6195             ECH   = PP1(4)+PT1(4)
6196             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6197             PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6198      &                                     +(PP2(3)+PT2(3))**2)
6199             ECH   = PP2(4)+PT2(4)
6200             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6201          ELSE
6202             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6203      &                                                       0,0,6)
6204             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6205      &                                                       0,0,6)
6206             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6207      &                                                       0,0,6)
6208             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6209      &                                                       0,0,6)
6210             PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6211      &                                     +(PP1(3)+PT2(3))**2)
6212             ECH   = PP1(4)+PT2(4)
6213             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6214             PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6215      &                                     +(PP2(3)+PT1(3))**2)
6216             ECH   = PP2(4)+PT1(4)
6217             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6218          ENDIF
6219          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6220             AM1 = SQRT(AM1)
6221             AM2 = SQRT(AM2)
6222             IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
6223 C              WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6224  5004          FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
6225             ENDIF
6226          ELSE
6227             WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6228          ENDIF
6229          NCSY = NCSY+1
6230    60 CONTINUE
6231
6232 * sea-valence chains
6233       DO 40 I=1,NSV
6234          IF (ISKPCH(4,I).EQ.99) GOTO 40
6235          ICCHAI(1,4) = ICCHAI(1,4)+2
6236          IDXP = INTSV1(I)
6237          IDXT = INTSV2(I)
6238          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6239          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6240          DO 41 K=1,4
6241             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6242             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6243             PT1(K) = XTVD(IDXT) *PHKK(K,MOT)
6244             PT2(K) = XTVQ(IDXT) *PHKK(K,MOT)
6245    41    CONTINUE
6246          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6247      &                                  +(PP1(3)+PT1(3))**2)
6248          ECH   = PP1(4)+PT1(4)
6249          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6250          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6251      &                                  +(PP2(3)+PT2(3))**2)
6252          ECH   = PP2(4)+PT2(4)
6253          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6254          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6255             AM1 = SQRT(AM1)
6256             AM2 = SQRT(AM2)
6257             IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
6258 C              WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6259  5005          FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
6260             ENDIF
6261          ELSE
6262             WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6263          ENDIF
6264          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6265          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6266          IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6267          IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6268          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6269      &                                                    0,0,4)
6270          CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6271      &                                                    0,0,4)
6272          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6273      &                                                    0,0,4)
6274          CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6275      &                                                    0,0,4)
6276          NCSY = NCSY+1
6277    40 CONTINUE
6278
6279 * valence-disea chains
6280       DO 70 I=1,NVD
6281          IF (ISKPCH(7,I).EQ.99) GOTO 70
6282          ICCHAI(1,7) = ICCHAI(1,7)+2
6283          IDXP = INTVD1(I)
6284          IDXT = INTVD2(I)
6285          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6286          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6287          DO 71 K=1,4
6288             PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6289             PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6290             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6291             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6292    71    CONTINUE
6293          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6294          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6295          IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6296          IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6297          CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6298          IF (LCHK) THEN
6299             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6300      &                                                       0,0,7)
6301             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6302      &                                                       0,0,7)
6303             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6304      &                                                       0,0,7)
6305             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6306      &                                                       0,0,7)
6307             PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6308      &                                     +(PP1(3)+PT1(3))**2)
6309             ECH   = PP1(4)+PT1(4)
6310             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6311             PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6312      &                                     +(PP2(3)+PT2(3))**2)
6313             ECH   = PP2(4)+PT2(4)
6314             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6315          ELSE
6316             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6317      &                                                       0,0,7)
6318             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6319      &                                                       0,0,7)
6320             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6321      &                                                       0,0,7)
6322             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6323      &                                                       0,0,7)
6324             PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6325      &                                     +(PP1(3)+PT2(3))**2)
6326             ECH   = PP1(4)+PT2(4)
6327             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6328             PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6329      &                                     +(PP2(3)+PT1(3))**2)
6330             ECH   = PP2(4)+PT1(4)
6331             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6332          ENDIF
6333          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6334             AM1 = SQRT(AM1)
6335             AM2 = SQRT(AM2)
6336             IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6337 C              WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6338  5006          FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
6339             ENDIF
6340          ELSE
6341             WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6342          ENDIF
6343          NCSY = NCSY+1
6344    70 CONTINUE
6345
6346 * valence-valence chains
6347       DO 80 I=1,NVV
6348          IF (ISKPCH(8,I).EQ.99) GOTO 80
6349          ICCHAI(1,8) = ICCHAI(1,8)+2
6350          IDXP = INTVV1(I)
6351          IDXT = INTVV2(I)
6352          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6353          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6354          DO 81 K=1,4
6355             PP1(K) = XPVQ(IDXP)*PHKK(K,MOP)
6356             PP2(K) = XPVD(IDXP)*PHKK(K,MOP)
6357             PT1(K) = XTVD(IDXT)*PHKK(K,MOT)
6358             PT2(K) = XTVQ(IDXT)*PHKK(K,MOT)
6359    81    CONTINUE
6360          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6361          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6362          IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6363          IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6364
6365 * check for diffractive event
6366          IDIFF = 0
6367          IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
6368      &        (IP.EQ.1).AND.(NN.EQ.1)) THEN
6369             DO 800 K=1,4
6370                PP(K) = PP1(K)+PP2(K)
6371                PT(K) = PT1(K)+PT2(K)
6372   800       CONTINUE
6373             ISTCK = NHKK
6374             CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
6375      &                  IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
6376 C           IF (IREJ1.NE.0) GOTO 9999
6377             IF (IREJ1.NE.0) THEN
6378                IDIFF = 0
6379                NHKK  = ISTCK
6380             ENDIF
6381          ELSE
6382             IDIFF = 0
6383          ENDIF
6384
6385          IF (IDIFF.EQ.0) THEN
6386 *   valence-valence chain system
6387             CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6388             IF (LCHK) THEN
6389 *    baryon-baryon
6390                CALL DT_EVTPUT(-21,IFP1,MOP,0,
6391      &                     PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6392                CALL DT_EVTPUT(-22,IFT1,MOT,0,
6393      &                     PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6394                CALL DT_EVTPUT(-21,IFP2,MOP,0,
6395      &                     PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6396                CALL DT_EVTPUT(-22,IFT2,MOT,0,
6397      &                     PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6398                PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6399      &                                        +(PP1(3)+PT1(3))**2)
6400                ECH   = PP1(4)+PT1(4)
6401                AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6402                PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6403      &                                        +(PP2(3)+PT2(3))**2)
6404                ECH   = PP2(4)+PT2(4)
6405                AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6406             ELSE
6407 *    antibaryon-baryon
6408                CALL DT_EVTPUT(-21,IFP1,MOP,0,
6409      &                     PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6410                CALL DT_EVTPUT(-22,IFT2,MOT,0,
6411      &                     PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6412                CALL DT_EVTPUT(-21,IFP2,MOP,0,
6413      &                     PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6414                CALL DT_EVTPUT(-22,IFT1,MOT,0,
6415      &                     PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6416                PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6417      &                                        +(PP1(3)+PT2(3))**2)
6418                ECH   = PP1(4)+PT2(4)
6419                AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6420                PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6421      &                                        +(PP2(3)+PT1(3))**2)
6422                ECH   = PP2(4)+PT1(4)
6423                AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6424             ENDIF
6425             IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6426                AM1 = SQRT(AM1)
6427                AM2 = SQRT(AM2)
6428                IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
6429 C                 WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6430  5007             FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
6431                ENDIF
6432             ELSE
6433                WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6434             ENDIF
6435             NCSY = NCSY+1
6436          ENDIF
6437    80 CONTINUE
6438       IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
6439
6440 * energy-momentum & flavor conservation check
6441       IF (ABS(IDIFF).NE.1) THEN
6442          IF (IDIFF.NE.0) THEN
6443             IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0,
6444      &                                              1,3,10,IREJ)
6445          ELSE
6446             IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
6447      &                                              1,3,10,IREJ)
6448          ENDIF
6449          IF (IREJ.NE.0) THEN
6450             CALL DT_EVTOUT(4)
6451             STOP
6452          ENDIF
6453       ENDIF
6454
6455       RETURN
6456
6457  9999 CONTINUE
6458       IREJ  = 1
6459       RETURN
6460       END
6461
6462 *$ CREATE DT_CHKCSY.FOR
6463 *COPY DT_CHKCSY
6464 *
6465 *===chkcsy=============================================================*
6466 *
6467       SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
6468
6469 ************************************************************************
6470 * CHeCk Chain SYstem for consistency of partons at chain ends.         *
6471 *            ID1,ID2        PDG-numbers of partons at chain ends       *
6472 *            LCHK = .true.  consistent chain                           *
6473 *                 = .false. inconsistent chain                         *
6474 * This version dated 18.01.95 is written by S. Roesler                 *
6475 ************************************************************************
6476
6477       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6478       SAVE
6479       PARAMETER ( LINP = 10 ,
6480      &            LOUT = 6 ,
6481      &            LDAT = 9 )
6482
6483       LOGICAL LCHK
6484
6485       LCHK = .TRUE.
6486
6487 * q-aq chain
6488       IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN
6489          IF (ID1*ID2.GT.0) LCHK = .FALSE.
6490 * q-qq, aq-aqaq chain
6491       ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR.
6492      &        ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN
6493          IF (ID1*ID2.LT.0) LCHK = .FALSE.
6494 * qq-aqaq chain
6495       ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
6496          IF (ID1*ID2.GT.0) LCHK = .FALSE.
6497       ENDIF
6498
6499       RETURN
6500       END
6501
6502 *$ CREATE DT_EVENTA.FOR
6503 *COPY DT_EVENTA
6504 *
6505 *===eventa=============================================================*
6506 *
6507       SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
6508
6509 ************************************************************************
6510 * Treatment of nucleon-nucleon interactions in a two-chain             *
6511 * approximation.                                                       *
6512 *  (input) ID       BAMJET-index of projectile hadron (in case of      *
6513 *                   h-K scattering)                                    *
6514 *          IP/IT    mass number of projectile/target nucleus           *
6515 *          NCSY     number of two chain systems                        *
6516 *          IREJ     rejection flag                                     *
6517 * This version dated 15.01.95 is written by S. Roesler                 *
6518 ************************************************************************
6519
6520       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6521       SAVE
6522       PARAMETER ( LINP = 10 ,
6523      &            LOUT = 6 ,
6524      &            LDAT = 9 )
6525       PARAMETER (TINY10=1.0D-10)
6526
6527 * event history
6528       PARAMETER (NMXHKK=200000)
6529       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6530      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6531      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6532 * extended event history
6533       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6534      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6535      &                IHIST(2,NMXHKK)
6536 * rejection counter
6537       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6538      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6539      &                IREXCI(3),IRDIFF(2),IRINC
6540 * flags for diffractive interactions (DTUNUC 1.x)
6541       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6542 * particle properties (BAMJET index convention)
6543       CHARACTER*8  ANAME
6544       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6545      &                IICH(210),IIBAR(210),K1(210),K2(210)
6546 * flags for input different options
6547       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6548       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6549      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6550 * various options for treatment of partons (DTUNUC 1.x)
6551 * (chain recombination, Cronin,..)
6552       LOGICAL LCO2CR,LINTPT
6553       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6554      &                LCO2CR,LINTPT
6555
6556       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
6557
6558       IREJ      = 0
6559       NPOINT(3) = NHKK+1
6560
6561 * skip following treatment for low-mass diffraction
6562       IF (ABS(IFLAGD).EQ.1) THEN
6563          NPOINT(3) = NPOINT(2)
6564          GOTO 5
6565       ENDIF
6566
6567 * multiple scattering of chain ends
6568       IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
6569       IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
6570
6571       NC = NPOINT(2)
6572 * get a two-chain system from DTEVT1
6573       DO 3 I=1,NCSY
6574          IFP1 = IDHKK(NC)
6575          IFT1 = IDHKK(NC+1)
6576          IFP2 = IDHKK(NC+2)
6577          IFT2 = IDHKK(NC+3)
6578          DO 4 K=1,4
6579             PP1(K) = PHKK(K,NC)
6580             PT1(K) = PHKK(K,NC+1)
6581             PP2(K) = PHKK(K,NC+2)
6582             PT2(K) = PHKK(K,NC+3)
6583     4    CONTINUE
6584          MOP1 = NC
6585          MOT1 = NC+1
6586          MOP2 = NC+2
6587          MOT2 = NC+3
6588          CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
6589      &               IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
6590          IF (IREJ1.GT.0) THEN
6591             IRHHA = IRHHA+1
6592             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
6593             GOTO 9999
6594          ENDIF
6595          NC = NC+4
6596     3 CONTINUE
6597
6598 * meson/antibaryon projectile:
6599 * sample single-chain valence-valence systems (Reggeon contrib.)
6600       IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN
6601          IF (IIBAR(ID).LE.0) CALL DT_VV2SCH
6602       ENDIF
6603
6604       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6605 * check DTEVT1 for remaining resonance mass corrections
6606          CALL DT_EVTRES(IREJ1)
6607          IF (IREJ1.GT.0) THEN
6608             IRRES(1) = IRRES(1)+1
6609             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA'
6610             GOTO 9999
6611          ENDIF
6612       ENDIF
6613
6614 * assign p_t to two-"chain" systems consisting of two resonances only
6615 * since only entries for chains will be affected, this is obsolete
6616 * in case of JETSET-fragmetation
6617       CALL DT_RESPT
6618
6619 * combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
6620       IF (LCO2CR) CALL DT_COM2CR
6621
6622     5 CONTINUE
6623
6624 * fragmentation of the complete event
6625 **uncomment for internal phojet-fragmentation
6626 C     CALL DT_EVTFRA(IREJ1)
6627       CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
6628       IF (IREJ1.GT.0) THEN
6629          IRFRAG = IRFRAG+1
6630          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
6631          GOTO 9999
6632       ENDIF
6633
6634 * decay of possible resonances (should be obsolete)
6635       CALL DT_DECAY1
6636
6637       RETURN
6638
6639  9999 CONTINUE
6640       IREVT = IREVT+1
6641       IREJ  = 1
6642       RETURN
6643       END
6644
6645 *$ CREATE DT_GETCSY.FOR
6646 *COPY DT_GETCSY
6647 *
6648 *===getcsy=============================================================*
6649 *
6650       SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
6651      &                  IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
6652
6653 ************************************************************************
6654 * This version dated 15.01.95 is written by S. Roesler                 *
6655 ************************************************************************
6656
6657       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6658       SAVE
6659       PARAMETER ( LINP = 10 ,
6660      &            LOUT = 6 ,
6661      &            LDAT = 9 )
6662       PARAMETER (TINY10=1.0D-10)
6663
6664 * event history
6665       PARAMETER (NMXHKK=200000)
6666       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6667      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6668      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6669 * extended event history
6670       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6671      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6672      &                IHIST(2,NMXHKK)
6673 * rejection counter
6674       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6675      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6676      &                IREXCI(3),IRDIFF(2),IRINC
6677 * flags for input different options
6678       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6679       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6680      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6681 * flags for diffractive interactions (DTUNUC 1.x)
6682       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6683
6684       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
6685      &          IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
6686
6687       IREJ  = 0
6688
6689 * get quark content of partons
6690       DO 1 I=1,2
6691          IFP1(I) = 0
6692          IFP2(I) = 0
6693          IFT1(I) = 0
6694          IFT2(I) = 0
6695     1 CONTINUE
6696       IFP1(1) = IDT_IPDG2B(IFPR1,1,2)
6697       IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2)
6698       IFP2(1) = IDT_IPDG2B(IFPR2,1,2)
6699       IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2)
6700       IFT1(1) = IDT_IPDG2B(IFTA1,1,2)
6701       IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2)
6702       IFT2(1) = IDT_IPDG2B(IFTA2,1,2)
6703       IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2)
6704
6705 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
6706       IDCH1 = 2
6707       IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1
6708       IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3
6709       IDCH2 = 2
6710       IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1
6711       IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3
6712
6713 * store initial configuration for energy-momentum cons. check
6714       IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
6715
6716 * sample intrinsic p_t at chain-ends
6717       CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2,
6718      &            PT1,IFTA1,IFT1,PT2,IFTA2,IFT2,
6719      &            AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1)
6720       IF (IREJ1.NE.0) THEN
6721          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY'
6722          IRPT = IRPT+1
6723          GOTO 9999
6724       ENDIF
6725
6726 C      IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6727 C         IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
6728 C* check second chain for resonance
6729 C            CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6730 C     &                  AMCH2,AMCH2N,IDCH2,IREJ1)
6731 C            IF (IREJ1.NE.0) GOTO 9999
6732 C            IF (IDR2.NE.0) THEN
6733 C               CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6734 C     &                     AMCH2,AMCH2N,AMCH1,IREJ1)
6735 C               IF (IREJ1.NE.0) GOTO 9999
6736 C            ENDIF
6737 C* check first chain for resonance
6738 C            CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6739 C     &                  AMCH1,AMCH1N,IDCH1,IREJ1)
6740 C            IF (IREJ1.NE.0) GOTO 9999
6741 C            IF (IDR1.NE.0) IDR1 = 100*IDR1
6742 C         ELSE
6743 C* check first chain for resonance
6744 C            CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6745 C     &                  AMCH1,AMCH1N,IDCH1,IREJ1)
6746 C            IF (IREJ1.NE.0) GOTO 9999
6747 C            IF (IDR1.NE.0) THEN
6748 C               CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6749 C     &                     AMCH1,AMCH1N,AMCH2,IREJ1)
6750 C               IF (IREJ1.NE.0) GOTO 9999
6751 C            ENDIF
6752 C* check second chain for resonance
6753 C            CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6754 C     &                  AMCH2,AMCH2N,IDCH2,IREJ1)
6755 C            IF (IREJ1.NE.0) GOTO 9999
6756 C            IF (IDR2.NE.0) IDR2 = 100*IDR2
6757 C         ENDIF
6758 C      ENDIF
6759
6760       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
6761 * check chains for resonances
6762          CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6763      &               AMCH1,AMCH1N,IDCH1,IREJ1)
6764          IF (IREJ1.NE.0) GOTO 9999
6765          CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6766      &               AMCH2,AMCH2N,IDCH2,IREJ1)
6767          IF (IREJ1.NE.0) GOTO 9999
6768 * change kinematics corresponding to resonance-masses
6769          IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN
6770             CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6771      &                                 AMCH1,AMCH1N,AMCH2,IREJ1)
6772             IF (IREJ1.GT.0) GOTO 9999
6773             IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6774             CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
6775      &                  AMCH2,AMCH2N,IDCH2,IREJ1)
6776             IF (IREJ1.NE.0) GOTO 9999
6777             IF (IDR2.NE.0) IDR2 = 100*IDR2
6778          ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN
6779             CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6780      &                                 AMCH2,AMCH2N,AMCH1,IREJ1)
6781             IF (IREJ1.GT.0) GOTO 9999
6782             IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6783             CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
6784      &                  AMCH1,AMCH1N,IDCH1,IREJ1)
6785             IF (IREJ1.NE.0) GOTO 9999
6786             IF (IDR1.NE.0) IDR1 = 100*IDR1
6787          ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN
6788             AMDIF1 = ABS(AMCH1-AMCH1N)
6789             AMDIF2 = ABS(AMCH2-AMCH2N)
6790             IF (AMDIF2.LT.AMDIF1) THEN
6791                CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
6792      &                                    AMCH2,AMCH2N,AMCH1,IREJ1)
6793                IF (IREJ1.GT.0) GOTO 9999
6794                IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
6795                CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),
6796      &                     IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1)
6797                IF (IREJ1.NE.0) GOTO 9999
6798                IF (IDR1.NE.0) IDR1 = 100*IDR1
6799             ELSE
6800                CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
6801      &                                    AMCH1,AMCH1N,AMCH2,IREJ1)
6802                IF (IREJ1.GT.0) GOTO 9999
6803                IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
6804                CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),
6805      &                     IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1)
6806                IF (IREJ1.NE.0) GOTO 9999
6807                IF (IDR2.NE.0) IDR2 = 100*IDR2
6808             ENDIF
6809          ENDIF
6810       ENDIF
6811
6812 * store final configuration for energy-momentum cons. check
6813       IF (LEMCCK) THEN
6814          CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM)
6815          CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
6816          IF (IREJ1.NE.0) GOTO 9999
6817       ENDIF
6818
6819 * put partons and chains into DTEVT1
6820       DO 10 I=1,4
6821          PCH1(I) = PP1(I)+PT1(I)
6822          PCH2(I) = PP2(I)+PT2(I)
6823    10 CONTINUE
6824       CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2),
6825      &                                      PP1(3),PP1(4),0,0,0)
6826       CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2),
6827      &                                      PT1(3),PT1(4),0,0,0)
6828       KCH = 100+IDCH(MOP1)*10+1
6829       CALL DT_EVTPUT(KCH,88888,-2,-1,
6830      &           PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1))
6831       CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2),
6832      &                                      PP2(3),PP2(4),0,0,0)
6833       CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2),
6834      &                                      PT2(3),PT2(4),0,0,0)
6835       KCH = KCH+1
6836       CALL DT_EVTPUT(KCH,88888,-2,-1,
6837      &           PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
6838
6839       RETURN
6840
6841  9999 CONTINUE
6842       IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN
6843 * "cancel" sea-sea chains
6844          CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1)
6845          IF (IREJ1.NE.0) GOTO 9998
6846 **sr 16.5. flag for EVENTB
6847          IREJ = -1
6848          RETURN
6849       ENDIF
6850  9998 CONTINUE
6851       IREJ = 1
6852       RETURN
6853       END
6854
6855 *$ CREATE DT_CHKINE.FOR
6856 *COPY DT_CHKINE
6857 *
6858 *===chkine=============================================================*
6859 *
6860       SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
6861      &                  AMCH1,AMCH1N,AMCH2,IREJ)
6862
6863 ************************************************************************
6864 * This subroutine replaces CORMOM.                                     *
6865 * This version dated 05.01.95 is written by S. Roesler                 *
6866 ************************************************************************
6867
6868       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6869       SAVE
6870       PARAMETER ( LINP = 10 ,
6871      &            LOUT = 6 ,
6872      &            LDAT = 9 )
6873       PARAMETER (TINY10=1.0D-10)
6874
6875 * flags for input different options
6876       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6877       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6878      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6879 * rejection counter
6880       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6881      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6882      &                IREXCI(3),IRDIFF(2),IRINC
6883
6884       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
6885      &          PP1I(4),PP2I(4),PT1I(4),PT2I(4)
6886
6887       IREJ  = 0
6888       JMSHL = IMSHL
6889
6890       SCALE  = AMCH1N/MAX(AMCH1,TINY10)
6891       DO 10 I=1,4
6892          PP1(I) = PP1I(I)
6893          PP2(I) = PP2I(I)
6894          PT1(I) = PT1I(I)
6895          PT2(I) = PT2I(I)
6896          PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I)
6897          PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I)
6898          PP1(I) = SCALE*PP1(I)
6899          PT1(I) = SCALE*PT1(I)
6900    10 CONTINUE
6901       IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR.
6902      &    (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997
6903
6904       ECH = PP2(4)+PT2(4)
6905       PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+
6906      &                               (PP2(3)+PT2(3))**2 )
6907       AMCH22 = (ECH-PCH)*(ECH+PCH)
6908       IF (AMCH22.LT.0.0D0) THEN
6909          IF (IOULEV(1).GT.0)
6910      &      WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
6911          GOTO 9997
6912       ENDIF
6913
6914       AMCH1 = AMCH1N
6915       AMCH2 = SQRT(AMCH22)
6916
6917 * put partons again on mass shell
6918    13 CONTINUE
6919       XM1 = 0.0D0
6920       XM2 = 0.0D0
6921       IF (JMSHL.EQ.1) THEN
6922          XM1 = PYMASS(IFP1)
6923          XM2 = PYMASS(IFT1)
6924       ENDIF
6925       CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
6926       IF (IREJ1.NE.0) THEN
6927          IF (JMSHL.EQ.0) GOTO 9998
6928          JMSHL = 0
6929          GOTO 13
6930       ENDIF
6931       JMSHL = IMSHL
6932       DO 11 I=1,4
6933          PP1(I) = P1(I)
6934          PT1(I) = P2(I)
6935    11 CONTINUE
6936    14 CONTINUE
6937       XM1 = 0.0D0
6938       XM2 = 0.0D0
6939       IF (JMSHL.EQ.1) THEN
6940          XM1 = PYMASS(IFP2)
6941          XM2 = PYMASS(IFT2)
6942       ENDIF
6943       CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
6944       IF (IREJ1.NE.0) THEN
6945          IF (JMSHL.EQ.0) GOTO 9998
6946          JMSHL = 0
6947          GOTO 14
6948       ENDIF
6949       DO 12 I=1,4
6950          PP2(I) = P1(I)
6951          PT2(I) = P2(I)
6952    12 CONTINUE
6953       DO 15 I=1,4
6954          PP1I(I) = PP1(I)
6955          PP2I(I) = PP2(I)
6956          PT1I(I) = PT1(I)
6957          PT2I(I) = PT2(I)
6958    15 CONTINUE
6959       RETURN
6960
6961  9997 IRCHKI(1) = IRCHKI(1)+1
6962 **sr
6963 C     GOTO 9999
6964       IREJ = -1
6965       RETURN
6966 **
6967  9998 IRCHKI(2) = IRCHKI(2)+1
6968
6969  9999 CONTINUE
6970       IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
6971       IREJ = 1
6972       RETURN
6973       END
6974
6975 *$ CREATE DT_CH2RES.FOR
6976 *COPY DT_CH2RES
6977 *
6978 *===ch2res=============================================================*
6979 *
6980       SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
6981      &                  AM,AMN,IMODE,IREJ)
6982
6983 ************************************************************************
6984 * Check chains for resonance production.                               *
6985 * This subroutine replaces COMCMA/COBCMA/COMCM2                        *
6986 *    input:                                                            *
6987 *          IF1,2,3,4    input flavors (q,aq in any order)              *
6988 *          AM           chain mass                                     *
6989 *          MODE = 1     check q-aq chain for meson-resonance           *
6990 *               = 2     check q-qq, aq-aqaq chain for baryon-resonance *
6991 *               = 3     check qq-aqaq chain for lower mass cut         *
6992 *    output:                                                           *
6993 *          IDR = 0      no resonances found                            *
6994 *              = -1     pseudoscalar meson/octet baryon                *
6995 *              = 1      vector-meson/decuplet baryon                   *
6996 *          IDXR         BAMJET-index of corresponding resonance        *
6997 *          AMN          mass of corresponding resonance                *
6998 *                                                                      *
6999 *          IREJ         rejection flag                                 *
7000 * This version dated 06.01.95 is written by S. Roesler                 *
7001 ************************************************************************
7002
7003       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7004       SAVE
7005       PARAMETER ( LINP = 10 ,
7006      &            LOUT = 6 ,
7007      &            LDAT = 9 )
7008
7009 * particle properties (BAMJET index convention)
7010       CHARACTER*8  ANAME
7011       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7012      &                IICH(210),IIBAR(210),K1(210),K2(210)
7013 * quark-content to particle index conversion (DTUNUC 1.x)
7014       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
7015      &                IA08(6,21),IA10(6,21)
7016 * rejection counter
7017       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7018      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7019      &                IREXCI(3),IRDIFF(2),IRINC
7020 * flags for input different options
7021       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7022       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7023      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7024
7025       DIMENSION IF(4),JF(4)
7026
7027 **sr 4.7. test
7028 C     DATA AMLOM,AMLOB /0.08D0,0.2D0/
7029       DATA AMLOM,AMLOB /0.1D0,0.7D0/
7030 **
7031 C     DATA AMLOM,AMLOB /0.001D0,0.001D0/
7032
7033       MODE = ABS(IMODE)
7034
7035       IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN
7036          WRITE(LOUT,1000) MODE
7037  1000    FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/,
7038      &          1X,'        program stopped')
7039          STOP
7040       ENDIF
7041
7042       AMX  = AM
7043       IREJ = 0
7044       IDR  = 0
7045       IDXR = 0
7046       AMN  = AMX
7047       IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
7048       IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
7049
7050       IF(1) = IF1
7051       IF(2) = IF2
7052       IF(3) = IF3
7053       IF(4) = IF4
7054       NF = 0
7055       DO 100 I=1,4
7056          IF (IF(I).NE.0) THEN
7057             NF = NF+1
7058             JF(NF) = IF(I)
7059          ENDIF
7060   100 CONTINUE
7061       IF (NF.LE.MODE) THEN
7062          WRITE(LOUT,1001) MODE,IF
7063  1001    FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ',
7064      &   I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4)
7065          GOTO 9999
7066       ENDIF
7067
7068       GOTO (1,2,3) MODE
7069
7070 * check for meson resonance
7071     1 CONTINUE
7072       IFQ  = JF(1)
7073       IFAQ = ABS(JF(2))
7074       IF (JF(2).GT.0) THEN
7075          IFQ  = JF(2)
7076          IFAQ = ABS(JF(1))
7077       ENDIF
7078       IFPS = IMPS(IFAQ,IFQ)
7079       IFV  = IMVE(IFAQ,IFQ)
7080       AMPS = AAM(IFPS)
7081       AMV  = AAM(IFV)
7082       AMHI = AMV+0.3D0
7083       IF (AMX.LT.AMV) THEN
7084          IF (AMX.LT.AMPS) THEN
7085             IF (IMODE.GT.0) THEN
7086                IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999
7087             ELSE
7088                IF (AMX.LT.0.8D0*AMPS) GOTO 9999
7089             ENDIF
7090             LOMRES = LOMRES+1
7091          ENDIF
7092 *    replace chain by pseudoscalar meson
7093          IDR  = -1
7094          IDXR = IFPS
7095          AMN  = AMPS
7096       ELSEIF (AMX.LT.AMHI) THEN
7097 *    replace chain by vector-meson
7098          IDR  = 1
7099          IDXR = IFV
7100          AMN  = AMV
7101       ENDIF
7102       RETURN
7103
7104 * check for baryon resonance
7105     2 CONTINUE
7106       CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
7107       AM8  = AAM(JB8)
7108       AM10 = AAM(JB10)
7109       AMHI = AM10+0.3D0
7110       IF (AMX.LT.AM10) THEN
7111          IF (AMX.LT.AM8) THEN
7112             IF (IMODE.GT.0) THEN
7113                IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999
7114             ELSE
7115                IF (AMX.LT.0.8D0*AM8) GOTO 9999
7116             ENDIF
7117             LOBRES = LOBRES+1
7118          ENDIF
7119 *    replace chain by oktet baryon
7120          IDR  = -1
7121          IDXR = JB8
7122          AMN  = AM8
7123       ELSEIF (AMX.LT.AMHI) THEN
7124          IDR  = 1
7125          IDXR = JB10
7126          AMN  = AM10
7127       ENDIF
7128       RETURN
7129
7130 * check qq-aqaq for lower mass cut
7131     3 CONTINUE
7132 *   empirical definition of AMHI to allow for (b-antib)-pair prod.
7133       AMHI = 2.5D0
7134       IF (AMX.LT.AMHI) GOTO 9999
7135       RETURN
7136
7137  9999 CONTINUE
7138       IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
7139      &    WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
7140       IREJ = 1
7141       IRRES(2) = IRRES(2)+1
7142       RETURN
7143       END
7144
7145 *$ CREATE DT_RJSEAC.FOR
7146 *COPY DT_RJSEAC
7147 *
7148 *===rjseac=============================================================*
7149 *
7150       SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
7151
7152 ************************************************************************
7153 * ReJection of SEA-sea Chains.                                         *
7154 *         MOP1/2       entries of projectile sea-partons in DTEVT1     *
7155 *         MOT1/2       entries of projectile sea-partons in DTEVT1     *
7156 * This version dated 16.01.95 is written by S. Roesler                 *
7157 ************************************************************************
7158
7159       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7160       SAVE
7161       PARAMETER ( LINP = 10 ,
7162      &            LOUT = 6 ,
7163      &            LDAT = 9 )
7164       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
7165
7166 * event history
7167       PARAMETER (NMXHKK=200000)
7168       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7169      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7170      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7171 * extended event history
7172       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7173      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7174      &                IHIST(2,NMXHKK)
7175 * statistics
7176       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7177      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7178      &                ICEVTG(8,0:30)
7179
7180       DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
7181
7182       IREJ = 0
7183
7184 * projectile sea q-aq-pair
7185 *    indices of sea-pair
7186       IDXSEA(1,1) = MOP1
7187       IDXSEA(1,2) = MOP2
7188 *    index of mother-nucleon
7189       IDXNUC(1)   = JMOHKK(1,MOP1)
7190 *    status of valence quarks to be corrected
7191       ISTVAL(1)   = -21
7192
7193 * target sea q-aq-pair
7194 *    indices of sea-pair
7195       IDXSEA(2,1) = MOT1
7196       IDXSEA(2,2) = MOT2
7197 *    index of mother-nucleon
7198       IDXNUC(2)   = JMOHKK(1,MOT1)
7199 *    status of valence quarks to be corrected
7200       ISTVAL(2)   = -22
7201
7202       DO 1 N=1,2
7203          IDONE = 0
7204          DO 2 I=NPOINT(2),NHKK
7205             IF ((ISTHKK(I).EQ.ISTVAL(N)).AND.
7206      &          (JMOHKK(1,I).EQ.IDXNUC(N)))   THEN
7207 * valence parton found
7208 *    inrease 4-momentum by sea 4-momentum
7209                DO 3 K=1,4
7210                   PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
7211      &                                  PHKK(K,IDXSEA(N,2))
7212     3          CONTINUE
7213                PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
7214      &                              PHKK(2,I)**2-PHKK(3,I)**2))
7215 *    "cancel" sea-pair
7216                DO 4 J=1,2
7217                   ISTHKK(IDXSEA(N,J))   = 100
7218                   IDHKK(IDXSEA(N,J))    = 0
7219                   JMOHKK(1,IDXSEA(N,J)) = 0
7220                   JMOHKK(2,IDXSEA(N,J)) = 0
7221                   JDAHKK(1,IDXSEA(N,J)) = 0
7222                   JDAHKK(2,IDXSEA(N,J)) = 0
7223                   DO 5 K=1,4
7224                      PHKK(K,IDXSEA(N,J)) = ZERO
7225                      VHKK(K,IDXSEA(N,J)) = ZERO
7226                      WHKK(K,IDXSEA(N,J)) = ZERO
7227     5             CONTINUE
7228                   PHKK(5,IDXSEA(N,J)) = ZERO
7229     4          CONTINUE
7230                IDONE = 1
7231             ENDIF
7232     2    CONTINUE
7233          IF (IDONE.NE.1) THEN
7234             WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2
7235  1000       FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event',
7236      &                '-record!',/,1X,'        sea-quark pairs   ',
7237      &                2I5,4X,2I5,'   could not be canceled!')
7238             GOTO 9999
7239          ENDIF
7240     1 CONTINUE
7241       ICRJSS = ICRJSS+1
7242       RETURN
7243
7244  9999 CONTINUE
7245       IREJ = 1
7246       RETURN
7247       END
7248
7249 *$ CREATE DT_VV2SCH.FOR
7250 *COPY DT_VV2SCH
7251 *
7252 *===vv2sch=============================================================*
7253 *
7254       SUBROUTINE DT_VV2SCH
7255
7256 ************************************************************************
7257 * Change Valence-Valence chain systems to Single CHain systems for     *
7258 * hadron-nucleus collisions with meson or antibaryon projectile.       *
7259 * (Reggeon contribution)                                               *
7260 * The single chain system is approximately treated as one chain and a  *
7261 * meson at rest.                                                       *
7262 * This version dated 18.01.95 is written by S. Roesler                 *
7263 ************************************************************************
7264
7265       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7266       SAVE
7267       PARAMETER ( LINP = 10 ,
7268      &            LOUT = 6 ,
7269      &            LDAT = 9 )
7270       PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
7271
7272       LOGICAL LSTART
7273
7274 * event history
7275       PARAMETER (NMXHKK=200000)
7276       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7277      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7278      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7279 * extended event history
7280       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7281      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7282      &                IHIST(2,NMXHKK)
7283 * flags for input different options
7284       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7285       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7286      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7287 * statistics
7288       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7289      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7290      &                ICEVTG(8,0:30)
7291
7292       DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
7293      &          PCH2(4)
7294
7295       DATA LSTART /.TRUE./
7296
7297       IFSC  = 0
7298       IF (LSTART) THEN
7299          WRITE(LOUT,1000)
7300  1000    FORMAT(/,1X,'VV2SCH:  Reggeon contribution to valance-',
7301      &          'valence chains treated')
7302          LSTART = .FALSE.
7303       ENDIF
7304
7305       NSTOP = NHKK
7306
7307 * get index of first chain
7308       DO 1 I=NPOINT(3),NHKK
7309          IF (IDHKK(I).EQ.88888) THEN
7310             NC = I
7311             GOTO 2
7312          ENDIF
7313     1 CONTINUE
7314
7315     2 CONTINUE
7316       IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)
7317      &                        .AND.(NC.LT.NSTOP)) THEN
7318 * get valence-valence chains
7319          IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN
7320 *   get "mother"-hadron indices
7321             MO1   = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC)))
7322             MO2   = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC)))
7323             KPROJ = IDT_ICIHAD(IDHKK(MO1))
7324             KTARG = IDT_ICIHAD(IDHKK(MO2))
7325 *   Lab momentum of projectile hadron
7326             CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3)
7327             PTOT  = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+
7328      &                                  PHKK(3,MO1)**2)
7329
7330             SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
7331             IF (DT_RNDM(PTOT).LE.SICHAP) THEN
7332                ICVV2S = ICVV2S+1
7333 *   single chain requested
7334 *      get flavors of chain-end partons
7335                MO(1) = JMOHKK(1,NC)
7336                MO(2) = JMOHKK(2,NC)
7337                MO(3) = JMOHKK(1,NC+3)
7338                MO(4) = JMOHKK(2,NC+3)
7339                DO 3 I=1,4
7340                   IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
7341                   IF(I,2) = 0
7342                   IF (ABS(IDHKK(MO(I))).GE.1000)
7343      &               IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
7344     3          CONTINUE
7345 *      which one is the q-aq chain?
7346 *        N1,N1+1 - DTEVT1-entries for q-aq system
7347 *        N2,N2+1 - DTEVT1-entries for the other chain
7348                IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN
7349                   K1 = 1
7350                   K2 = 3
7351                   N1 = NC-2
7352                   N2 = NC+1
7353                ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
7354                   K1 = 3
7355                   K2 = 1
7356                   N1 = NC+1
7357                   N2 = NC-2
7358                ELSE
7359                   GOTO 10
7360                ENDIF
7361                DO 4 K=1,4
7362                   PP1(K) = PHKK(K,N1)
7363                   PT1(K) = PHKK(K,N1+1)
7364                   PP2(K) = PHKK(K,N2)
7365                   PT2(K) = PHKK(K,N2+1)
7366     4          CONTINUE
7367                AMCH1 = PHKK(5,N1+2)
7368                AMCH2 = PHKK(5,N2+2)
7369 *      get meson-identity corresponding to flavors of q-aq chain
7370                ITMP   = IRESRJ
7371                IRESRJ = 0
7372                CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1,
7373      &                     ZERO,AMCH1N,1,IDUM)
7374                IRESRJ = ITMP
7375 *      change kinematics of chains
7376                CALL DT_CHKINE(PP1,IDHKK(N1),  PP2,IDHKK(N2),
7377      &                     PT1,IDHKK(N1+1),PT2,IDHKK(N2+1),
7378      &                     AMCH1,AMCH1N,AMCH2,IREJ1)
7379                IF (IREJ1.NE.0) GOTO 10
7380 *      check second chain for resonance
7381                IDCHAI = 2
7382                IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3
7383                CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2),
7384      &                     IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1)
7385                IF (IREJ1.NE.0) GOTO 10
7386                IF (IDR2.NE.0) IDR2 = 100*IDR2
7387 *      add partons and chains to DTEVT1
7388                DO 5 K=1,4
7389                   PCH1(K) = PP1(K)+PT1(K)
7390                   PCH2(K) = PP2(K)+PT2(K)
7391     5          CONTINUE
7392                CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2),
7393      &                                             PP1(3),PP1(4),0,0,0)
7394                CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1),
7395      &                                      PT1(2),PT1(3),PT1(4),0,0,0)
7396                KCH = ISTHKK(N1+2)+100
7397                CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3),
7398      &                     PCH1(4),IDR1,IDXR1,IDCH(N1+2))
7399                IDHKK(N1+2) = 22222
7400                CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2),
7401      &                                             PP2(3),PP2(4),0,0,0)
7402                CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1),
7403      &                                      PT2(2),PT2(3),PT2(4),0,0,0)
7404                KCH = ISTHKK(N2+2)+100
7405                CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3),
7406      &                     PCH2(4),IDR2,IDXR2,IDCH(N2+2))
7407                IDHKK(N2+2) = 22222
7408             ENDIF
7409          ENDIF
7410       ELSE
7411          GOTO 11
7412       ENDIF
7413    10 CONTINUE
7414       NC = NC+6
7415       GOTO 2
7416
7417    11 CONTINUE
7418
7419       RETURN
7420       END
7421
7422 *$ CREATE DT_PHNSCH.FOR
7423 *COPY DT_PHNSCH
7424 *
7425 *=== phnsch ===========================================================*
7426 *
7427       DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB )
7428
7429 *----------------------------------------------------------------------*
7430 *                                                                      *
7431 *     Probability for Hadron Nucleon Single CHain interactions:        *
7432 *                                                                      *
7433 *     Created on 30 december 1993  by    Alfredo Ferrari & Paola Sala  *
7434 *                                                   Infn - Milan       *
7435 *                                                                      *
7436 *     Last change on 04-jan-94     by    Alfredo Ferrari               *
7437 *                                                                      *
7438 *             modified by J.R.for use in DTUNUC  6.1.94                *
7439 *                                                                      *
7440 *     Input variables:                                                 *
7441 *                      Kp = hadron projectile index (Part numbering    *
7442 *                           scheme)                                    *
7443 *                   Ktarg = target nucleon index (1=proton, 8=neutron) *
7444 *                    Plab = projectile laboratory momentum (GeV/c)     *
7445 *     Output variable:                                                 *
7446 *                  Phnsch = probability per single chain (particle     *
7447 *                           exchange) interactions                     *
7448 *                                                                      *
7449 *----------------------------------------------------------------------*
7450
7451       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7452       SAVE
7453
7454       PARAMETER ( LUNOUT = 6  )
7455       PARAMETER ( LUNERR = 6  )
7456       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
7457       PARAMETER ( ZERZER = 0.D+00 )
7458       PARAMETER ( ONEONE = 1.D+00 )
7459       PARAMETER ( TWOTWO = 2.D+00 )
7460       PARAMETER ( FIVFIV = 5.D+00 )
7461       PARAMETER ( HLFHLF = 0.5D+00 )
7462
7463       PARAMETER ( NALLWP = 39   )
7464       PARAMETER ( IDMAXP = 210  )
7465
7466       DIMENSION ICHRGE(39),AM(39)
7467
7468 * particle properties (BAMJET index convention)
7469       CHARACTER*8  ANAME
7470       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7471      &                IICH(210),IIBAR(210),K1(210),K2(210)
7472
7473       DIMENSION KPTOIP(210)
7474 * auxiliary common for reggeon exchange (DTUNUC 1.x)
7475       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
7476      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
7477      &                IQTCHR(-6:6),MQUARK(3,39)
7478
7479       DIMENSION SGTCOE (5,33), IHLP (NALLWP)
7480       DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15)
7481 CPH      SAVE SGTCOE, IHLP
7482 CPH      SAVE IQFSC1, IQFSC2, IQBSC1, IQBSC2
7483       EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1))
7484       EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11))
7485       EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19))
7486
7487 * Conversion from part to paprop numbering
7488       DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
7489      & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
7490      & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
7491
7492 *  1=baryon, 2=pion, 3=kaon, 4=antibaryon:
7493       DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
7494      &    2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
7495 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
7496       DATA  SGTCO1  /
7497 * 1st reaction: gamma p total
7498      &0.147 D+00, ZERZER  , ZERZER   , 0.0022D+00, -0.0170D+00,
7499 * 2nd reaction: gamma d total
7500      &0.300 D+00, ZERZER  , ZERZER   , 0.0095D+00, -0.057 D+00,
7501 * 3rd reaction: pi+ p total
7502      &16.4  D+00, 19.3D+00, -0.42D+00, 0.19  D+00, ZERZER     ,
7503 * 4th reaction: pi- p total
7504      &33.0  D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03  D+00,
7505 * 5th reaction: pi+/- d total
7506      &56.8  D+00, 42.2D+00, -1.45D+00, 0.65  D+00, -5.39  D+00,
7507 * 6th reaction: K+ p total
7508      &18.1  D+00, ZERZER  , ZERZER   , 0.26  D+00, -1.0   D+00,
7509 * 7th reaction: K+ n total
7510      &18.7  D+00, ZERZER  , ZERZER   , 0.21  D+00, -0.89  D+00,
7511 * 8th reaction: K+ d total
7512      &34.2  D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99  D+00,
7513 * 9th reaction: K- p total
7514      &32.1  D+00, ZERZER  , ZERZER   , 0.66  D+00, -5.6   D+00,
7515 * 10th reaction: K- n total
7516      &25.2  D+00, ZERZER  , ZERZER   , 0.38  D+00, -2.9   D+00/
7517 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
7518       DATA  SGTCO2  /
7519 * 11th reaction: K- d total
7520      &57.6  D+00, ZERZER  , ZERZER   , 1.17  D+00, -9.5   D+00,
7521 * 12th reaction: p p total
7522      &48.0  D+00, ZERZER  , ZERZER   , 0.522 D+00, -4.51  D+00,
7523 * 13th reaction: p n total
7524      &47.30 D+00, ZERZER  , ZERZER   , 0.513 D+00, -4.27  D+00,
7525 * 14th reaction: p d total
7526      &91.3  D+00, ZERZER  , ZERZER   , 1.05  D+00, -8.8   D+00,
7527 * 15th reaction: pbar p total
7528      &38.4  D+00, 77.6D+00, -0.64D+00, 0.26  D+00, -1.2   D+00,
7529 * 16th reaction: pbar n total
7530      &ZERZER    ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7   D+00,
7531 * 17th reaction: pbar d total
7532      &112.  D+00, 125.D+00, -1.08D+00, 1.14  D+00, -12.4  D+00,
7533 * 18th reaction: Lamda p total
7534      &30.4  D+00, ZERZER  , ZERZER   , ZERZER    , 1.6    D+00/
7535 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
7536       DATA SGTCO3  /
7537 * 19th reaction: pi+ p elastic
7538      &ZERZER    , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER     ,
7539 * 20th reaction: pi- p elastic
7540      &1.76  D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER     ,
7541 * 21st reaction: K+ p elastic
7542      &5.0   D+00, 8.1 D+00, -1.8 D+00, 0.16  D+00, -1.3   D+00,
7543 * 22nd reaction: K- p elastic
7544      &7.3   D+00, ZERZER  , ZERZER   , 0.29  D+00, -2.40  D+00,
7545 * 23rd reaction: p p elastic
7546      &11.9  D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85  D+00,
7547 * 24th reaction: p d elastic
7548      &16.1  D+00, ZERZER  , ZERZER   , 0.32  D+00, -3.4   D+00,
7549 * 25th reaction: pbar p elastic
7550      &10.2  D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28  D+00,
7551 * 26th reaction: pbar p elastic bis
7552      &10.6  D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41  D+00,
7553 * 27th reaction: pbar n elastic
7554      &36.5  D+00, ZERZER  , ZERZER   , ZERZER    , -11.9  D+00,
7555 * 28th reaction: Lamda p elastic
7556      &12.3  D+00, ZERZER  , ZERZER   , ZERZER    , -2.4   D+00,
7557 * 29th reaction: K- p ela bis
7558      &7.24  D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35  D+00,
7559 * 30th reaction: pi- p cx
7560      &ZERZER    ,0.912D+00, -1.22D+00, ZERZER    , ZERZER     ,
7561 * 31st reaction: K- p cx
7562      &ZERZER    , 3.39D+00, -1.75D+00, ZERZER    , ZERZER     ,
7563 * 32nd reaction: K+ n cx
7564      &ZERZER    , 7.18D+00, -2.01D+00, ZERZER    , ZERZER     ,
7565 * 33rd reaction: pbar p cx
7566      &ZERZER    , 18.8D+00, -2.01D+00, ZERZER    , ZERZER     /
7567 *
7568 *  +-------------------------------------------------------------------*
7569          ICHRGE(KTARG)=IICH(KTARG)
7570          AM    (KTARG)=AAM (KTARG)
7571 *  |  Check for pi0 (d-dbar)
7572       IF ( KP .NE. 26 ) THEN
7573          IP  = KPTOIP (KP)
7574          IF(IP.EQ.0)IP=1
7575          ICHRGE(IP)=IICH(KP)
7576          AM    (IP)=AAM (KP)
7577 *  |
7578 *  +-------------------------------------------------------------------*
7579 *  |
7580       ELSE
7581          IP = 23
7582          ICHRGE(IP)=0
7583       END IF
7584 *  |
7585 *  +-------------------------------------------------------------------*
7586 *  +-------------------------------------------------------------------*
7587 *  |  No such interactions for baryon-baryon
7588       IF ( IIBAR (KP) .GT. 0 ) THEN
7589          DT_PHNSCH = ZERZER
7590          RETURN
7591 *  |
7592 *  +-------------------------------------------------------------------*
7593 *  |  No "annihilation" diagram possible for K+ p/n
7594       ELSE IF ( IP .EQ. 15 ) THEN
7595          DT_PHNSCH = ZERZER
7596          RETURN
7597 *  |
7598 *  +-------------------------------------------------------------------*
7599 *  |  No "annihilation" diagram possible for K0 p/n
7600       ELSE IF ( IP .EQ. 24 ) THEN
7601          DT_PHNSCH = ZERZER
7602          RETURN
7603 *  |
7604 *  +-------------------------------------------------------------------*
7605 *  |  No "annihilation" diagram possible for Omebar p/n
7606       ELSE IF ( IP .GE. 38 ) THEN
7607          DT_PHNSCH = ZERZER
7608          RETURN
7609       END IF
7610 *  |
7611 *  +-------------------------------------------------------------------*
7612 *  +-------------------------------------------------------------------*
7613 *  |  If the momentum is larger than 50 GeV/c, compute the single
7614 *  |  chain probability at 50 GeV/c and extrapolate to the present
7615 *  |  momentum according to 1/sqrt(s)
7616 *  |  sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
7617 *  |  P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
7618 *  |  sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
7619 *  |  sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
7620 *  |                        x sqrt(s/s(50))
7621 *  |  P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
7622       IF ( PLAB .GT. 50.D+00 ) THEN
7623          PLA    = 50.D+00
7624          AMPSQ  = AM (IP)**2
7625          AMTSQ  = AM (KTARG)**2
7626          EPROJ  = SQRT ( PLAB**2 + AMPSQ )
7627          UMOSQ  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7628          EPROJ  = SQRT ( PLA**2 + AMPSQ )
7629          UMO50  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7630          UMORAT = SQRT ( UMOSQ / UMO50 )
7631 *  |
7632 *  +-------------------------------------------------------------------*
7633 *  |  P < 3 GeV/c
7634       ELSE IF ( PLAB .LT. 3.D+00 ) THEN
7635          PLA    = 3.D+00
7636          AMPSQ  = AM (IP)**2
7637          AMTSQ  = AM (KTARG)**2
7638          EPROJ  = SQRT ( PLAB**2 + AMPSQ )
7639          UMOSQ  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7640          EPROJ  = SQRT ( PLA**2 + AMPSQ )
7641          UMO50  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
7642          UMORAT = SQRT ( UMOSQ / UMO50 )
7643 *  |
7644 *  +-------------------------------------------------------------------*
7645 *  |  P < 50 GeV/c
7646       ELSE
7647          PLA    = PLAB
7648          UMORAT = ONEONE
7649       END IF
7650 *  |
7651 *  +-------------------------------------------------------------------*
7652       ALGPLA = LOG (PLA)
7653 *  +-------------------------------------------------------------------*
7654 *  |  Pions:
7655       IF ( IHLP (IP) .EQ. 2 ) THEN
7656          ACOF = SGTCOE (1,3)
7657          BCOF = SGTCOE (2,3)
7658          ENNE = SGTCOE (3,3)
7659          CCOF = SGTCOE (4,3)
7660          DCOF = SGTCOE (5,3)
7661 *  |  Compute the pi+ p total cross section:
7662          SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7663      &          + DCOF * ALGPLA
7664          ACOF = SGTCOE (1,19)
7665          BCOF = SGTCOE (2,19)
7666          ENNE = SGTCOE (3,19)
7667          CCOF = SGTCOE (4,19)
7668          DCOF = SGTCOE (5,19)
7669 *  |  Compute the pi+ p elastic cross section:
7670          SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7671      &          + DCOF * ALGPLA
7672 *  |  Compute the pi+ p inelastic cross section:
7673          SPPPIN = SPPPTT - SPPPEL
7674          ACOF = SGTCOE (1,4)
7675          BCOF = SGTCOE (2,4)
7676          ENNE = SGTCOE (3,4)
7677          CCOF = SGTCOE (4,4)
7678          DCOF = SGTCOE (5,4)
7679 *  |  Compute the pi- p total cross section:
7680          SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7681      &          + DCOF * ALGPLA
7682          ACOF = SGTCOE (1,20)
7683          BCOF = SGTCOE (2,20)
7684          ENNE = SGTCOE (3,20)
7685          CCOF = SGTCOE (4,20)
7686          DCOF = SGTCOE (5,20)
7687 *  |  Compute the pi- p elastic cross section:
7688          SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7689      &          + DCOF * ALGPLA
7690 *  |  Compute the pi- p inelastic cross section:
7691          SPMPIN = SPMPTT - SPMPEL
7692          SIGDIA = SPMPIN - SPPPIN
7693 *  |  +----------------------------------------------------------------*
7694 *  |  |  Charged pions: besides isospin consideration it is supposed
7695 *  |  |                 that (pi+ n)el is almost equal to (pi- p)el
7696 *  |  |                 and  (pi+ p)el "    "     "    "  (pi- n)el
7697 *  |  |                 and all are almost equal among each others
7698 *  |  |                 (reasonable above 5 GeV/c)
7699          IF ( ICHRGE (IP) .NE. 0 ) THEN
7700             KHELP = KTARG / 8
7701             JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP
7702             ACOF = SGTCOE (1,JREAC)
7703             BCOF = SGTCOE (2,JREAC)
7704             ENNE = SGTCOE (3,JREAC)
7705             CCOF = SGTCOE (4,JREAC)
7706             DCOF = SGTCOE (5,JREAC)
7707 *  |  |  Compute the total cross section:
7708             SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7709      &             + DCOF * ALGPLA
7710             JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP
7711             ACOF = SGTCOE (1,JREAC)
7712             BCOF = SGTCOE (2,JREAC)
7713             ENNE = SGTCOE (3,JREAC)
7714             CCOF = SGTCOE (4,JREAC)
7715             DCOF = SGTCOE (5,JREAC)
7716 *  |  |  Compute the elastic cross section:
7717             SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7718      &             + DCOF * ALGPLA
7719 *  |  |  Compute the inelastic cross section:
7720             SHNCIN = SHNCTT - SHNCEL
7721 *  |  |  Number of diagrams:
7722             NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP
7723 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7724             IQFSC1 = 1 + IP - 13
7725             IQFSC2 = 0
7726             IQBSC1 = 1 + KHELP
7727             IQBSC2 = 1 + IP - 13
7728 *  |  |
7729 *  |  +----------------------------------------------------------------*
7730 *  |  |  pi0: besides isospin consideration it is supposed that the
7731 *  |  |       elastic cross section is not very different from
7732 *  |  |       pi+ p and/or pi- p (reasonable above 5 GeV/c)
7733          ELSE
7734             KHELP  = KTARG / 8
7735             K2HLP  = ( KP - 23 ) / 3
7736 *  |  |  Number of diagrams:
7737 *  |  |  For u ubar (k2hlp=0):
7738 *           NDIAGR = 2 - KHELP
7739 *  |  |  For d dbar (k2hlp=1):
7740 *           NDIAGR = 2 + KHELP - K2HLP
7741             NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP
7742             SHNCIN = HLFHLF * ( SPPPIN + SPMPIN )
7743 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7744             IQFSC1 = 1 + K2HLP
7745             IQFSC2 = 0
7746             IQBSC1 = 1 + KHELP
7747             IQBSC2 = 2 - K2HLP
7748          END IF
7749 *  |  |
7750 *  |  +----------------------------------------------------------------*
7751 *  |                                                   end pi's
7752 *  +-------------------------------------------------------------------*
7753 *  |  Kaons:
7754       ELSE IF ( IHLP (IP) .EQ. 3 ) THEN
7755          ACOF = SGTCOE (1,6)
7756          BCOF = SGTCOE (2,6)
7757          ENNE = SGTCOE (3,6)
7758          CCOF = SGTCOE (4,6)
7759          DCOF = SGTCOE (5,6)
7760 *  |  Compute the K+ p total cross section:
7761          SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7762      &          + DCOF * ALGPLA
7763          ACOF = SGTCOE (1,21)
7764          BCOF = SGTCOE (2,21)
7765          ENNE = SGTCOE (3,21)
7766          CCOF = SGTCOE (4,21)
7767          DCOF = SGTCOE (5,21)
7768 *  |  Compute the K+ p elastic cross section:
7769          SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7770      &          + DCOF * ALGPLA
7771 *  |  Compute the K+ p inelastic cross section:
7772          SKPPIN = SKPPTT - SKPPEL
7773          ACOF = SGTCOE (1,9)
7774          BCOF = SGTCOE (2,9)
7775          ENNE = SGTCOE (3,9)
7776          CCOF = SGTCOE (4,9)
7777          DCOF = SGTCOE (5,9)
7778 *  |  Compute the K- p total cross section:
7779          SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7780      &          + DCOF * ALGPLA
7781          ACOF = SGTCOE (1,22)
7782          BCOF = SGTCOE (2,22)
7783          ENNE = SGTCOE (3,22)
7784          CCOF = SGTCOE (4,22)
7785          DCOF = SGTCOE (5,22)
7786 *  |  Compute the K- p elastic cross section:
7787          SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7788      &          + DCOF * ALGPLA
7789 *  |  Compute the K- p inelastic cross section:
7790          SKMPIN = SKMPTT - SKMPEL
7791          SIGDIA = HLFHLF * ( SKMPIN - SKPPIN )
7792 *  |  +----------------------------------------------------------------*
7793 *  |  |  Charged Kaons: actually only K-
7794          IF ( ICHRGE (IP) .NE. 0 ) THEN
7795             KHELP = KTARG / 8
7796 *  |  |  +-------------------------------------------------------------*
7797 *  |  |  |  Proton target:
7798             IF ( KHELP .EQ. 0 ) THEN
7799                SHNCIN = SKMPIN
7800 *  |  |  |  Number of diagrams:
7801                NDIAGR = 2
7802 *  |  |  |
7803 *  |  |  +-------------------------------------------------------------*
7804 *  |  |  |  Neutron target: besides isospin consideration it is supposed
7805 *  |  |  |              that (K- n)el is almost equal to (K- p)el
7806 *  |  |  |              (reasonable above 5 GeV/c)
7807             ELSE
7808                ACOF = SGTCOE (1,10)
7809                BCOF = SGTCOE (2,10)
7810                ENNE = SGTCOE (3,10)
7811                CCOF = SGTCOE (4,10)
7812                DCOF = SGTCOE (5,10)
7813 *  |  |  |  Compute the total cross section:
7814                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7815      &                + DCOF * ALGPLA
7816 *  |  |  |  Compute the elastic cross section:
7817                SHNCEL = SKMPEL
7818 *  |  |  |  Compute the inelastic cross section:
7819                SHNCIN = SHNCTT - SHNCEL
7820 *  |  |  |  Number of diagrams:
7821                NDIAGR = 1
7822             END IF
7823 *  |  |  |
7824 *  |  |  +-------------------------------------------------------------*
7825 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7826             IQFSC1 = 3
7827             IQFSC2 = 0
7828             IQBSC1 = 1 + KHELP
7829             IQBSC2 = 2
7830 *  |  |
7831 *  |  +----------------------------------------------------------------*
7832 *  |  |  K0's: (actually only K0bar)
7833          ELSE
7834             KHELP  = KTARG / 8
7835 *  |  |  +-------------------------------------------------------------*
7836 *  |  |  |  Proton target: (K0bar p)in supposed to be given by
7837 *  |  |  |                 (K- p)in - Sig_diagr
7838             IF ( KHELP .EQ. 0 ) THEN
7839                SHNCIN = SKMPIN - SIGDIA
7840 *  |  |  |  Number of diagrams:
7841                NDIAGR = 1
7842 *  |  |  |
7843 *  |  |  +-------------------------------------------------------------*
7844 *  |  |  |  Neutron target: (K0bar n)in supposed to be given by
7845 *  |  |  |                 (K- n)in + Sig_diagr
7846 *  |  |  |              besides isospin consideration it is supposed
7847 *  |  |  |              that (K- n)el is almost equal to (K- p)el
7848 *  |  |  |              (reasonable above 5 GeV/c)
7849             ELSE
7850                ACOF = SGTCOE (1,10)
7851                BCOF = SGTCOE (2,10)
7852                ENNE = SGTCOE (3,10)
7853                CCOF = SGTCOE (4,10)
7854                DCOF = SGTCOE (5,10)
7855 *  |  |  |  Compute the total cross section:
7856                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7857      &                + DCOF * ALGPLA
7858 *  |  |  |  Compute the elastic cross section:
7859                SHNCEL = SKMPEL
7860 *  |  |  |  Compute the inelastic cross section:
7861                SHNCIN = SHNCTT - SHNCEL + SIGDIA
7862 *  |  |  |  Number of diagrams:
7863                NDIAGR = 2
7864             END IF
7865 *  |  |  |
7866 *  |  |  +-------------------------------------------------------------*
7867 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7868             IQFSC1 = 3
7869             IQFSC2 = 0
7870             IQBSC1 = 1
7871             IQBSC2 = 1 + KHELP
7872          END IF
7873 *  |  |
7874 *  |  +----------------------------------------------------------------*
7875 *  |                                                   end Kaon's
7876 *  +-------------------------------------------------------------------*
7877 *  |  Antinucleons:
7878       ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN
7879 *  |  For momenta between 3 and 5 GeV/c the use of tabulated data
7880 *  |  should be implemented!
7881          ACOF = SGTCOE (1,15)
7882          BCOF = SGTCOE (2,15)
7883          ENNE = SGTCOE (3,15)
7884          CCOF = SGTCOE (4,15)
7885          DCOF = SGTCOE (5,15)
7886 *  |  Compute the pbar p total cross section:
7887          SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7888      &          + DCOF * ALGPLA
7889          IF ( PLA .LT. FIVFIV ) THEN
7890             JREAC = 26
7891          ELSE
7892             JREAC = 25
7893          END IF
7894          ACOF = SGTCOE (1,JREAC)
7895          BCOF = SGTCOE (2,JREAC)
7896          ENNE = SGTCOE (3,JREAC)
7897          CCOF = SGTCOE (4,JREAC)
7898          DCOF = SGTCOE (5,JREAC)
7899 *  |  Compute the pbar p elastic cross section:
7900          SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7901      &          + DCOF * ALGPLA
7902 *  |  Compute the pbar p inelastic cross section:
7903          SAPPIN = SAPPTT - SAPPEL
7904          ACOF = SGTCOE (1,12)
7905          BCOF = SGTCOE (2,12)
7906          ENNE = SGTCOE (3,12)
7907          CCOF = SGTCOE (4,12)
7908          DCOF = SGTCOE (5,12)
7909 *  |  Compute the p p total cross section:
7910          SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7911      &          + DCOF * ALGPLA
7912          ACOF = SGTCOE (1,23)
7913          BCOF = SGTCOE (2,23)
7914          ENNE = SGTCOE (3,23)
7915          CCOF = SGTCOE (4,23)
7916          DCOF = SGTCOE (5,23)
7917 *  |  Compute the p p elastic cross section:
7918          SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7919      &          + DCOF * ALGPLA
7920 *  |  Compute the K- p inelastic cross section:
7921          SPPINE = SPPTOT - SPPELA
7922          SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV
7923          KHELP  = KTARG / 8
7924 *  |  +----------------------------------------------------------------*
7925 *  |  |  Pbar:
7926          IF ( ICHRGE (IP) .NE. 0 ) THEN
7927             NDIAGR = 5 - KHELP
7928 *  |  |  +-------------------------------------------------------------*
7929 *  |  |  |  Proton target:
7930             IF ( KHELP .EQ. 0 ) THEN
7931 *  |  |  |  Number of diagrams:
7932                SHNCIN = SAPPIN
7933                PUUBAR = 0.8D+00
7934 *  |  |  |
7935 *  |  |  +-------------------------------------------------------------*
7936 *  |  |  |  Neutron target: it is supposed that (ap n)el is almost equal
7937 *  |  |  |                  to (ap p)el (reasonable above 5 GeV/c)
7938             ELSE
7939                ACOF = SGTCOE (1,16)
7940                BCOF = SGTCOE (2,16)
7941                ENNE = SGTCOE (3,16)
7942                CCOF = SGTCOE (4,16)
7943                DCOF = SGTCOE (5,16)
7944 *  |  |  |  Compute the total cross section:
7945                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
7946      &                + DCOF * ALGPLA
7947 *  |  |  |  Compute the elastic cross section:
7948                SHNCEL = SAPPEL
7949 *  |  |  |  Compute the inelastic cross section:
7950                SHNCIN = SHNCTT - SHNCEL
7951                PUUBAR = HLFHLF
7952             END IF
7953 *  |  |  |
7954 *  |  |  +-------------------------------------------------------------*
7955 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7956 *  |  |  there are different possibilities, make a random choiche:
7957             IQFSC1 = -1
7958             RNCHEN = DT_RNDM(PUUBAR)
7959             IF ( RNCHEN .LT. PUUBAR ) THEN
7960                IQFSC2 = -2
7961             ELSE
7962                IQFSC2 = -1
7963             END IF
7964             IQBSC1 = -IQFSC1 + KHELP
7965             IQBSC2 = -IQFSC2
7966 *  |  |
7967 *  |  +----------------------------------------------------------------*
7968 *  |  |  nbar:
7969          ELSE
7970             NDIAGR = 4 + KHELP
7971 *  |  |  +-------------------------------------------------------------*
7972 *  |  |  |  Proton target: (nbar p)in supposed to be given by
7973 *  |  |  |                 (pbar p)in - Sig_diagr
7974             IF ( KHELP .EQ. 0 ) THEN
7975                SHNCIN = SAPPIN - SIGDIA
7976                PDDBAR = HLFHLF
7977 *  |  |  |
7978 *  |  |  +-------------------------------------------------------------*
7979 *  |  |  |  Neutron target: (nbar n)el is supposed to be equal to
7980 *  |  |  |                  (pbar p)el (reasonable above 5 GeV/c)
7981             ELSE
7982 *  |  |  |  Compute the total cross section:
7983                SHNCTT = SAPPTT
7984 *  |  |  |  Compute the elastic cross section:
7985                SHNCEL = SAPPEL
7986 *  |  |  |  Compute the inelastic cross section:
7987                SHNCIN = SHNCTT - SHNCEL
7988                PDDBAR = 0.8D+00
7989             END IF
7990 *  |  |  |
7991 *  |  |  +-------------------------------------------------------------*
7992 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
7993 *  |  |  there are different possibilities, make a random choiche:
7994             IQFSC1 = -2
7995             RNCHEN = DT_RNDM(RNCHEN)
7996             IF ( RNCHEN .LT. PDDBAR ) THEN
7997                IQFSC2 = -1
7998             ELSE
7999                IQFSC2 = -2
8000             END IF
8001             IQBSC1 = -IQFSC1 + KHELP - 1
8002             IQBSC2 = -IQFSC2
8003          END IF
8004 *  |  |
8005 *  |  +----------------------------------------------------------------*
8006 *  |
8007 *  +-------------------------------------------------------------------*
8008 *  |  Others: not yet implemented
8009       ELSE
8010          SIGDIA = ZERZER
8011          SHNCIN = ONEONE
8012          NDIAGR = 0
8013          DT_PHNSCH = ZERZER
8014          RETURN
8015       END IF
8016 *  |                                                   end others
8017 *  +-------------------------------------------------------------------*
8018       DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN
8019       IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1)
8020      &       + IQECHR (IQBSC2)
8021       IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1)
8022      &       + IQBCHR (IQBSC2)
8023       IQECHC = IQECHC / 3
8024       IQBCHC = IQBCHC / 3
8025       IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1)
8026      &       + IQSCHR (IQBSC2)
8027       IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP))
8028      &       + IQSCHR (MQUARK(3,IP))
8029 *  +-------------------------------------------------------------------*
8030 *  |  Consistency check:
8031       IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN
8032          WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla',
8033      &                         DT_PHNSCH,KP,KTARG,PLA,' ****'
8034          WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla',
8035      &                         DT_PHNSCH,KP,KTARG,PLA,' ****'
8036          DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER )
8037          DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE )
8038       END IF
8039 *  |
8040 *  +-------------------------------------------------------------------*
8041 *  +-------------------------------------------------------------------*
8042 *  |  Consistency check:
8043       IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG)
8044      &     .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN
8045          WRITE (LUNOUT,*)
8046      &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8047      &      IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8048          WRITE (LUNERR,*)
8049      &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8050      &      IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8051       END IF
8052 *  |
8053 *  +-------------------------------------------------------------------*
8054 *  P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8055       IF ( UMORAT .GT. ONEPLS )
8056      &   DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH
8057      &                                 - ONEONE ) * UMORAT + ONEONE )
8058       RETURN
8059 *
8060       ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 )
8061       DT_SCHQUA = ONEONE
8062       JQFSC1 = IQFSC1
8063       JQFSC2 = IQFSC2
8064       JQBSC1 = IQBSC1
8065       JQBSC2 = IQBSC2
8066 *=== End of function Phnsch ===========================================*
8067       RETURN
8068       END
8069
8070 *$ CREATE DT_RESPT.FOR
8071 *COPY DT_RESPT
8072 *
8073 *===respt==============================================================*
8074 *
8075       SUBROUTINE DT_RESPT
8076
8077 ************************************************************************
8078 * Check DTEVT1 for two-resonance systems and sample intrinsic p_t.     *
8079 * This version dated 18.01.95 is written by S. Roesler                 *
8080 ************************************************************************
8081
8082       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8083       SAVE
8084       PARAMETER ( LINP = 10 ,
8085      &            LOUT = 6 ,
8086      &            LDAT = 9 )
8087       PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8088
8089 * event history
8090       PARAMETER (NMXHKK=200000)
8091       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8092      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8093      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8094 * extended event history
8095       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8096      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8097      &                IHIST(2,NMXHKK)
8098
8099 * get index of first chain
8100       DO 1 I=NPOINT(3),NHKK
8101          IF (IDHKK(I).EQ.88888) THEN
8102             NC = I
8103             GOTO 2
8104          ENDIF
8105     1 CONTINUE
8106
8107     2 CONTINUE
8108       IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN
8109 C        WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3)
8110 * skip VV-,SS- systems
8111          IF ((IDCH(NC  ).NE.1).AND.(IDCH(NC  ).NE.8).AND.
8112      &       (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN
8113 * check if both "chains" are resonances
8114             IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN
8115                CALL DT_SAPTRE(NC,NC+3)
8116             ENDIF
8117          ENDIF
8118       ELSE
8119          GOTO 3
8120       ENDIF
8121       NC = NC+6
8122       GOTO 2
8123
8124     3 CONTINUE
8125
8126       RETURN
8127       END
8128
8129 *$ CREATE DT_EVTRES.FOR
8130 *COPY DT_EVTRES
8131 *
8132 *===evtres=============================================================*
8133 *
8134       SUBROUTINE DT_EVTRES(IREJ)
8135
8136 ************************************************************************
8137 * This version dated 14.12.94 is written by S. Roesler                 *
8138 ************************************************************************
8139
8140       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8141       SAVE
8142       PARAMETER ( LINP = 10 ,
8143      &            LOUT = 6 ,
8144      &            LDAT = 9 )
8145       PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10)
8146
8147 * event history
8148       PARAMETER (NMXHKK=200000)
8149       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8150      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8151      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8152 * extended event history
8153       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8154      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8155      &                IHIST(2,NMXHKK)
8156 * flags for input different options
8157       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8158       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8159      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8160 * particle properties (BAMJET index convention)
8161       CHARACTER*8  ANAME
8162       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
8163      &                IICH(210),IIBAR(210),K1(210),K2(210)
8164
8165       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2)
8166
8167       IREJ = 0
8168
8169       DO 1 I=NPOINT(3),NHKK
8170          IF (ABS(IDRES(I)).GE.100) THEN
8171             AMMX = 0.0D0
8172             DO 2 J=NPOINT(3),NHKK
8173                IF (IDHKK(J).EQ.88888) THEN
8174                   IF (PHKK(5,J).GT.AMMX) THEN
8175                      AMMX = PHKK(5,J)
8176                      IMMX = J
8177                   ENDIF
8178                ENDIF
8179     2       CONTINUE
8180             IF (IDRES(IMMX).NE.0) THEN
8181                IF (IOULEV(3).GT.0) THEN
8182                   WRITE(LOUT,'(1X,A)')
8183      &               'EVTRES: no chain for correc. found'
8184 C                 GOTO 6
8185                   GOTO 9999
8186                ELSE
8187                   GOTO 9999
8188                ENDIF
8189             ENDIF
8190             IMO11  = JMOHKK(1,I)
8191             IMO12  = JMOHKK(2,I)
8192             IF (PHKK(3,IMO11).LT.0.0D0) THEN
8193                IMO11 = JMOHKK(2,I)
8194                IMO12 = JMOHKK(1,I)
8195             ENDIF
8196             IMO21  = JMOHKK(1,IMMX)
8197             IMO22  = JMOHKK(2,IMMX)
8198             IF (PHKK(3,IMO21).LT.0.0D0) THEN
8199                IMO21 = JMOHKK(2,IMMX)
8200                IMO22 = JMOHKK(1,IMMX)
8201             ENDIF
8202             AMCH1  = PHKK(5,I)
8203             AMCH1N = AAM(IDXRES(I))
8204
8205             IFPR1 = IDHKK(IMO11)
8206             IFPR2 = IDHKK(IMO21)
8207             IFTA1 = IDHKK(IMO12)
8208             IFTA2 = IDHKK(IMO22)
8209             DO 4 J=1,4
8210                PP1(J) = PHKK(J,IMO11)
8211                PP2(J) = PHKK(J,IMO21)
8212                PT1(J) = PHKK(J,IMO12)
8213                PT2(J) = PHKK(J,IMO22)
8214     4       CONTINUE
8215 * store initial configuration for energy-momentum cons. check
8216             IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1)
8217 * correct kinematics of second chain
8218             CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
8219      &                  AMCH1,AMCH1N,AMCH2,IREJ1)
8220             IF (IREJ1.NE.0) GOTO 9999
8221 * check now this chain for resonance mass
8222             IFP(1) = IDT_IPDG2B(IFPR2,1,2)
8223             IFP(2) = 0
8224             IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2)
8225             IFT(1) = IDT_IPDG2B(IFTA2,1,2)
8226             IFT(2) = 0
8227             IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2)
8228             IDCH2 = 2
8229             IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1
8230             IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3
8231             CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2,
8232      &                  AMCH2,AMCH2N,IDCH2,IREJ1)
8233             IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN
8234                IF (IOULEV(1).GT.0)
8235      &            WRITE(LOUT,*) ' correction for resonance not poss.'
8236 **sr test
8237 C              GOTO 1
8238 C              GOTO 9999
8239 **
8240             ENDIF
8241 * store final configuration for energy-momentum cons. check
8242             IF (LEMCCK) THEN
8243                CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1)
8244                CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
8245                IF (IREJ1.NE.0) GOTO 9999
8246             ENDIF
8247             DO 5 J=1,4
8248                PHKK(J,IMO11) = PP1(J)
8249                PHKK(J,IMO21) = PP2(J)
8250                PHKK(J,IMO12) = PT1(J)
8251                PHKK(J,IMO22) = PT2(J)
8252     5       CONTINUE
8253 * correct entries of chains
8254             DO 3 K=1,4
8255                PHKK(K,I)    = PHKK(K,IMO11)+PHKK(K,IMO12)
8256                PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22)
8257     3       CONTINUE
8258             AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2
8259             AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2-
8260      &            PHKK(3,IMMX)**2
8261 * ?? the following should now be obsolete
8262 **sr test
8263 C           IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN
8264             IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8265 **
8266                WRITE(LOUT,'(1X,A,4G10.3)')
8267      &          'EVTRES: inonsistent mass-corr.',AM1,AM2
8268 C              GOTO 9999
8269                GOTO 1
8270             ENDIF
8271             PHKK(5,I)    = SQRT(AM1)
8272             PHKK(5,IMMX) = SQRT(AM2)
8273             IDRES(I)     = IDRES(I)/100
8274             IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR.
8275      &          (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN
8276                WRITE(LOUT,'(1X,A,4G10.3)')
8277      &          'EVTRES: inconsistent chain-masses',
8278      &          PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2
8279                GOTO 9999
8280             ENDIF
8281          ENDIF
8282     1 CONTINUE
8283     6 CONTINUE
8284       RETURN
8285
8286  9999 CONTINUE
8287       IREJ = 1
8288       RETURN
8289       END
8290
8291 *$ CREATE DT_GETSPT.FOR
8292 *COPY DT_GETSPT
8293 *
8294 *===getspt=============================================================*
8295 *
8296       SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2,
8297      &                  PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2,
8298      &                  AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ)
8299
8300 ************************************************************************
8301 * This version dated 12.12.94 is written by S. Roesler                 *
8302 ************************************************************************
8303
8304       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8305       SAVE
8306       PARAMETER ( LINP = 10 ,
8307      &            LOUT = 6 ,
8308      &            LDAT = 9 )
8309       PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)
8310
8311 * various options for treatment of partons (DTUNUC 1.x)
8312 * (chain recombination, Cronin,..)
8313       LOGICAL LCO2CR,LINTPT
8314       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8315      &                LCO2CR,LINTPT
8316 * flags for input different options
8317       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8318       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8319      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8320 * flags for diffractive interactions (DTUNUC 1.x)
8321       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
8322
8323       DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4),
8324      &          PT2(4),PT2I(4),P1(4),P2(4),
8325      &          IFP1(2),IFP2(2),IFT1(2),IFT2(2),
8326      &          PTOTI(4),PTOTF(4),DIFF(4)
8327
8328       IC   = 0
8329       IREJ = 0
8330 C     B33P = 4.0D0
8331 C     B33T = 4.0D0
8332 C     IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
8333 C     IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
8334       REDU = 1.0D0
8335 C     B33P = 3.5D0
8336 C     B33T = 3.5D0
8337       B33P = 4.0D0
8338       B33T = 4.0D0
8339       IF (IDIFF.NE.0) THEN
8340          B33P = 16.0D0
8341          B33T = 16.0D0
8342       ENDIF
8343
8344       DO 1 I=1,4
8345          PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I)
8346          PP1(I)   = PP1I(I)
8347          PP2(I)   = PP2I(I)
8348          PT1(I)   = PT1I(I)
8349          PT2(I)   = PT2I(I)
8350     1 CONTINUE
8351 * get initial chain masses
8352       PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8353      &                               +(PP1(3)+PT1(3))**2)
8354       ECH   = PP1(4)+PT1(4)
8355       AM1   = (ECH+PTOCH)*(ECH-PTOCH)
8356       PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8357      &                               +(PP2(3)+PT2(3))**2)
8358       ECH   = PP2(4)+PT2(4)
8359       AM2   = (ECH+PTOCH)*(ECH-PTOCH)
8360       IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8361          IF (IOULEV(1).GT.0)
8362      &   WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1',
8363      &                              AM1,AM2
8364          GOTO 9999
8365       ENDIF
8366       AM1  = SQRT(AM1)
8367       AM2  = SQRT(AM2)
8368       AM1N = ZERO
8369       AM2N = ZERO
8370
8371       MODE = 0
8372 C      IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
8373 C        MODE = 0
8374 C      ELSE
8375 C         MODE = 1
8376 C         IF (AM1.LT.0.6) THEN
8377 C            B33P = 10.0D0
8378 C         ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
8379 CC           B33P = 4.0D0
8380 C         ENDIF
8381 C         IF (AM2.LT.0.6) THEN
8382 C            B33T = 10.0D0
8383 C         ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
8384 CC           B33T = 4.0D0
8385 C         ENDIF
8386 C      ENDIF
8387
8388 * check chain masses for very low mass chains
8389 C     CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8390 C    &            AM1,DUM,-IDCH1,IREJ1)
8391 C     CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8392 C    &            AM2,DUM,-IDCH2,IREJ2)
8393 C     IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
8394 C        B33P = 20.0D0
8395 C        B33T = 20.0D0
8396 C     ENDIF
8397
8398       JMSHL = IMSHL
8399
8400     2 CONTINUE
8401       IC = IC+1
8402       IF (MOD(IC,15).EQ.0) B33P  = 2.0D0*B33P
8403       IF (MOD(IC,15).EQ.0) B33T  = 2.0D0*B33T
8404       IF (MOD(IC,18).EQ.0) REDU  = 0.0D0
8405 C     IF (MOD(IC,19).EQ.0) JMSHL = 0
8406       IF (MOD(IC,20).EQ.0) GOTO 7
8407 C        WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
8408 C        RETURN
8409 C        GOTO 9999
8410 C     ENDIF
8411
8412 * get transverse momentum
8413       IF (LINTPT) THEN
8414          ES   = -2.0D0/(B33P**2)
8415      &          *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8416          HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0)
8417          HPSP = HPSP*REDU
8418          ES   = -2.0D0/(B33T**2)
8419      &          *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8420          HPST = SQRT(ES*ES+2.0D0*ES*0.94D0)
8421          HPST = HPST*REDU
8422       ELSE
8423          HPSP = ZERO
8424          HPST = ZERO
8425       ENDIF
8426       CALL DT_DSFECF(SFE1,CFE1)
8427       CALL DT_DSFECF(SFE2,CFE2)
8428       IF (MODE.EQ.0) THEN
8429          PP1(1) = PP1I(1)+HPSP*CFE1
8430          PP1(2) = PP1I(2)+HPSP*SFE1
8431          PP2(1) = PP2I(1)-HPSP*CFE1
8432          PP2(2) = PP2I(2)-HPSP*SFE1
8433          PT1(1) = PT1I(1)+HPST*CFE2
8434          PT1(2) = PT1I(2)+HPST*SFE2
8435          PT2(1) = PT2I(1)-HPST*CFE2
8436          PT2(2) = PT2I(2)-HPST*SFE2
8437       ELSE
8438          PP1(1) = PP1I(1)+HPSP*CFE1
8439          PP1(2) = PP1I(2)+HPSP*SFE1
8440          PT1(1) = PT1I(1)-HPSP*CFE1
8441          PT1(2) = PT1I(2)-HPSP*SFE1
8442          PP2(1) = PP2I(1)+HPST*CFE2
8443          PP2(2) = PP2I(2)+HPST*SFE2
8444          PT2(1) = PT2I(1)-HPST*CFE2
8445          PT2(2) = PT2I(2)-HPST*SFE2
8446       ENDIF
8447
8448 * put partons on mass shell
8449       XMP1 = 0.0D0
8450       XMT1 = 0.0D0
8451       IF (JMSHL.EQ.1) THEN
8452          XMP1 = PYMASS(IFPR1)
8453          XMT1 = PYMASS(IFTA1)
8454       ENDIF
8455       CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1)
8456       IF (IREJ1.NE.0) GOTO 2
8457       DO 3 I=1,4
8458          PTOTF(I) = P1(I)+P2(I)
8459          PP1(I)   = P1(I)
8460          PT1(I)   = P2(I)
8461     3 CONTINUE
8462       XMP2 = 0.0D0
8463       XMT2 = 0.0D0
8464       IF (JMSHL.EQ.1) THEN
8465          XMP2 = PYMASS(IFPR2)
8466          XMT2 = PYMASS(IFTA2)
8467       ENDIF
8468       CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1)
8469       IF (IREJ1.NE.0) GOTO 2
8470       DO 4 I=1,4
8471          PTOTF(I) = PTOTF(I)+P1(I)+P2(I)
8472          PP2(I)   = P1(I)
8473          PT2(I)   = P2(I)
8474     4 CONTINUE
8475
8476 * check consistency
8477       DO 5 I=1,4
8478          DIFF(I) = PTOTI(I)-PTOTF(I)
8479     5 CONTINUE
8480       IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR.
8481      &    (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN
8482          WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF
8483          GOTO 9999
8484       ENDIF
8485       PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2)
8486       AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) ))
8487       PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2)
8488       AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) ))
8489       PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2)
8490       AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) ))
8491       PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2)
8492       AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) ))
8493       IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR.
8494      &    (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3))
8495      &                                                           THEN
8496          WRITE(LOUT,'(1X,A,2(4G10.3,/))')
8497      &     'GETSPT: inconsistent masses',
8498      &     AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2
8499 * sr 22.11.00: commented. It should only have inconsistent masses for
8500 * ultrahigh energies due to rounding problems
8501 C        GOTO 9999
8502       ENDIF
8503
8504 * get chain masses
8505       PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8506      &                               +(PP1(3)+PT1(3))**2)
8507       ECH   = PP1(4)+PT1(4)
8508       AM1N  = (ECH+PTOCH)*(ECH-PTOCH)
8509       PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8510      &                               +(PP2(3)+PT2(3))**2)
8511       ECH   = PP2(4)+PT2(4)
8512       AM2N  = (ECH+PTOCH)*(ECH-PTOCH)
8513       IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN
8514          IF (IOULEV(1).GT.0)
8515      &   WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2',
8516      &                              AM1N,AM2N
8517          GOTO 2
8518       ENDIF
8519       AM1N = SQRT(AM1N)
8520       AM2N = SQRT(AM2N)
8521
8522 * check chain masses for very low mass chains
8523       CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8524      &            AM1N,DUM,-IDCH1,IREJ1)
8525       IF (IREJ1.NE.0) GOTO 2
8526       CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8527      &            AM2N,DUM,-IDCH2,IREJ2)
8528       IF (IREJ2.NE.0) GOTO 2
8529
8530     7 CONTINUE
8531       IF (AM1N.GT.ZERO) THEN
8532          AM1 = AM1N
8533          AM2 = AM2N
8534       ENDIF
8535       DO 6 I=1,4
8536          PP1I(I)   = PP1(I)
8537          PP2I(I)   = PP2(I)
8538          PT1I(I)   = PT1(I)
8539          PT2I(I)   = PT2(I)
8540     6 CONTINUE
8541
8542       RETURN
8543
8544  9999 CONTINUE
8545       IREJ = 1
8546       RETURN
8547       END
8548
8549 *$ CREATE DT_SAPTRE.FOR
8550 *COPY DT_SAPTRE
8551 *
8552 *===saptre=============================================================*
8553 *
8554       SUBROUTINE DT_SAPTRE(IDX1,IDX2)
8555
8556 ************************************************************************
8557 * p-t sampling for two-resonance systems. ("BAMJET-like" method)       *
8558 *        IDX1,IDX2       indices of resonances ("chains") in DTEVT1    *
8559 * Adopted from the original SAPTRE written by J. Ranft.                *
8560 * This version dated 18.01.95 is written by S. Roesler                 *
8561 ************************************************************************
8562
8563       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8564       SAVE
8565       PARAMETER ( LINP = 10 ,
8566      &            LOUT = 6 ,
8567      &            LDAT = 9 )
8568       PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8569
8570 * event history
8571       PARAMETER (NMXHKK=200000)
8572       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8573      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8574      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8575 * extended event history
8576       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8577      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8578      &                IHIST(2,NMXHKK)
8579 * flags for input different options
8580       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8581       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8582      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8583
8584       DIMENSION PA1(4),PA2(4),P1(4),P2(4)
8585
8586       DATA B3 /4.0D0/
8587
8588       ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1)
8589       ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2)
8590       ESMAX  = MIN(ESMAX1,ESMAX2)
8591       IF (ESMAX.LE.0.05D0) RETURN
8592
8593       HMA    = PHKK(5,IDX1)
8594       DO 1 K=1,4
8595          PA1(K) = PHKK(K,IDX1)
8596          PA2(K) = PHKK(K,IDX2)
8597     1 CONTINUE
8598
8599       IF (LEMCCK) THEN
8600          CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM)
8601          CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM)
8602       ENDIF
8603
8604       EXEB   = 0.0D0
8605       IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX)
8606       BEXP   = HMA*(1.0D0-EXEB)/B3
8607       AXEXP  = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2
8608       WA     = AXEXP/(BEXP+AXEXP)
8609       XAB    = DT_RNDM(WA)
8610    10 CONTINUE
8611 * ES is the transverse kinetic energy
8612       IF (XAB.LT.WA)THEN
8613         X  = DT_RNDM(WA)
8614         Y  = DT_RNDM(WA)
8615         ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7)
8616       ELSE
8617         X  = DT_RNDM(Y)
8618         ES = ABS(-LOG(X+TINY7)/B3)
8619       ENDIF
8620       IF (ES.GT.ESMAX) GOTO 10
8621       ES  = ES+HMA
8622 * transverse momentum
8623       HPS = SQRT((ES-HMA)*(ES+HMA))
8624
8625       CALL DT_DSFECF(SFE,CFE)
8626       HPX = HPS*CFE
8627       HPY = HPS*SFE
8628       PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY
8629       PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY
8630       IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN
8631
8632 C     PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3))
8633 C     PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3))
8634       PA1(1) = PA1(1)+HPX
8635       PA1(2) = PA1(2)+HPY
8636       PA2(1) = PA2(1)-HPX
8637       PA2(2) = PA2(2)-HPY
8638
8639 * put resonances on mass-shell again
8640       XM1 = PHKK(5,IDX1)
8641       XM2 = PHKK(5,IDX2)
8642       CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1)
8643       IF (IREJ1.NE.0) RETURN
8644
8645       IF (LEMCCK) THEN
8646          CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM)
8647          CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM)
8648          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1)
8649          IF (IREJ1.NE.0) RETURN
8650       ENDIF
8651
8652       DO 2 K=1,4
8653          PHKK(K,IDX1) = P1(K)
8654          PHKK(K,IDX2) = P2(K)
8655     2 CONTINUE
8656
8657       RETURN
8658       END
8659
8660 *$ CREATE DT_CRONIN.FOR
8661 *COPY DT_CRONIN
8662 *
8663 *===cronin=============================================================*
8664 *
8665       SUBROUTINE DT_CRONIN(INCL)
8666
8667 ************************************************************************
8668 * Cronin-Effect. Multiple scattering of partons at chain ends.         *
8669 *             INCL = 1     multiple sc. in projectile                  *
8670 *                  = 2     multiple sc. in target                      *
8671 * This version dated 05.01.96 is written by S. Roesler.                *
8672 ************************************************************************
8673
8674       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8675       SAVE
8676       PARAMETER ( LINP = 10 ,
8677      &            LOUT = 6 ,
8678      &            LDAT = 9 )
8679       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8680
8681 * event history
8682       PARAMETER (NMXHKK=200000)
8683       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8684      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8685      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8686 * extended event history
8687       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8688      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8689      &                IHIST(2,NMXHKK)
8690 * rejection counter
8691       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8692      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8693      &                IREXCI(3),IRDIFF(2),IRINC
8694 * Glauber formalism: collision properties
8695       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
8696      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
8697
8698       DIMENSION R(3),PIN(4),POUT(4),DEV(4)
8699
8700       DO 1 K=1,4
8701          DEV(K) = ZERO
8702     1 CONTINUE
8703
8704       DO 2 I=NPOINT(2),NHKK
8705          IF (ISTHKK(I).LT.0) THEN
8706 * get z-position of the chain
8707             R(1) = VHKK(1,I)*1.0D12
8708             IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC
8709             R(2) = VHKK(2,I)*1.0D12
8710             IDXNU = JMOHKK(1,I)
8711             IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) )
8712      &                             IDXNU = JMOHKK(1,I-1)
8713             IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) )
8714      &                             IDXNU = JMOHKK(1,I+1)
8715             R(3) = VHKK(3,IDXNU)*1.0D12
8716 * position of target parton the chain is connected to
8717             DO 3 K=1,4
8718                PIN(K) = PHKK(K,I)
8719     3       CONTINUE
8720 * multiple scattering of parton with DTEVT1-index I
8721             CALL DT_CROMSC(PIN,R,POUT,INCL)
8722 **testprint
8723 C           IF (NEVHKK.EQ.5) THEN
8724 C              AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2
8725 C              AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2
8726 C              AMIN = SIGN(SQRT(ABS(AMIN)),AMIN)
8727 C              AMOU = SIGN(SQRT(ABS(AMOU)),AMOU)
8728 C              WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU
8729 C              WRITE(6,'(A,4E15.5)')'PIN:       ',PIN
8730 C              WRITE(6,'(A,4E15.5)')'POUT:      ',POUT
8731 C           ENDIF
8732 **
8733 * increase accumulator by energy-momentum difference
8734             DO 4 K=1,4
8735                DEV(K)    = DEV(K)+POUT(K)-PIN(K)
8736                PHKK(K,I) = POUT(K)
8737     4       CONTINUE
8738             PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8739      &                           PHKK(2,I)**2-PHKK(3,I)**2))
8740          ENDIF
8741     2 CONTINUE
8742
8743 * dump accumulator to momenta of valence partons
8744       NVAL = 0
8745       ETOT = 0.0D0
8746       DO 5 I=NPOINT(2),NHKK
8747          IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8748             NVAL = NVAL+1
8749             ETOT = ETOT+PHKK(4,I)
8750          ENDIF
8751     5 CONTINUE
8752 C     WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4)
8753  1000 FORMAT(1X,'CRONIN :  number of val. partons ',I4,/,
8754      &       9X,4E12.4)
8755       DO 6 I=NPOINT(2),NHKK
8756          IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
8757             E = PHKK(4,I)
8758             DO 7 K=1,4
8759 C              PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL)
8760                PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT
8761     7       CONTINUE
8762             PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
8763      &                           PHKK(2,I)**2-PHKK(3,I)**2))
8764          ENDIF
8765     6 CONTINUE
8766
8767       RETURN
8768       END
8769
8770 *$ CREATE DT_CROMSC.FOR
8771 *COPY DT_CROMSC
8772 *
8773 *===cromsc=============================================================*
8774 *
8775       SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL)
8776
8777 ************************************************************************
8778 * Cronin-Effect. Multiple scattering of one parton passing through     *
8779 * nuclear matter.                                                      *
8780 *            PIN(4)       input 4-momentum of parton                   *
8781 *            POUT(4)      4-momentum of parton after mult. scatt.      *
8782 *            R(3)         spatial position of parton in target nucleus *
8783 *            INCL = 1     multiple sc. in projectile                   *
8784 *                 = 2     multiple sc. in target                       *
8785 * This is a revised version of the original version written by J. Ranft*
8786 * This version dated 17.01.95 is written by S. Roesler.                *
8787 ************************************************************************
8788
8789       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8790       SAVE
8791       PARAMETER ( LINP = 10 ,
8792      &            LOUT = 6 ,
8793      &            LDAT = 9 )
8794       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
8795
8796       LOGICAL LSTART
8797
8798 * rejection counter
8799       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
8800      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
8801      &                IREXCI(3),IRDIFF(2),IRINC
8802 * Glauber formalism: collision properties
8803       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
8804      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
8805 * various options for treatment of partons (DTUNUC 1.x)
8806 * (chain recombination, Cronin,..)
8807       LOGICAL LCO2CR,LINTPT
8808       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8809      &                LCO2CR,LINTPT
8810
8811       DIMENSION PIN(4),POUT(4),R(3)
8812
8813       DATA LSTART /.TRUE./
8814
8815       IRCRON(1) = IRCRON(1)+1
8816
8817       IF (LSTART) THEN
8818          WRITE(LOUT,1000) CRONCO
8819  1000    FORMAT(/,1X,'CROMSC:  multiple scattering of chain ends',
8820      &          ' treated',/,10X,'with parameter CRONCO = ',F5.2)
8821          LSTART = .FALSE.
8822       ENDIF
8823
8824       NCBACK = 0
8825       RNCL   = RPROJ
8826       IF (INCL.EQ.2) RNCL = RTARG
8827
8828 * Lorentz-transformation into Lab.
8829       MODE = -(INCL+1)
8830       CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE)
8831
8832       PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2)
8833       IF (PTOT.LE.8.0D0) GOTO 9997
8834
8835 * direction cosines of parton before mult. scattering
8836       COSX = PIN(1)/PTOT
8837       COSY = PIN(2)/PTOT
8838       COSZ = PZ/PTOT
8839
8840       RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2
8841       IF (RTESQ.GE.-TINY3) GOTO 9999
8842
8843 * calculate distance (DIST) from R to surface of nucleus (radius RNCL)
8844 * in the direction of particle motion
8845
8846       A    = COSX*R(1)+COSY*R(2)+COSZ*R(3)
8847       TMP  = A**2-RTESQ
8848       IF (TMP.LT.ZERO) GOTO 9998
8849       DIST = -A+SQRT(TMP)
8850
8851 * multiple scattering angle
8852       THETO = CRONCO*SQRT(DIST)/PTOT
8853       IF (THETO.GT.0.1D0) THETO=0.1D0
8854
8855     1 CONTINUE
8856 * Gaussian sampling of spatial angle
8857       CALL DT_RANNOR(R1,R2)
8858       THETA = ABS(R1*THETO)
8859       IF (THETA.GT.0.3D0) GOTO 9997
8860       CALL DT_DSFECF(SFE,CFE)
8861       COSTH = COS(THETA)
8862       SINTH = SIN(THETA)
8863
8864 * new direction cosines
8865       CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE,
8866      &                               COSXN,COSYN,COSZN)
8867
8868       POUT(1) = COSXN*PTOT
8869       POUT(2) = COSYN*PTOT
8870       PZ      = COSZN*PTOT
8871 * Lorentz-transformation into nucl.-nucl. cms
8872       MODE = INCL+1
8873       CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE)
8874
8875 C     IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
8876 C     IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN
8877       IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN
8878          THETO = THETO/2.0D0
8879          NCBACK = NCBACK+1
8880          IF (MOD(NCBACK,200).EQ.0) THEN
8881             WRITE(LOUT,1001) THETO,PIN,POUT
8882  1001       FORMAT(1X,'CROMSC: inconsistent scattering angle ',
8883      &             E12.4,/,1X,'        PIN :',4E12.4,/,
8884      &             1X,'       POUT:',4E12.4)
8885             GOTO 9997
8886          ENDIF
8887          GOTO 1
8888       ENDIF
8889
8890       RETURN
8891
8892  9997 IRCRON(2) = IRCRON(2)+1
8893       GOTO 9999
8894  9998 IRCRON(3) = IRCRON(3)+1
8895
8896  9999 CONTINUE
8897       DO 100 K=1,4
8898          POUT(K) = PIN(K)
8899   100 CONTINUE
8900       RETURN
8901       END
8902
8903 *$ CREATE DT_COM2CR.FOR
8904 *COPY DT_COM2CR
8905 *
8906 *===com2sr=============================================================*
8907 *
8908       SUBROUTINE DT_COM2CR
8909
8910 ************************************************************************
8911 * COMbine q-aq chains to Color Ropes (qq-aqaq).                        *
8912 *        CUTOF      parameter determining minimum number of not        *
8913 *                   combined q-aq chains                               *
8914 * This subroutine replaces KKEVCC etc.                                 *
8915 * This version dated 11.01.95 is written by S. Roesler.                *
8916 ************************************************************************
8917
8918       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8919       SAVE
8920       PARAMETER ( LINP = 10 ,
8921      &            LOUT = 6 ,
8922      &            LDAT = 9 )
8923
8924 * event history
8925       PARAMETER (NMXHKK=200000)
8926       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8927      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8928      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8929 * extended event history
8930       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8931      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8932      &                IHIST(2,NMXHKK)
8933 * statistics
8934       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
8935      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
8936      &                ICEVTG(8,0:30)
8937 * various options for treatment of partons (DTUNUC 1.x)
8938 * (chain recombination, Cronin,..)
8939       LOGICAL LCO2CR,LINTPT
8940       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8941      &                LCO2CR,LINTPT
8942
8943       DIMENSION IDXQA(248),IDXAQ(248)
8944
8945       ICCHAI(1,9) = ICCHAI(1,9)+1
8946       NQA = 0
8947       NAQ = 0
8948 * scan DTEVT1 for q-aq, aq-q chains
8949       DO 10 I=NPOINT(3),NHKK
8950 * skip "chains" which are resonances
8951          IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN
8952             MO1 = JMOHKK(1,I)
8953             MO2 = JMOHKK(2,I)
8954             IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN
8955 * q-aq, aq-q chain found, keep index
8956                IF (IDHKK(MO1).GT.0) THEN
8957                   NQA = NQA+1
8958                   IDXQA(NQA) = I
8959                ELSE
8960                   NAQ = NAQ+1
8961                   IDXAQ(NAQ) = I
8962                ENDIF
8963             ENDIF
8964          ENDIF
8965    10 CONTINUE
8966
8967 * minimum number of q-aq chains requested for the same projectile/
8968 * target
8969       NCHMIN = IDT_NPOISS(CUTOF)
8970
8971 * combine q-aq chains of the same projectile
8972       CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1)
8973 * combine q-aq chains of the same target
8974       CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2)
8975 * combine aq-q chains of the same projectile
8976       CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1)
8977 * combine aq-q chains of the same target
8978       CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2)
8979
8980       RETURN
8981       END
8982
8983 *$ CREATE DT_SCN4CR.FOR
8984 *COPY DT_SCN4CR
8985 *
8986 *===scn4cr=============================================================*
8987 *
8988       SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE)
8989
8990 ************************************************************************
8991 * SCan q-aq chains for Color Ropes.                                    *
8992 * This version dated 11.01.95 is written by S. Roesler.                *
8993 ************************************************************************
8994
8995       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8996       SAVE
8997       PARAMETER ( LINP = 10 ,
8998      &            LOUT = 6 ,
8999      &            LDAT = 9 )
9000
9001 * event history
9002       PARAMETER (NMXHKK=200000)
9003       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9004      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9005      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9006 * extended event history
9007       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9008      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9009      &                IHIST(2,NMXHKK)
9010
9011       DIMENSION IDXCH(248),IDXJN(248)
9012
9013       DO 1 I=1,NCH
9014          IF (IDXCH(I).GT.0) THEN
9015             NJOIN = 1
9016             IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I))))
9017             IDXJN(NJOIN) = I
9018             IF (I.LT.NCH) THEN
9019                DO 2 J=I+1,NCH
9020                   IF (IDXCH(J).GT.0) THEN
9021                      IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J))))
9022                      IF (IDXMO.EQ.IDXMO1) THEN
9023                         NJOIN = NJOIN+1
9024                         IDXJN(NJOIN) = J
9025                      ENDIF
9026                   ENDIF
9027     2          CONTINUE
9028             ENDIF
9029             IF (NJOIN.GE.NCHMIN+2) THEN
9030                NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0)
9031                DO 3 J=1,2*NJ,2
9032                   CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1)
9033                   IF (IREJ1.NE.0) GOTO 3
9034                   IDXCH(IDXJN(J))   = 0
9035                   IDXCH(IDXJN(J+1)) = 0
9036     3          CONTINUE
9037             ENDIF
9038          ENDIF
9039     1 CONTINUE
9040
9041       RETURN
9042       END
9043
9044 *$ CREATE DT_JOIN.FOR
9045 *COPY DT_JOIN
9046 *
9047 *===join===============================================================*
9048 *
9049       SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ)
9050
9051 ************************************************************************
9052 * This subroutine joins two q-aq chains to one qq-aqaq chain.          *
9053 *     IDX1, IDX2       DTEVT1 indices of chains to be joined           *
9054 * This version dated 11.01.95 is written by S. Roesler.                *
9055 ************************************************************************
9056
9057       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9058       SAVE
9059       PARAMETER ( LINP = 10 ,
9060      &            LOUT = 6 ,
9061      &            LDAT = 9 )
9062
9063 * event history
9064       PARAMETER (NMXHKK=200000)
9065       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9066      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9067      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9068 * extended event history
9069       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9070      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9071      &                IHIST(2,NMXHKK)
9072 * flags for input different options
9073       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9074       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9075      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9076 * statistics
9077       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9078      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9079      &                ICEVTG(8,0:30)
9080
9081       DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4)
9082
9083       IREJ   = 0
9084
9085       IDX(1) = IDX1
9086       IDX(2) = IDX2
9087       DO 1 I=1,2
9088          DO 2 J=1,2
9089             MO(I,J) = JMOHKK(J,IDX(I))
9090             ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2)
9091     2    CONTINUE
9092     1 CONTINUE
9093
9094 * check consistency
9095       IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR.
9096      &    (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR.
9097      &    ((ID(1,1)*ID(2,1)).LT.0).OR.
9098      &    ((ID(1,2)*ID(2,2)).LT.0)) THEN
9099          WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1),
9100      &                    MO(2,2)
9101  1000    FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':',
9102      &             2I5,' chain ',I4,':',2I5)
9103       ENDIF
9104
9105 * join chains
9106       DO 3 K=1,4
9107          PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))
9108          PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))
9109     3 CONTINUE
9110       IF1  = IDT_IB2PDG(ID(1,1),ID(2,1),2)
9111       IF2  = IDT_IB2PDG(ID(1,2),ID(2,2),2)
9112       IST1 = ISTHKK(MO(1,1))
9113       IST2 = ISTHKK(MO(1,2))
9114
9115 * put partons again on mass shell
9116       XM1 = 0.0D0
9117       XM2 = 0.0D0
9118       IF (IMSHL.EQ.1) THEN
9119          XM1 = PYMASS(IF1)
9120          XM2 = PYMASS(IF2)
9121       ENDIF
9122       CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1)
9123       IF (IREJ1.NE.0) GOTO 9999
9124       DO 4 I=1,4
9125          PP(I) = P1(I)
9126          PT(I) = P2(I)
9127     4 CONTINUE
9128
9129 * store new partons in DTEVT1
9130       CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4),
9131      &                                                       0,0,0)
9132       CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4),
9133      &                                                       0,0,0)
9134       DO 5 K=1,4
9135          PCH(K) = PP(K)+PT(K)
9136     5 CONTINUE
9137
9138 * check new chain for lower mass limit
9139       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
9140          AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2))
9141          CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM,
9142      &               AMCH,AMCHN,3,IREJ1)
9143          IF (IREJ1.NE.0) THEN
9144             NHKK = NHKK-2
9145             GOTO 9999
9146          ENDIF
9147       ENDIF
9148
9149       ICCHAI(2,9) = ICCHAI(2,9)+1
9150 * store new chain in DTEVT1
9151       KCH = 191
9152       CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9)
9153       IDHKK(IDX(1)) = 22222
9154       IDHKK(IDX(2)) = 22222
9155 * special treatment for space-time coordinates
9156       DO 6 K=1,4
9157          VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0
9158          WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0
9159     6 CONTINUE
9160       RETURN
9161
9162  9999 CONTINUE
9163       IREJ = 1
9164       RETURN
9165       END
9166
9167 *$ CREATE DT_XSGLAU.FOR
9168 *COPY DT_XSGLAU
9169 *
9170 *===xsglau=============================================================*
9171 *
9172       SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX)
9173
9174 ************************************************************************
9175 * Total, elastic, quasi-elastic, inelastic cross sections according to *
9176 * Glauber's approach.                                                  *
9177 *  NA / NB     mass numbers of proj./target nuclei                     *
9178 *  JJPROJ      bamjet-index of projectile (=1 in case of proj.nucleus) *
9179 *  XI,Q2I,ECMI kinematical variables x, Q^2, E_cm                      *
9180 *  IE,IQ       indices of energy and virtuality (the latter for gamma  *
9181 *              projectiles only)                                       *
9182 *  NIDX        index of projectile/target nucleus                      *
9183 * This version dated 17.3.98  is written by S. Roesler                 *
9184 ************************************************************************
9185
9186       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9187       SAVE
9188       PARAMETER ( LINP = 10 ,
9189      &            LOUT = 6 ,
9190      &            LDAT = 9 )
9191
9192       COMPLEX*16 CZERO,CONE,CTWO
9193       CHARACTER*12 CFILE
9194       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9195      &           ONETHI=ONE/THREE,TINY25=1.0D-25)
9196       PARAMETER (TWOPI  = 6.283185307179586454D+00,
9197      &           PI     = TWOPI/TWO,
9198      &           GEV2MB = 0.38938D0,
9199      &           GEV2FM = 0.1972D0,
9200      &           ALPHEM = ONE/137.0D0,
9201 * proton mass
9202      &           AMP    = 0.938D0,
9203      &           AMP2   = AMP**2,
9204 * approx. nucleon radius
9205      &           RNUCLE = 1.12D0)
9206
9207 * particle properties (BAMJET index convention)
9208       CHARACTER*8  ANAME
9209       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
9210      &                IICH(210),IIBAR(210),K1(210),K2(210)
9211       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9212       PARAMETER ( MAXNCL = 260,
9213      &            MAXVQU = MAXNCL,
9214      &            MAXSQU = 20*MAXVQU,
9215      &            MAXINT = MAXVQU+MAXSQU)
9216 * Glauber formalism: parameters
9217       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9218      &                BMAX(NCOMPX),BSTEP(NCOMPX),
9219      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9220      &                NSITEB,NSTATB
9221 * Glauber formalism: cross sections
9222       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
9223      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
9224      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
9225      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
9226      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
9227      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
9228      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
9229      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
9230      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
9231      &                BSLOPE,NEBINI,NQBINI
9232 * Glauber formalism: flags and parameters for statistics
9233       LOGICAL LPROD
9234       CHARACTER*8 CGLB
9235       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
9236 * nucleon-nucleon event-generator
9237       CHARACTER*8 CMODEL
9238       LOGICAL LPHOIN
9239       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
9240 * VDM parameter for photon-nucleus interactions
9241       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
9242 * parameters for hA-diffraction
9243       COMMON /DTDIHA/ DIBETA,DIALPH
9244
9245       COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL),
9246      &           OMPP11,OMPP12,OMPP21,OMPP22,
9247      &           DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP,
9248      &           PPTMP1,PPTMP2
9249       COMPLEX*16 C,CA,CI
9250       DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL),
9251      &          COOP2(3,MAXNCL),COOT2(3,MAXNCL),
9252      &          BPROD(KSITEB)
9253
9254       PARAMETER (NPOINT=16)
9255       DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
9256
9257       LOGICAL LFIRST,LOPEN
9258       DATA LFIRST,LOPEN /.TRUE.,.FALSE./
9259
9260       NTARG = ABS(NIDX)
9261 * for quasi-elastic neutrino scattering set projectile to proton
9262 * it should not have an effect since the whole Glauber-formalism is
9263 * not needed for these interactions..
9264       IF (MCGENE.EQ.4) THEN
9265          IJPROJ = 1
9266       ELSE
9267          IJPROJ = JJPROJ
9268       ENDIF
9269
9270       IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN
9271          I = INDEX(CGLB,' ')
9272          IF (I.EQ.0) THEN
9273             CFILE = CGLB//'.glb'
9274             OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN')
9275          ELSEIF (I.GT.1) THEN
9276             CFILE = CGLB(1:I-1)//'.glb'
9277             OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN')
9278          ELSE
9279             STOP 'XSGLAU 1'
9280          ENDIF
9281          LOPEN = .TRUE.
9282       ENDIF
9283
9284       CZERO  = DCMPLX(ZERO,ZERO)
9285       CONE   = DCMPLX(ONE,ZERO)
9286       CTWO   = DCMPLX(TWO,ZERO)
9287       NEBINI = IE
9288       NQBINI = IQ
9289
9290 * re-define kinematics
9291       S  = ECMI**2
9292       Q2 = Q2I
9293       X  = XI
9294 *  g(Q2=0)-A, h-A, A-A scattering
9295       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9296          Q2 = 0.0001D0
9297          X  = Q2/(S+Q2-AMP2)
9298 *  g(Q2>0)-A scattering
9299       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN
9300          X  = Q2/(S+Q2-AMP2)
9301       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9302          Q2 = (S-AMP2)*X/(ONE-X)
9303       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
9304          S  = Q2*(ONE-X)/X+AMP2
9305       ELSE
9306          WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X
9307          STOP
9308       ENDIF
9309       ECMNN(IE) = SQRT(S)
9310       Q2G(IQ)   = Q2
9311       XNU = (S+Q2-AMP2)/(TWO*AMP)
9312
9313 * parameters determining statistics in evaluating Glauber-xsection
9314       NSTATB = JSTATB
9315       NSITEB = JBINSB
9316       IF (NSITEB.GT.KSITEB) NSITEB = KSITEB
9317
9318 * set up interaction geometry (common /DTGLAM/)
9319 *  projectile/target radii
9320       RPRNCL = DT_RNCLUS(NA)
9321       RTANCL = DT_RNCLUS(NB)
9322       IF (IJPROJ.EQ.7) THEN
9323          RASH(1) = ZERO
9324          RBSH(NTARG) = RTANCL
9325          BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9326       ELSE
9327          IF (NIDX.LE.-1) THEN
9328             RASH(1)     = RPRNCL
9329             RBSH(NTARG) = RTANCL
9330             BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9331          ELSE
9332             RASH(NTARG) = RPRNCL
9333             RBSH(1)     = RTANCL
9334             BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1))
9335          ENDIF
9336       ENDIF
9337 *  maximum impact-parameter
9338       BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1)
9339
9340 * slope, rho ( Re(f(0))/Im(f(0)) )
9341       IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
9342          IF (MCGENE.EQ.2) THEN
9343             ZERO1 = ZERO
9344             CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3,
9345      &                                                   BSLOPE,0)
9346          ELSE
9347             BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
9348          ENDIF
9349          IF (ECMNN(IE).LE.3.0D0) THEN
9350             ROSH = -0.43D0
9351          ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN
9352             ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE))
9353          ELSEIF (ECMNN(IE).GT.50.0D0) THEN
9354             ROSH = 0.1D0
9355          ENDIF
9356       ELSEIF (IJPROJ.EQ.7) THEN
9357          ROSH = 0.1D0
9358       ELSE
9359          BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
9360          ROSH   = 0.01D0
9361       ENDIF
9362
9363 * projectile-nucleon xsection (in fm)
9364       IF (IJPROJ.EQ.7) THEN
9365          SIGSH = DT_SIGVP(X,Q2)/10.0D0
9366       ELSE
9367          ELAB  = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
9368          PLAB  = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
9369 C        SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
9370          DUMZER = ZERO
9371          CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
9372          SIGSH = SIGSH/10.0D0
9373       ENDIF
9374
9375 * parameters for projectile diffraction (hA scattering only)
9376       IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7)
9377      &                               .AND.(DIBETA.GE.ZERO)) THEN
9378          ZERO1 = ZERO
9379          CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0)
9380 C        DIBETA = SDIF1/STOT
9381          DIBETA = 0.2D0
9382          DIGAMM = SQRT(DIALPH**2+DIBETA**2)
9383          IF (DIBETA.LE.ZERO) THEN
9384             ALPGAM = ONE
9385          ELSE
9386             ALPGAM = DIALPH/DIGAMM
9387          ENDIF
9388          FACDI1 = ONE-ALPGAM
9389          FACDI2 = ONE+ALPGAM
9390          FACDI  = SQRT(FACDI1*FACDI2)
9391          WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM
9392       ELSE
9393          DIBETA = -1.0D0
9394          DIALPH = ZERO
9395          DIGAMM = ZERO
9396          FACDI1 = ZERO
9397          FACDI2 = 2.0D0
9398          FACDI  = ZERO
9399       ENDIF
9400
9401 * initializations
9402       DO 10 I=1,NSITEB
9403          BSITE( 0,IQ,NTARG,I) = ZERO
9404          BSITE(IE,IQ,NTARG,I) = ZERO
9405          BPROD(I) = ZERO
9406    10 CONTINUE
9407       STOT  = ZERO
9408       STOT2 = ZERO
9409       SELA  = ZERO
9410       SELA2 = ZERO
9411       SQEP  = ZERO
9412       SQEP2 = ZERO
9413       SQET  = ZERO
9414       SQET2 = ZERO
9415       SQE2  = ZERO
9416       SQE22 = ZERO
9417       SPRO  = ZERO
9418       SPRO2 = ZERO
9419       SDEL  = ZERO
9420       SDEL2 = ZERO
9421       SDQE  = ZERO
9422       SDQE2 = ZERO
9423       FACN   = ONE/DBLE(NSTATB)
9424
9425       IPNT = 0
9426       RPNT = ZERO
9427
9428 *  initialize Gauss-integration for photon-proj.
9429       JPOINT = 1
9430       IF (IJPROJ.EQ.7) THEN
9431          IF (INTRGE(1).EQ.1) THEN
9432             AMLO2 = (3.0D0*AAM(13))**2
9433          ELSEIF (INTRGE(1).EQ.2) THEN
9434             AMLO2 = AAM(33)**2
9435          ELSE
9436             AMLO2 = AAM(96)**2
9437          ENDIF
9438          IF (INTRGE(2).EQ.1) THEN
9439             AMHI2 = S/TWO
9440          ELSEIF (INTRGE(2).EQ.2) THEN
9441             AMHI2 = S/4.0D0
9442          ELSE
9443             AMHI2 = S
9444          ENDIF
9445          AMHI20 = (ECMNN(IE)-AMP)**2
9446          IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
9447          XAMLO = LOG( AMLO2+Q2 )
9448          XAMHI = LOG( AMHI2+Q2 )
9449 **PHOJET105a
9450 C        CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9451 **PHOJET112
9452          CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9453 **
9454          JPOINT = NPOINT
9455 * ratio direct/total photon-nucleon xsection
9456          CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1)
9457       ENDIF
9458
9459 * read pre-initialized profile-function from file
9460       IF (IOGLB.EQ.1) THEN
9461          READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM
9462          IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN
9463             WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB,
9464      &                             NA,NB,NSTATB,NSITEB
9465  1000       FORMAT(' XSGLAU: inconsistent input data in file ',A12,/,
9466      &             ' (IA,IB,ISTATB,ISITEB) ',4I10,/,
9467      &             ' (NA,NB,NSTATB,NSITEB) ',4I10)
9468             STOP
9469          ENDIF
9470          IF (LFIRST) WRITE(LOUT,1001) CFILE
9471  1001    FORMAT(/,' XSGLAU: impact parameter distribution read from ',
9472      &          'file ',A12,/)
9473          READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),
9474      &                         XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG),
9475      &                         XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9476          READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),
9477      &                         XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG),
9478      &                         XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9479          NLINES = INT(DBLE(NSITEB)/7.0D0)
9480          IF (NLINES.GT.0) THEN
9481             DO 21 I=1,NLINES
9482                ISTART = 7*I-6
9483                READ(LDAT,'(7E11.4)')
9484      &            (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9485    21       CONTINUE
9486          ENDIF
9487          ISTART = 7*NLINES+1
9488          IF (ISTART.LE.NSITEB) THEN
9489             READ(LDAT,'(7E11.4)')
9490      &         (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9491          ENDIF
9492          LFIRST = .FALSE.
9493          GOTO 100
9494 * variable projectile/target/energy runs:
9495 * read pre-initialized profile-functions from file
9496       ELSEIF (IOGLB.EQ.100) THEN
9497          CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0)
9498          GOTO 100
9499       ENDIF
9500
9501 * cross sections averaged over NSTATB nucleon configurations
9502       DO 11 IS=1,NSTATB
9503 C        IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS
9504          STOTN = ZERO
9505          SELAN = ZERO
9506          SQEPN = ZERO
9507          SQETN = ZERO
9508          SQE2N = ZERO
9509          SPRON = ZERO
9510          SDELN = ZERO
9511          SDQEN = ZERO
9512
9513          IF (NIDX.LE.-1) THEN
9514             CALL DT_CONUCL(COOP1,NA,RASH(1),0)
9515             CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1)
9516             IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9517                CALL DT_CONUCL(COOP2,NA,RASH(1),0)
9518                CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1)
9519             ENDIF
9520          ELSE
9521             CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0)
9522             CALL DT_CONUCL(COOT1,NB,RBSH(1),1)
9523             IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9524                CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0)
9525                CALL DT_CONUCL(COOT2,NB,RBSH(1),1)
9526             ENDIF
9527          ENDIF
9528
9529 *  integration over impact parameter B
9530          DO 12 IB=1,NSITEB-1
9531             STOTB = ZERO
9532             SELAB = ZERO
9533             SQEPB = ZERO
9534             SQETB = ZERO
9535             SQE2B = ZERO
9536             SPROB = ZERO
9537             SDIR  = ZERO
9538             SDELB = ZERO
9539             SDQEB = ZERO
9540             B     = DBLE(IB)*BSTEP(NTARG)
9541             FACB  = 10.0D0*TWOPI*B*BSTEP(NTARG)
9542
9543 *   integration over M_V^2 for photon-proj.
9544             DO 14 IM=1,JPOINT
9545                PP11(1) = CONE
9546                PP12(1) = CONE
9547                PP21(1) = CONE
9548                PP22(1) = CONE
9549                IF (IJPROJ.EQ.7) THEN
9550                   DO 13 K=2,NB
9551                      PP11(K) = CONE
9552                      PP12(K) = CONE
9553                      PP21(K) = CONE
9554                      PP22(K) = CONE
9555    13             CONTINUE
9556                ENDIF
9557                SHI  = ZERO
9558                FACM = ONE
9559                DCOH = 1.0D10
9560
9561                IF (IJPROJ.EQ.7) THEN
9562                   AMV2 = EXP(ABSZX(IM))-Q2
9563                   AMV  = SQRT(AMV2)
9564                   IF (AMV2.LT.16.0D0) THEN
9565                      R = TWO
9566                   ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN
9567                      R = 10.0D0/3.0D0
9568                   ELSE
9569                      R = 11.0D0/3.0D0
9570                   ENDIF
9571 *    define M_V dependent properties of nucleon scattering amplitude
9572 *     V_M-nucleon xsection
9573                   SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0
9574                   SIGMV  = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2)
9575 *     slope-parametrisation a la Kaidalov
9576                   BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
9577      &                           +0.25D0*LOG(S/(AMV2+Q2)))
9578 *    coherence length
9579                   IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM
9580 *    integration weight factor
9581                   FACM = ALPHEM/(3.0D0*PI*(ONE-X))*
9582      &                  R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM)
9583                ENDIF
9584                GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
9585                GAM = GSH
9586                IF (IJPROJ.EQ.7) THEN
9587                   RCA = GAM*SIGMV/TWOPI
9588                ELSE
9589                   RCA = GAM*SIGSH/TWOPI
9590                ENDIF
9591                FCA = -ROSH*RCA
9592                CA  = DCMPLX(RCA,FCA)
9593                CI  = CONE
9594
9595                DO 15 INA=1,NA
9596                   KK1  = 1
9597                   INT1 = 1
9598                   KK2  = 1
9599                   INT2 = 1
9600                   DO 16 INB=1,NB
9601 *    photon-projectile: check for supression by coherence length
9602                      IF (IJPROJ.EQ.7) THEN
9603                         IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN
9604                            KK1  = INB
9605                            INT1 = INT1+1
9606                         ENDIF
9607                         IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN
9608                            KK2  = INB
9609                            INT2 = INT2+1
9610                         ENDIF
9611                      ENDIF
9612
9613                      X11 = B+COOT1(1,INB)-COOP1(1,INA)
9614                      Y11 =   COOT1(2,INB)-COOP1(2,INA)
9615                      XY11 = GAM*(X11*X11+Y11*Y11)
9616                      IF (XY11.LE.15.0D0) THEN
9617                         C = CONE-CA*EXP(-XY11)
9618                         AR = DBLE(PP11(INT1))
9619                         AI = DIMAG(PP11(INT1))
9620                         IF (ABS(AR).LT.TINY25) AR = ZERO
9621                         IF (ABS(AI).LT.TINY25) AI = ZERO
9622                         PP11(INT1) = DCMPLX(AR,AI)
9623                         PP11(INT1) = PP11(INT1)*C
9624                         AR  = DBLE(C)
9625                         AI  = DIMAG(C)
9626                         SHI = SHI+LOG(AR*AR+AI*AI)
9627                      ENDIF
9628                      IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9629                         X12 = B+COOT2(1,INB)-COOP1(1,INA)
9630                         Y12 =   COOT2(2,INB)-COOP1(2,INA)
9631                         XY12 = GAM*(X12*X12+Y12*Y12)
9632                         IF (XY12.LE.15.0D0) THEN
9633                            C = CONE-CA*EXP(-XY12)
9634                            AR = DBLE(PP12(INT2))
9635                            AI = DIMAG(PP12(INT2))
9636                            IF (ABS(AR).LT.TINY25) AR = ZERO
9637                            IF (ABS(AI).LT.TINY25) AI = ZERO
9638                            PP12(INT2) = DCMPLX(AR,AI)
9639                            PP12(INT2) = PP12(INT2)*C
9640                         ENDIF
9641                         X21 = B+COOT1(1,INB)-COOP2(1,INA)
9642                         Y21 =   COOT1(2,INB)-COOP2(2,INA)
9643                         XY21 = GAM*(X21*X21+Y21*Y21)
9644                         IF (XY21.LE.15.0D0) THEN
9645                            C = CONE-CA*EXP(-XY21)
9646                            AR = DBLE(PP21(INT1))
9647                            AI = DIMAG(PP21(INT1))
9648                            IF (ABS(AR).LT.TINY25) AR = ZERO
9649                            IF (ABS(AI).LT.TINY25) AI = ZERO
9650                            PP21(INT1) = DCMPLX(AR,AI)
9651                            PP21(INT1) = PP21(INT1)*C
9652                         ENDIF
9653                         X22 = B+COOT2(1,INB)-COOP2(1,INA)
9654                         Y22 =   COOT2(2,INB)-COOP2(2,INA)
9655                         XY22 = GAM*(X22*X22+Y22*Y22)
9656                         IF (XY22.LE.15.0D0) THEN
9657                            C = CONE-CA*EXP(-XY22)
9658                            AR = DBLE(PP22(INT2))
9659                            AI = DIMAG(PP22(INT2))
9660                            IF (ABS(AR).LT.TINY25) AR = ZERO
9661                            IF (ABS(AI).LT.TINY25) AI = ZERO
9662                            PP22(INT2) = DCMPLX(AR,AI)
9663                            PP22(INT2) = PP22(INT2)*C
9664                         ENDIF
9665                      ENDIF
9666    16             CONTINUE
9667    15          CONTINUE
9668
9669                OMPP11 = CZERO
9670                OMPP21 = CZERO
9671                DIPP11 = CZERO
9672                DIPP21 = CZERO
9673                DO 17 K=1,INT1
9674                   IF (PP11(K).EQ.CZERO) THEN
9675                      PPTMP1 = CZERO
9676                      PPTMP2 = CZERO
9677                   ELSE
9678                      PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM)
9679                      PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM)
9680                   ENDIF
9681                   AVDIPP = 0.5D0*
9682      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9683                   OMPP11 = OMPP11+AVDIPP
9684 C                 OMPP11 = OMPP11+(CONE-PP11(K))
9685                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9686                   DIPP11 = DIPP11+AVDIPP
9687                   IF (PP21(K).EQ.CZERO) THEN
9688                      PPTMP1 = CZERO
9689                      PPTMP2 = CZERO
9690                   ELSE
9691                      PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM)
9692                      PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM)
9693                   ENDIF
9694                   AVDIPP = 0.5D0*
9695      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9696                   OMPP21 = OMPP21+AVDIPP
9697 C                 OMPP21 = OMPP21+(CONE-PP21(K))
9698                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9699                   DIPP21 = DIPP21+AVDIPP
9700    17          CONTINUE
9701                OMPP12 = CZERO
9702                OMPP22 = CZERO
9703                DIPP12 = CZERO
9704                DIPP22 = CZERO
9705                DO 18 K=1,INT2
9706                   IF (PP12(K).EQ.CZERO) THEN
9707                      PPTMP1 = CZERO
9708                      PPTMP2 = CZERO
9709                   ELSE
9710                      PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM)
9711                      PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM)
9712                   ENDIF
9713                   AVDIPP = 0.5D0*
9714      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9715                   OMPP12 = OMPP12+AVDIPP
9716 C                 OMPP12 = OMPP12+(CONE-PP12(K))
9717                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9718                   DIPP12 = DIPP12+AVDIPP
9719                   IF (PP22(K).EQ.CZERO) THEN
9720                      PPTMP1 = CZERO
9721                      PPTMP2 = CZERO
9722                   ELSE
9723                      PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM)
9724                      PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM)
9725                   ENDIF
9726                   AVDIPP = 0.5D0*
9727      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
9728                   OMPP22 = OMPP22+AVDIPP
9729 C                 OMPP22 = OMPP22+(CONE-PP22(K))
9730                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
9731                   DIPP22 = DIPP22+AVDIPP
9732    18          CONTINUE
9733
9734                SPROM = ONE-EXP(SHI)
9735                SPROB = SPROB+FACM*SPROM
9736                IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
9737                   STOTM = DBLE(OMPP11+OMPP22)
9738                   SELAM = DBLE(OMPP11*DCONJG(OMPP22))
9739                   SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM
9740                   SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM
9741                   SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM
9742                   SDELM = DBLE(DIPP11*DCONJG(DIPP22))
9743                   SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM
9744                   STOTB = STOTB+FACM*STOTM
9745                   SELAB = SELAB+FACM*SELAM
9746                   SDELB = SDELB+FACM*SDELM
9747                   IF (NB.GT.1) THEN
9748                      SQEPB = SQEPB+FACM*SQEPM
9749                      SDQEB = SDQEB+FACM*SDQEM
9750                   ENDIF
9751                   IF (NA.GT.1) SQETB = SQETB+FACM*SQETM
9752                   IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M
9753                   IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD
9754                ENDIF
9755
9756    14       CONTINUE
9757
9758             STOTN = STOTN+FACB*STOTB
9759             SELAN = SELAN+FACB*SELAB
9760             SQEPN = SQEPN+FACB*SQEPB
9761             SQETN = SQETN+FACB*SQETB
9762             SQE2N = SQE2N+FACB*SQE2B
9763             SPRON = SPRON+FACB*SPROB
9764             SDELN = SDELN+FACB*SDELB
9765             SDQEN = SDQEN+FACB*SDQEB
9766
9767             IF (IJPROJ.EQ.7) THEN
9768                BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB)
9769             ELSE
9770                IF (DIBETA.GT.ZERO) THEN
9771                   BPROD(IB+1)= BPROD(IB+1)
9772      &                        +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B)
9773                ELSE
9774                   BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB
9775                ENDIF
9776             ENDIF
9777
9778    12    CONTINUE
9779
9780          STOT  = STOT +FACN*STOTN
9781          STOT2 = STOT2+FACN*STOTN**2
9782          SELA  = SELA +FACN*SELAN
9783          SELA2 = SELA2+FACN*SELAN**2
9784          SQEP  = SQEP +FACN*SQEPN
9785          SQEP2 = SQEP2+FACN*SQEPN**2
9786          SQET  = SQET +FACN*SQETN
9787          SQET2 = SQET2+FACN*SQETN**2
9788          SQE2  = SQE2 +FACN*SQE2N
9789          SQE22 = SQE22+FACN*SQE2N**2
9790          SPRO  = SPRO +FACN*SPRON
9791          SPRO2 = SPRO2+FACN*SPRON**2
9792          SDEL  = SDEL +FACN*SDELN
9793          SDEL2 = SDEL2+FACN*SDELN**2
9794          SDQE  = SDQE +FACN*SDQEN
9795          SDQE2 = SDQE2+FACN*SDQEN**2
9796
9797    11 CONTINUE
9798
9799 * final cross sections
9800 * 1) total
9801       XSTOT(IE,IQ,NTARG) = STOT
9802       IF (IJPROJ.EQ.7)
9803      &   XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR
9804 * 2) elastic
9805       XSELA(IE,IQ,NTARG) = SELA
9806 * 3) quasi-el.: A+B-->A+X (excluding 2)
9807       XSQEP(IE,IQ,NTARG) = SQEP
9808 * 4) quasi-el.: A+B-->X+B (excluding 2)
9809       XSQET(IE,IQ,NTARG) = SQET
9810 * 5) quasi-el.: A+B-->X (excluding 2-4)
9811       XSQE2(IE,IQ,NTARG) = SQE2
9812 * 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
9813       IF (SDEL.GT.ZERO) THEN
9814          XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2
9815       ELSE
9816          XSPRO(IE,IQ,NTARG) = SPRO
9817       ENDIF
9818 * 7) projectile diffraction (el. scatt. off target)
9819       XSDEL(IE,IQ,NTARG) = SDEL
9820 * 8) projectile diffraction (quasi-el. scatt. off target)
9821       XSDQE(IE,IQ,NTARG) = SDQE
9822 *  stat. errors
9823       XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1))
9824       XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1))
9825       XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1))
9826       XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1))
9827       XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1))
9828       XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1))
9829       XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1))
9830       XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1))
9831
9832       IF (IJPROJ.EQ.7) THEN
9833          BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG)
9834      &          -XSQEP(IE,IQ,NTARG)
9835       ELSE
9836          BNORM = XSPRO(IE,IQ,NTARG)
9837       ENDIF
9838       DO 19 I=2,NSITEB
9839          BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1)
9840          IF ((IE.EQ.1).AND.(IQ.EQ.1))
9841      &      BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1)
9842    19 CONTINUE
9843
9844 * write profile function data into file
9845       IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN
9846          WRITE(LDAT,'(5I10,1P,E15.5)')
9847      &      IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE)
9848          WRITE(LDAT,'(1P,6E12.5)')
9849      &      XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG),
9850      &      XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
9851          WRITE(LDAT,'(1P,6E12.5)')
9852      &      XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG),
9853      &      XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
9854          NLINES = INT(DBLE(NSITEB)/7.0D0)
9855          IF (NLINES.GT.0) THEN
9856             DO 20 I=1,NLINES
9857                ISTART = 7*I-6
9858                WRITE(LDAT,'(1P,7E11.4)')
9859      &            (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
9860    20       CONTINUE
9861          ENDIF
9862          ISTART = 7*NLINES+1
9863          IF (ISTART.LE.NSITEB) THEN
9864             WRITE(LDAT,'(1P,7E11.4)')
9865      &         (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
9866          ENDIF
9867       ENDIF
9868
9869   100 CONTINUE
9870
9871 C     IF (ABS(IOGLB).EQ.1) CLOSE(LDAT)
9872
9873       RETURN
9874       END
9875
9876 *$ CREATE DT_GETBXS.FOR
9877 *COPY DT_GETBXS
9878 *
9879 *===getbxs=============================================================*
9880 *
9881       SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX)
9882
9883 ************************************************************************
9884 * Biasing in impact parameter space.                                   *
9885 *     XSFRAC = 0 :  BLO    - minimum impact parameter  (input)         *
9886 *                   BHI    - maximum impact parameter  (input)         *
9887 *                   XSFRAC - fraction of cross section corresponding   *
9888 *                            to impact parameter range (BLO,BHI)       *
9889 *                                                      (output)        *
9890 *     XSFRAC > 0 :  XSFRAC - fraction of cross section (input)         *
9891 *                   BHI    - maximum impact parameter giving requested *
9892 *                            fraction of cross section in impact       *
9893 *                            parameter range (0,BMAX)  (output)        *
9894 * This version dated 17.03.00  is written by S. Roesler                *
9895 ************************************************************************
9896
9897       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9898       SAVE
9899       PARAMETER ( LINP = 10 ,
9900      &            LOUT = 6 ,
9901      &            LDAT = 9 )
9902
9903       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9904 * Glauber formalism: parameters
9905       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9906      &                BMAX(NCOMPX),BSTEP(NCOMPX),
9907      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9908      &                NSITEB,NSTATB
9909
9910       NTARG = ABS(NIDX)
9911       IF (XSFRAC.LE.0.0D0) THEN
9912          ILO    = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG)))
9913          IHI    = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG)))
9914          IF (ILO.GE.IHI) THEN
9915             XSFRAC = 0.0D0
9916             RETURN
9917          ENDIF
9918          IF (ILO.EQ.NSITEB-1) THEN
9919             FRCLO = BSITE(0,1,NTARG,NSITEB)
9920          ELSE
9921             FRCLO = BSITE(0,1,NTARG,ILO+1)
9922      &              +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG)
9923      &              *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1))
9924          ENDIF
9925          IF (IHI.EQ.NSITEB-1) THEN
9926             FRCHI = BSITE(0,1,NTARG,NSITEB)
9927          ELSE
9928             FRCHI = BSITE(0,1,NTARG,IHI+1)
9929      &              +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG)
9930      &              *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1))
9931          ENDIF
9932          XSFRAC = FRCHI-FRCLO
9933       ELSE
9934          BLO = 0.0D0
9935          BHI = BMAX(NTARG)
9936          DO 1 I=1,NSITEB-1
9937             IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN
9938                FAC = (XSFRAC              -BSITE(0,1,NTARG,I))/
9939      &               (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I))
9940                BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC
9941                GOTO 2
9942             ENDIF
9943     1    CONTINUE
9944     2    CONTINUE
9945       ENDIF
9946
9947       RETURN
9948       END
9949
9950 *$ CREATE DT_CONUCL.FOR
9951 *COPY DT_CONUCL
9952 *
9953 *===conucl=============================================================*
9954 *
9955       SUBROUTINE DT_CONUCL(X,N,R,MODE)
9956
9957 ************************************************************************
9958 * Calculation of coordinates of nucleons within nuclei.                *
9959 *        X(3,N)   spatial coordinates of nucleons (in fm)  (output)    *
9960 *        N / R    number of nucleons / radius of nucleus   (input)     *
9961 *        MODE = 0 coordinates not sorted                               *
9962 *             = 1 coordinates sorted with increasing X(3,i)            *
9963 *             = 2 coordinates sorted with decreasing X(3,i)            *
9964 * This version dated 26.10.95 is revised by S. Roesler                 *
9965 ************************************************************************
9966
9967       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9968       SAVE
9969       PARAMETER ( LINP = 10 ,
9970      &            LOUT = 6 ,
9971      &            LDAT = 9 )
9972
9973       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9974      &           ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
9975
9976       PARAMETER (TWOPI = 6.283185307179586454D+00 )
9977
9978       PARAMETER (NSRT=10)
9979       DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
9980       DIMENSION X(3,N),XTMP(3,260)
9981
9982       CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R)
9983
9984       IF ((MODE.NE.0).AND.(N.GT.4)) THEN
9985          K = 0
9986          DO 1 I=1,NSRT
9987             IF (MODE.EQ.2) THEN
9988                ISRT = NSRT+1-I
9989             ELSE
9990                ISRT = I
9991             ENDIF
9992             K1 = K
9993             DO 2 J=1,ICSRT(ISRT)
9994                K = K+1
9995                X(1,K) = XTMP(1,IDXSRT(ISRT,J))
9996                X(2,K) = XTMP(2,IDXSRT(ISRT,J))
9997                X(3,K) = XTMP(3,IDXSRT(ISRT,J))
9998     2       CONTINUE
9999             IF (ICSRT(ISRT).GT.1) THEN
10000                I0 = K1+1
10001                I1 = K
10002                CALL DT_SORT(X,N,I0,I1,MODE)
10003             ENDIF
10004     1    CONTINUE
10005       ELSEIF ((MODE.NE.0).AND.(N.GE.2).AND.(N.LE.4)) THEN
10006          DO 3 I=1,N
10007             X(1,I) = XTMP(1,I)
10008             X(2,I) = XTMP(2,I)
10009             X(3,I) = XTMP(3,I)
10010     3    CONTINUE
10011          CALL DT_SORT(X,N,1,N,MODE)
10012       ELSE
10013          DO 4 I=1,N
10014             X(1,I) = XTMP(1,I)
10015             X(2,I) = XTMP(2,I)
10016             X(3,I) = XTMP(3,I)
10017     4    CONTINUE
10018       ENDIF
10019
10020       RETURN
10021       END
10022
10023 *$ CREATE DT_COORDI.FOR
10024 *COPY DT_COORDI
10025 *
10026 *===coordi=============================================================*
10027 *
10028       SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R)
10029
10030 ************************************************************************
10031 * Calculation of coordinates of nucleons within nuclei.                *
10032 *        X(3,N)   spatial coordinates of nucleons (in fm)  (output)    *
10033 *        N / R    number of nucleons / radius of nucleus   (input)     *
10034 * Based on the original version by Shmakov et al.                      *
10035 * This version dated 26.10.95 is revised by S. Roesler                 *
10036 ************************************************************************
10037
10038       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10039       SAVE
10040       PARAMETER ( LINP = 10 ,
10041      &            LOUT = 6 ,
10042      &            LDAT = 9 )
10043
10044       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10045      &           ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10046
10047       PARAMETER (TWOPI = 6.283185307179586454D+00 )
10048
10049       LOGICAL LSTART
10050
10051       PARAMETER (NSRT=10)
10052       DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10053       DIMENSION X(3,260),WD(4),RD(3)
10054
10055       DATA PDIF/0.545D0/,R2MIN/0.16D0/
10056       DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/
10057       DATA RD /2.09D0, 0.935D0, 0.697D0/
10058
10059       X1SUM = ZERO
10060       X2SUM = ZERO
10061       X3SUM = ZERO
10062
10063       IF (N.EQ.1) THEN
10064          X(1,1) = ZERO
10065          X(2,1) = ZERO
10066          X(3,1) = ZERO
10067       ELSEIF (N.EQ.2) THEN
10068          EPS = DT_RNDM(RD(1))
10069          DO 30 I=1,3
10070             IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40
10071    30    CONTINUE
10072    40    CONTINUE
10073          DO 50 J=1,3
10074             CALL DT_RANNOR(X1,X2)
10075             X(J,1) = RD(I)*X1
10076             X(J,2) = -X(J,1)
10077    50    CONTINUE
10078       ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN
10079          SIGMA = R/SQRTWO
10080          LSTART = .TRUE.
10081          CALL DT_RANNOR(X3,X4)
10082          DO 100 I=1,N
10083             CALL DT_RANNOR(X1,X2)
10084             X(1,I) = SIGMA*X1
10085             X(2,I) = SIGMA*X2
10086             IF (LSTART) GOTO 80
10087             X(3,I) = SIGMA*X4
10088             CALL DT_RANNOR(X3,X4)
10089             GOTO 90
10090    80       CONTINUE
10091             X(3,I) = SIGMA*X3
10092    90       CONTINUE
10093             LSTART = .NOT.LSTART
10094             X1SUM = X1SUM+X(1,I)
10095             X2SUM = X2SUM+X(2,I)
10096             X3SUM = X3SUM+X(3,I)
10097   100    CONTINUE
10098          X1SUM = X1SUM/DBLE(N)
10099          X2SUM = X2SUM/DBLE(N)
10100          X3SUM = X3SUM/DBLE(N)
10101          DO 101 I=1,N
10102             X(1,I) = X(1,I)-X1SUM
10103             X(2,I) = X(2,I)-X2SUM
10104             X(3,I) = X(3,I)-X3SUM
10105   101    CONTINUE
10106       ELSE
10107
10108 * maximum nuclear radius for coordinate sampling
10109          RMAX = R+4.605D0*PDIF
10110
10111 * initialize pre-sorting
10112          DO 121 I=1,NSRT
10113             ICSRT(I) = 0
10114   121    CONTINUE
10115          DR = TWO*RMAX/DBLE(NSRT)
10116
10117 * sample coordinates for N nucleons
10118          DO 140 I=1,N
10119   120       CONTINUE
10120             RAD = RMAX*(DT_RNDM(DR))**ONETHI
10121             F   = DT_DENSIT(N,RAD,R)
10122             IF (DT_RNDM(RAD).GT.F) GOTO 120
10123 *   theta, phi uniformly distributed
10124             CT  = ONE-TWO*DT_RNDM(F)
10125             ST  = SQRT((ONE-CT)*(ONE+CT))
10126             CALL DT_DSFECF(SFE,CFE)
10127             X(1,I) = RAD*ST*CFE
10128             X(2,I) = RAD*ST*SFE
10129             X(3,I) = RAD*CT
10130 *   ensure that distance between two nucleons is greater than R2MIN
10131             IF (I.LT.2) GOTO 122
10132             I1 = I-1
10133             DO 130 I2=1,I1
10134                DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+
10135      &                 (X(3,I)-X(3,I2))**2
10136                IF (DIST2.LE.R2MIN) GOTO 120
10137   130       CONTINUE
10138   122       CONTINUE
10139 *   save index according to z-bin
10140             IDXZ        = INT( (X(3,I)+RMAX)/DR )+1
10141             ICSRT(IDXZ) = ICSRT(IDXZ)+1
10142             IDXSRT(IDXZ,ICSRT(IDXZ)) = I
10143             X1SUM = X1SUM+X(1,I)
10144             X2SUM = X2SUM+X(2,I)
10145             X3SUM = X3SUM+X(3,I)
10146   140    CONTINUE
10147          X1SUM = X1SUM/DBLE(N)
10148          X2SUM = X2SUM/DBLE(N)
10149          X3SUM = X3SUM/DBLE(N)
10150          DO 141 I=1,N
10151             X(1,I) = X(1,I)-X1SUM
10152             X(2,I) = X(2,I)-X2SUM
10153             X(3,I) = X(3,I)-X3SUM
10154   141    CONTINUE
10155
10156       ENDIF
10157
10158       RETURN
10159       END
10160
10161 *$ CREATE DT_DENSIT.FOR
10162 *COPY DT_DENSIT
10163 *
10164 *===densit=============================================================*
10165 *
10166       DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA)
10167
10168       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10169       SAVE
10170
10171       PARAMETER ( LINP = 10 ,
10172      &            LOUT = 6 ,
10173      &            LDAT = 9 )
10174       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10175       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
10176      &           PI    = TWOPI/TWO)
10177
10178       DIMENSION R0(18),FNORM(18)
10179       DATA R0 /  ZERO,   ZERO,   ZERO,   ZERO, 2.12D0,
10180      &         2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0,
10181      &         2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0,
10182      &         2.72D0, 2.66D0, 2.79D0/
10183       DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10184      &            .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10185      &            .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01,
10186      &            .1214D+01,.1265D+01,.1318D+01/
10187       DATA PDIF /0.545D0/
10188
10189       DT_DENSIT = ZERO
10190 * shell model
10191       IF (NA.LE.4) THEN
10192          STOP 'DT_DENSIT-0'
10193       ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN
10194          R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA))
10195          DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2)
10196      &            *EXP(-(R/R1)**2)/FNORM(NA)
10197 * Woods-Saxon
10198       ELSEIF (NA.GT.18) THEN
10199          DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF))
10200       ENDIF
10201
10202       RETURN
10203       END
10204
10205 *$ CREATE DT_RNCLUS.FOR
10206 *COPY DT_RNCLUS
10207 *
10208 *===rnclus=============================================================*
10209 *
10210       DOUBLE PRECISION FUNCTION DT_RNCLUS(N)
10211
10212 ************************************************************************
10213 * Nuclear radius for nucleus with mass number N.                       *
10214 * This version dated 26.9.00  is written by S. Roesler                 *
10215 ************************************************************************
10216
10217       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10218       SAVE
10219
10220       PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)
10221
10222 * nucleon radius
10223       PARAMETER (RNUCLE = 1.12D0)
10224
10225 * nuclear radii for selected nuclei
10226       DIMENSION RADNUC(18)
10227       DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0,
10228      &               2.58D0,2.71D0,2.66D0,2.71D0/
10229
10230       IF (N.LE.18) THEN
10231          IF (RADNUC(N).GT.0.0D0) THEN
10232             DT_RNCLUS = RADNUC(N)
10233          ELSE
10234             DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10235          ENDIF
10236       ELSE
10237          DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10238       ENDIF
10239
10240       RETURN
10241       END
10242
10243 *$ CREATE DT_DENTST.FOR
10244 *COPY DT_DENTST
10245 *
10246 *===dentst=============================================================*
10247 *
10248 C      PROGRAM DT_DENTST
10249       SUBROUTINE DT_DENTST
10250
10251       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10252       SAVE
10253
10254       OPEN(40,FILE='dentst.out',STATUS='UNKNOWN')
10255       OPEN(41,FILE='denmax.out',STATUS='UNKNOWN')
10256
10257       RMIN  = 0.0D0
10258       RMAX  = 8.0D0
10259       NBINS = 500.0D0
10260       DR    = (RMAX-RMIN)/DBLE(NBINS)
10261       DO 1 IA=5,18
10262          FMAX = 0.0D0
10263          DO 2 IR=1,NBINS+1
10264             R = RMIN+DBLE(IR-1)*DR
10265             F = DT_DENSIT(IA,R,R)
10266             IF (F.GT.FMAX) FMAX = F
10267             WRITE(40,'(1X,I3,2E15.5)') IA,R,F
10268     2    CONTINUE
10269          WRITE(41,'(1X,I3,E15.5)') IA,FMAX
10270     1 CONTINUE
10271
10272       CLOSE(40)
10273       CLOSE(41)
10274
10275       END
10276
10277 *$ CREATE DT_SHMAKI.FOR
10278 *COPY DT_SHMAKI
10279 *
10280 *===shmaki=============================================================*
10281 *
10282       SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE)
10283
10284 ************************************************************************
10285 * Initialisation of Glauber formalism. This subroutine has to be       *
10286 * called once (in case of target emulsions as often as many different  *
10287 * target nuclei are considered) before events are sampled.             *
10288 *         NA / NCA   mass number/charge of projectile nucleus          *
10289 *         NB / NCB   mass number/charge of target     nucleus          *
10290 *         IJP        identity of projectile (hadrons/leptons/photons)  *
10291 *         PPN        projectile momentum (for projectile nuclei:       *
10292 *                    momentum per nucleon) in target rest system       *
10293 *         MODE = 0   Glauber formalism invoked                         *
10294 *              = 1   fitted results are loaded from data-file          *
10295 *              = 99  NTARG is forced to be 1                           *
10296 *                    (used in connection with GLAUBERI-card only)      *
10297 * This version dated 22.03.96 is based on the original SHMAKI-routine  *
10298 * and revised by S. Roesler.                                           *
10299 ************************************************************************
10300
10301       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10302       SAVE
10303       PARAMETER ( LINP = 10 ,
10304      &            LOUT = 6 ,
10305      &            LDAT = 9 )
10306       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
10307      &           THREE=3.0D0)
10308
10309       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10310 * Glauber formalism: parameters
10311       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10312      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10313      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10314      &                NSITEB,NSTATB
10315 * Lorentz-parameters of the current interaction
10316       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10317      &                UMO,PPCM,EPROJ,PPROJ
10318 * properties of photon/lepton projectiles
10319       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10320 * kinematical cuts for lepton-nucleus interactions
10321       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
10322      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
10323 * Glauber formalism: cross sections
10324       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10325      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10326      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10327      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10328      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10329      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10330      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10331      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10332      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10333      &                BSLOPE,NEBINI,NQBINI
10334 * cuts for variable energy runs
10335       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
10336 * nucleon-nucleon event-generator
10337       CHARACTER*8 CMODEL
10338       LOGICAL LPHOIN
10339       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10340 * Glauber formalism: flags and parameters for statistics
10341       LOGICAL LPROD
10342       CHARACTER*8 CGLB
10343       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10344
10345       DATA NTARG,ICOUT,IVEOUT /0,0,0/
10346
10347 C     CALL DT_HISHAD
10348 C     STOP
10349
10350       NTARG = NTARG+1
10351       IF (MODE.EQ.99) NTARG = 1
10352       NIDX = -NTARG
10353       IF (MODE.EQ.-1) NIDX = NTARG
10354
10355       IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1
10356       IF (ICOUT.EQ.1) WRITE(LOUT,1000)
10357  1000    FORMAT(//,1X,'SHMAKI:    Glauber formalism (Shmakov et. al) -',
10358      &          ' initialization',/,12X,'--------------------------',
10359      &          '-------------------------',/)
10360
10361       IF (MODE.EQ.2) THEN
10362          CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10363          CALL DT_SHFAST(MODE,PPN,IBACK)
10364          STOP ' Glauber pre-initialization done'
10365       ENDIF
10366       IF (MODE.EQ.1) THEN
10367          CALL DT_PROFBI(NA,NB,PPN,NTARG)
10368       ELSE
10369          IBACK = 1
10370          IF (MODE.EQ.3)  CALL DT_SHFAST(MODE,PPN,IBACK)
10371          IF (IBACK.EQ.1) THEN
10372 * lepton-nucleus (variable energy runs)
10373             IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR.
10374      &          (IJP.EQ.10).OR.(IJP.EQ.11))   THEN
10375                IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10376      &            WRITE(LOUT,1002) NB,NCB
10377  1002          FORMAT(1X,'variable energy run:     projectile-id:  7',
10378      &                '    target A/Z: ',I3,' /',I3,/,/,8X,
10379      &                'E_cm (GeV)    Q^2 (GeV^2)',
10380      &                '    Sigma_tot (mb)     Sigma_in (mb)',/,7X,
10381      &                '--------------------------------',
10382      &                '------------------------------')
10383                AECMLO = LOG10(MIN(UMO,ECMLI))
10384                AECMHI = LOG10(MIN(UMO,ECMHI))
10385                IESTEP = NEB-1
10386                DAECM  = (AECMHI-AECMLO)/DBLE(IESTEP)
10387                IF (AECMLO.EQ.AECMHI) IESTEP = 0
10388                DO 1 I=1,IESTEP+1
10389                   ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10390                   IF (Q2HI.GT.0.1D0) THEN
10391                      IF (Q2LI.LT.0.01D0) THEN
10392                         CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10393                         IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10394      &                     WRITE(LOUT,1003)
10395      &                  ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10396                         Q2LI = 0.01D0
10397                         IBIN = 2
10398                      ELSE
10399                         IBIN = 1
10400                      ENDIF
10401                      IQSTEP = NQB-IBIN
10402                      AQ2LO  = LOG10(Q2LI)
10403                      AQ2HI  = LOG10(Q2HI)
10404                      DAQ2   = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE)
10405                      DO 2 J=IBIN,IQSTEP+IBIN
10406                         Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2)
10407                         CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX)
10408                         IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10409      &                     WRITE(LOUT,1003) ECMNN(I),
10410      &                     Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG)
10411     2                CONTINUE
10412                   ELSE
10413                      CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10414                      IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10415      &                  WRITE(LOUT,1003)
10416      &                  ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10417                   ENDIF
10418  1003             FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3)
10419     1          CONTINUE
10420                IVEOUT = 1
10421             ELSE
10422 * hadron/photon/nucleus-nucleus
10423                IF ((ABS(VAREHI).GT.ZERO).AND.
10424      &             (ABS(VAREHI).GT.ABS(VARELO))) THEN
10425                   IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN
10426                      WRITE(LOUT,1004) NA,NB,NCB
10427  1004                FORMAT(1X,'variable energy run:    projectile-id:',
10428      &                      I3,'    target A/Z: ',I3,' /',I3,/)
10429                      WRITE(LOUT,1005)
10430  1005                FORMAT('  E_cm (GeV)  E_Lab (GeV)  sig_tot^pp (mb)'
10431      &                      ,'  Sigma_tot (mb)  Sigma_prod (mb)',/,
10432      &                      ' -------------------------------------',
10433      &                      '--------------------------------------')
10434                   ENDIF
10435                   AECMLO = LOG10(VARCLO)
10436                   AECMHI = LOG10(VARCHI)
10437                   IESTEP = NEB-1
10438                   DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10439                   IF (AECMLO.EQ.AECMHI) IESTEP = 0
10440                   DO 3 I=1,IESTEP+1
10441                      ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10442                      AMP = 0.938D0
10443                      AMT = 0.938D0
10444                      AMP2 = AMP**2
10445                      AMT2 = AMT**2
10446                      ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT)
10447                      PLAB = SQRT((ELAB+AMP)*(ELAB-AMP))
10448                      CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX)
10449                      IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10450      &                 WRITE(LOUT,1006)
10451      &                 ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10452  1006             FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3)
10453     3             CONTINUE
10454                   IVEOUT = 1
10455                ELSE
10456                   CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10457                ENDIF
10458             ENDIF
10459          ENDIF
10460       ENDIF
10461
10462       IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND.
10463      &    (IOGLB.NE.100)) THEN
10464          WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH,
10465      &                    BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG)
10466  1001    FORMAT(38X,'projectile',
10467      &          '      target',/,1X,'Mass number / charge',
10468      &          17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X,
10469      &          'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X,
10470      &          'Parameters of elastic scattering amplitude:',/,5X,
10471      &          'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ',
10472      &          F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X,
10473      &          'statistics at each b-step',4X,I5,/,/,1X,
10474      &          'Prod. cross section  ',5X,F10.4,' mb',/)
10475       ENDIF
10476
10477       RETURN
10478       END
10479
10480 *$ CREATE DT_PROFBI.FOR
10481 *COPY DT_PROFBI
10482 *
10483 *===profbi=============================================================*
10484 *
10485       SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG)
10486
10487 ************************************************************************
10488 * Integral over profile function (to be used for impact-parameter      *
10489 * sampling during event generation).                                   *
10490 * Fitted results are used.                                             *
10491 *         NA / NB    mass numbers of proj./target nuclei               *
10492 *         PPN        projectile momentum (for projectile nuclei:       *
10493 *                    momentum per nucleon) in target rest system       *
10494 *         NTARG      index of target material (i.e. kind of nucleus)   *
10495 * This version dated 31.05.95 is revised by S. Roesler                 *
10496 ************************************************************************
10497
10498       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10499       SAVE
10500       PARAMETER ( LINP = 10 ,
10501      &            LOUT = 6 ,
10502      &            LDAT = 9 )
10503 CPH      SAVE
10504
10505       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
10506
10507       LOGICAL LSTART
10508       CHARACTER CNAME*80
10509
10510       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10511 * Glauber formalism: parameters
10512       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10513      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10514      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10515      &                NSITEB,NSTATB
10516 * Glauber formalism: cross sections
10517       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10518      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10519      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10520      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10521      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10522      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10523      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10524      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10525      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10526      &                BSLOPE,NEBINI,NQBINI
10527
10528       PARAMETER (NGLMAX=8000)
10529       DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX),
10530      &          GLASIG(NGLMAX),GLAFIT(5,NGLMAX)
10531
10532       DATA LSTART /.TRUE./
10533
10534       IF (LSTART) THEN
10535 * read fit-parameters from file
10536          OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN')
10537          I = 0
10538     1    CONTINUE
10539          READ(47,'(A80)') CNAME
10540          IF (CNAME.EQ.'STOP') GOTO 2
10541          I = I+1
10542          READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I),
10543      &                 GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I),
10544      &                 GLAFIT(4,I),GLAFIT(5,I)
10545          IF (I+1.GT.NGLMAX) THEN
10546             WRITE(LOUT,1000)
10547  1000       FORMAT(1X,'PROFBI:    warning! array size exceeded - ',
10548      &             'program stopped')
10549             STOP
10550          ENDIF
10551          GOTO 1
10552     2    CONTINUE
10553          NGLPAR = I
10554          LSTART = .FALSE.
10555       ENDIF
10556
10557       NNA = NA
10558       NNB = NB
10559       IF (NA.GT.NB) THEN
10560          NNA = NB
10561          NNB = NA
10562       ENDIF
10563       IDXGLA = 0
10564       DO 3 J=1,NGLPAR
10565          IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN
10566             IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1)
10567             DO 4 K=1,J-1
10568                IPOINT = J-K
10569                IF (J.EQ.NGLPAR) IPOINT = J+1-K
10570                IF ((NNA.GT.NGLIP(IPOINT)).OR.
10571      &             (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN
10572                   IF (IPOINT.EQ.1) IPOINT = 0
10573                   NATMP = NGLIP(IPOINT+1)
10574                   IF (PPN.LT.GLAPPN(IPOINT+1)) THEN
10575                      IDXGLA = IPOINT+1
10576                      GOTO 6
10577                   ELSE
10578                      J1BEG = IPOINT+1
10579                      J1END = J
10580 C                    IF (J.EQ.NGLPAR) THEN
10581 C                       J1BEG = IPOINT
10582 C                       J1END = J
10583 C                    ENDIF
10584                      DO 5 J1=J1BEG,J1END
10585                         IF (NGLIP(J1).EQ.NATMP) THEN
10586                            IF (PPN.LT.GLAPPN(J1)) THEN
10587                               IDXGLA = J1
10588                               GOTO 6
10589                            ENDIF
10590                         ELSE
10591                            IDXGLA = J1-1
10592                            GOTO 6
10593                         ENDIF
10594     5                CONTINUE
10595                      IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR)))
10596      &                  IDXGLA = NGLPAR
10597                   ENDIF
10598                ENDIF
10599     4       CONTINUE
10600          ENDIF
10601     3 CONTINUE
10602
10603     6 CONTINUE
10604       IF (IDXGLA.EQ.0) THEN
10605          WRITE(LOUT,1001) NNA,NNB,PPN
10606  1001    FORMAT(1X,'PROFBI:   configuration (NA,NB,PPN = ',
10607      &          2I4,F6.0,') not found ')
10608          STOP
10609       ENDIF
10610
10611 * no interpolation yet available
10612       XSPRO(1,1,NTARG) = GLASIG(IDXGLA)
10613
10614       BSITE(1,1,NTARG,1) = ZERO
10615       DO 10 I=2,NSITEB
10616          XX = DBLE(I)
10617          POLY  = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+
10618      &           GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+
10619      &           GLAFIT(5,IDXGLA)*XX**4
10620          IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY)
10621          BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY))
10622          IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO
10623    10 CONTINUE
10624
10625       RETURN
10626       END
10627
10628 *$ CREATE DT_GLAUBE.FOR
10629 *COPY DT_GLAUBE
10630 *
10631 *===glaube=============================================================*
10632 *
10633       SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX)
10634
10635 ************************************************************************
10636 * Calculation of configuartion of interacting nucleons for one event.  *
10637 *    NB / NB    mass numbers of proj./target nuclei           (input)  *
10638 *    B          impact parameter                              (output) *
10639 *    INTT       total number of wounded nucleons                 "     *
10640 *    INTA / INTB number of wounded nucleons in proj. / target    "     *
10641 *    JS / JT(i) number of collisions proj. / target nucleon i is       *
10642 *                                                   involved  (output) *
10643 *    NIDX       index of projectile/target material            (input) *
10644 *               = -2 call within FLUKA transport calculation           *
10645 * This is an update of the original routine SHMAKO by J.Ranft/HJM      *
10646 * This version dated 22.03.96 is revised by S. Roesler                 *
10647 *                                                                      *
10648 * Last change 27.12.2006 by S. Roesler.                                *
10649 ************************************************************************
10650
10651       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10652       SAVE
10653       PARAMETER ( LINP = 10 ,
10654      &            LOUT = 6 ,
10655      &            LDAT = 9 )
10656       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
10657      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
10658
10659       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10660       PARAMETER ( MAXNCL = 260,
10661      &            MAXVQU = MAXNCL,
10662      &            MAXSQU = 20*MAXVQU,
10663      &            MAXINT = MAXVQU+MAXSQU)
10664 * Glauber formalism: parameters
10665       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10666      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10667      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10668      &                NSITEB,NSTATB
10669 * Glauber formalism: cross sections
10670       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10671      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10672      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10673      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10674      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10675      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10676      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10677      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10678      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10679      &                BSLOPE,NEBINI,NQBINI
10680 * Lorentz-parameters of the current interaction
10681       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10682      &                UMO,PPCM,EPROJ,PPROJ
10683 * properties of photon/lepton projectiles
10684       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10685 * Glauber formalism: collision properties
10686       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
10687      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
10688 * Glauber formalism: flags and parameters for statistics
10689       LOGICAL LPROD
10690       CHARACTER*8 CGLB
10691       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10692
10693       DIMENSION JS(MAXNCL),JT(MAXNCL)
10694
10695       NTARG = ABS(NIDX)
10696
10697 * get actual energy from /DTLTRA/
10698       ECMNOW = UMO
10699       Q2     = VIRT
10700 *
10701 * new patch for pre-initialized variable projectile/target/energy runs,
10702 * bypassed for use within FLUKA (Nidx=-2)
10703       IF (IOGLB.EQ.100) THEN
10704          IF (NIDX.NE.-2) CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1)
10705 *
10706 * variable energy run, interpolate profile function
10707       ELSE
10708          I1   = 1
10709          I2   = 1
10710          RATE = ONE
10711          IF (NEBINI.GT.1) THEN
10712             IF (ECMNOW.GE.ECMNN(NEBINI)) THEN
10713                I1   = NEBINI
10714                I2   = NEBINI
10715                RATE = ONE
10716             ELSEIF (ECMNOW.GT.ECMNN(1)) THEN
10717                DO 1 I=2,NEBINI
10718                   IF (ECMNOW.LT.ECMNN(I)) THEN
10719                      I1   = I-1
10720                      I2   = I
10721                      RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
10722                      GOTO 2
10723                   ENDIF
10724     1          CONTINUE
10725     2          CONTINUE
10726             ENDIF
10727          ENDIF
10728          J1   = 1
10729          J2   = 1
10730          RATQ = ONE
10731          IF (NQBINI.GT.1) THEN
10732             IF (Q2.GE.Q2G(NQBINI)) THEN
10733                J1   = NQBINI
10734                J2   = NQBINI
10735                RATQ = ONE
10736             ELSEIF (Q2.GT.Q2G(1)) THEN
10737                DO 3 I=2,NQBINI
10738                   IF (Q2.LT.Q2G(I)) THEN
10739                      J1   = I-1
10740                      J2   = I
10741                      RATQ = LOG10(     Q2/MAX(Q2G(J1),TINY14))/
10742      &                      LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
10743 C                    RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1))
10744                      GOTO 4
10745                   ENDIF
10746     3          CONTINUE
10747     4          CONTINUE
10748             ENDIF
10749          ENDIF
10750
10751          DO 5 I=1,KSITEB
10752             BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+
10753      &         RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10754      &         RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+
10755      &         RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+
10756      &                    BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I))
10757     5    CONTINUE
10758       ENDIF
10759
10760       CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX)
10761       IF (NIDX.LE.-1) THEN
10762          RPROJ = RASH(1)
10763          RTARG = RBSH(NTARG)
10764       ELSE
10765          RPROJ = RASH(NTARG)
10766          RTARG = RBSH(1)
10767       ENDIF
10768
10769       RETURN
10770       END
10771
10772 *$ CREATE DT_DIAGR.FOR
10773 *COPY DT_DIAGR
10774 *
10775 *===diagr==============================================================*
10776 *
10777       SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC,
10778      &                                                         NIDX)
10779
10780 ************************************************************************
10781 * Based on the original version by Shmakov et al.                      *
10782 * This version dated 21.04.95 is revised by S. Roesler                 *
10783 ************************************************************************
10784
10785       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10786       SAVE
10787       PARAMETER ( LINP = 10 ,
10788      &            LOUT = 6 ,
10789      &            LDAT = 9 )
10790       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10791       PARAMETER (TWOPI  = 6.283185307179586454D+00,
10792      &           PI     = TWOPI/TWO,
10793      &           GEV2MB = 0.38938D0,
10794      &           GEV2FM = 0.1972D0,
10795      &           ALPHEM = ONE/137.0D0,
10796 * proton mass
10797      &           AMP    = 0.938D0,
10798      &           AMP2   = AMP**2,
10799 * rho0 mass
10800      &           AMRHO0 = 0.77D0)
10801
10802       COMPLEX*16 C,CA,CI
10803       PARAMETER ( MAXNCL = 260,
10804      &            MAXVQU = MAXNCL,
10805      &            MAXSQU = 20*MAXVQU,
10806      &            MAXINT = MAXVQU+MAXSQU)
10807 * particle properties (BAMJET index convention)
10808       CHARACTER*8  ANAME
10809       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
10810      &                IICH(210),IIBAR(210),K1(210),K2(210)
10811       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10812 * emulsion treatment
10813       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
10814      &                NCOMPO,IEMUL
10815 * Glauber formalism: parameters
10816       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10817      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10818      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10819      &                NSITEB,NSTATB
10820 * Glauber formalism: cross sections
10821       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10822      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10823      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10824      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10825      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10826      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10827      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10828      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10829      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10830      &                BSLOPE,NEBINI,NQBINI
10831 * VDM parameter for photon-nucleus interactions
10832       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
10833 * nucleon-nucleon event-generator
10834       CHARACTER*8 CMODEL
10835       LOGICAL LPHOIN
10836       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10837 **PHOJET105a
10838 C     COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10839 **PHOJET112
10840 C  obsolete cut-off information
10841       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
10842       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
10843 **
10844 * coordinates of nucleons
10845       COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
10846 * interface between Glauber formalism and DPM
10847       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
10848      &                INTER1(MAXINT),INTER2(MAXINT)
10849 * statistics: Glauber-formalism
10850       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
10851 * n-n cross section fluctuations
10852       PARAMETER (NBINS = 1000)
10853       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
10854
10855       DIMENSION JS(MAXNCL),JT(MAXNCL),
10856      &          JS0(MAXNCL),JT0(MAXNCL,MAXNCL),
10857      &          JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL)
10858       DIMENSION NWA(0:210),NWB(0:210)
10859
10860       LOGICAL LFIRST
10861       DATA LFIRST /.TRUE./
10862
10863       DATA NTARGO,ICNT /0,0/
10864
10865       NTARG = ABS(NIDX)
10866
10867       IF (LFIRST) THEN
10868          LFIRST = .FALSE.
10869          IF (NCOMPO.EQ.0) THEN
10870             NCALL  = 0
10871             NWAMAX = NA
10872             NWBMAX = NB
10873             DO 17 I=0,210
10874                NWA(I) = 0
10875                NWB(I) = 0
10876    17       CONTINUE
10877          ENDIF
10878       ENDIF
10879       IF (NTARG.EQ.-1) THEN
10880          IF (NCOMPO.EQ.0) THEN
10881             WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons'
10882             WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ',
10883      &                                NCALL,NWAMAX,NWBMAX
10884             DO 18 I=1,MAX(NWAMAX,NWBMAX)
10885                WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)')
10886      &                          I,NWA(I),DBLE(NWA(I))/DBLE(NCALL),
10887      &                            NWB(I),DBLE(NWB(I))/DBLE(NCALL)
10888    18       CONTINUE
10889          ENDIF
10890          RETURN
10891       ENDIF
10892
10893       DCOH   = 1.0D10
10894       IPNT   = 0
10895
10896       SQ2  = Q2
10897       IF (SQ2.LE.ZERO) SQ2 = 0.0001D0
10898       S   = ECMNOW**2
10899       X   = SQ2/(S+SQ2-AMP2)
10900       XNU = (S+SQ2-AMP2)/(TWO*AMP)
10901 * photon projectiles: recalculate photon-nucleon amplitude
10902       IF (IJPROJ.EQ.7) THEN
10903    15    CONTINUE
10904 *  VDM assumption: mass of V-meson
10905          AMV2   = DT_SAM2(SQ2,ECMNOW)
10906          AMV    = SQRT(AMV2)
10907          IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15
10908 *  check for pointlike interaction
10909          CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1)
10910 **sr 27.10.
10911 C        SIGSH  = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
10912          SIGSH  = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
10913 **
10914          ROSH   = 0.1D0
10915          BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2)
10916      &                   +0.25D0*LOG(S/(AMV2+SQ2)))
10917 *  coherence length
10918          IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM
10919       ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
10920          IF (MCGENE.EQ.2) THEN
10921             ZERO1 = ZERO
10922             CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3,
10923      &                                                BSLOPE,0)
10924          ELSE
10925             BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
10926          ENDIF
10927          IF (ECMNOW.LE.3.0D0) THEN
10928             ROSH = -0.43D0
10929          ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN
10930             ROSH = -0.63D0+0.175D0*LOG(ECMNOW)
10931          ELSEIF (ECMNOW.GT.50.0D0) THEN
10932             ROSH = 0.1D0
10933          ENDIF
10934          ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
10935          PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
10936          IF (MCGENE.EQ.2) THEN
10937             ZERO1 = ZERO
10938             CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3,
10939      &                                                  BDUM,0)
10940             SIGSH = SIGSH/10.0D0
10941          ELSE
10942 C           SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
10943             DUMZER = ZERO
10944             CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
10945             SIGSH = SIGSH/10.0D0
10946          ENDIF
10947       ELSE
10948          BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
10949          ROSH   = 0.01D0
10950          ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
10951          PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
10952 C        SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
10953          DUMZER = ZERO
10954          CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
10955          SIGSH = SIGSH/10.0D0
10956       ENDIF
10957       GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
10958       GAM = GSH
10959       RCA = GAM*SIGSH/TWOPI
10960       FCA = -ROSH*RCA
10961       CA  = DCMPLX(RCA,FCA)
10962       CI  = DCMPLX(ONE,ZERO)
10963
10964    16 CONTINUE
10965 * impact parameter
10966       IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX)
10967
10968       NTRY = 0
10969     3 CONTINUE
10970       NTRY = NTRY+1
10971 * initializations
10972       JNT  = 0
10973       DO 1 I=1,NA
10974          JS(I) = 0
10975     1 CONTINUE
10976       DO 2 I=1,NB
10977          JT(I) = 0
10978     2 CONTINUE
10979       IF (IJPROJ.EQ.7) THEN
10980          DO 8 I=1,MAXNCL
10981             JS0(I) = 0
10982             JNT0(I)= 0
10983             DO 9 J=1,NB
10984                JT0(I,J) = 0
10985     9       CONTINUE
10986     8    CONTINUE
10987       ENDIF
10988
10989 * nucleon configuration
10990 C     IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN
10991       IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN
10992 C        CALL DT_CONUCL(PKOO,NA,RASH,2)
10993 C        CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1)
10994          IF (NIDX.LE.-1) THEN
10995             CALL DT_CONUCL(PKOO,NA,RASH(1),0)
10996             CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0)
10997          ELSE
10998             CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0)
10999             CALL DT_CONUCL(TKOO,NB,RBSH(1),0)
11000          ENDIF
11001          NTARGO = NTARG
11002       ENDIF
11003       ICNT = ICNT+1
11004
11005 * LEPTO: pick out one struck nucleon
11006       IF (MCGENE.EQ.3) THEN
11007          JNT     = 1
11008          JS(1)   = 1
11009          IDX     = INT(DT_RNDM(X)*NB)+1
11010          JT(IDX) = 1
11011          B       = ZERO
11012          GOTO 19
11013       ENDIF
11014
11015       DO 4 INA=1,NA
11016 * cross section fluctuations
11017          AFLUC = ONE
11018          IF (IFLUCT.EQ.1) THEN
11019             IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0)
11020             AFLUC = FLUIXX(IFLUK)
11021          ENDIF
11022          KK1  = 1
11023          KINT = 1
11024          DO 5 INB=1,NB
11025 * photon-projectile: check for supression by coherence length
11026             IF (IJPROJ.EQ.7) THEN
11027                IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN
11028                   KK1  = INB
11029                   KINT = KINT+1
11030                ENDIF
11031             ENDIF
11032             QQ1 = B+TKOO(1,INB)-PKOO(1,INA)
11033             QQ2 =   TKOO(2,INB)-PKOO(2,INA)
11034             XY  = GAM*(QQ1*QQ1+QQ2*QQ2)
11035             IF (XY.LE.15.0D0) THEN
11036                C  = CI-CA*AFLUC*EXP(-XY)
11037                AR = DBLE(C)
11038                AI = DIMAG(C)
11039                P  = AR*AR+AI*AI
11040                IF (DT_RNDM(XY).GE.P) THEN
11041                   JNT = JNT+1
11042                   IF (IJPROJ.EQ.7) THEN
11043                      JNT0(KINT) = JNT0(KINT)+1
11044                      IF (JNT0(KINT).GT.MAXNCL) THEN
11045                         WRITE(LOUT,1001) MAXNCL
11046  1001                   FORMAT(1X,
11047      &                        'DIAGR:  no. of requested interactions',
11048      &                        ' exceeds array dimensions ',I4)
11049                         STOP
11050                      ENDIF
11051                      JS0(KINT)      = JS0(KINT)+1
11052                      JT0(KINT,INB)  = JT0(KINT,INB)+1
11053                      JI1(KINT,JNT0(KINT)) = INA
11054                      JI2(KINT,JNT0(KINT)) = INB
11055                   ELSE
11056                      IF (JNT.GT.MAXINT) THEN
11057                         WRITE(LOUT,1000) JNT, MAXINT
11058  1000                   FORMAT(1X,
11059      &                        'DIAGR:  no. of requested interactions ('
11060      &                        ,I4,') exceeds array dimensions (',I4,')')
11061                         STOP
11062                      ENDIF
11063                      JS(INA) = JS(INA)+1
11064                      JT(INB) = JT(INB)+1
11065                      INTER1(JNT) = INA
11066                      INTER2(JNT) = INB
11067                   ENDIF
11068                ENDIF
11069             ENDIF
11070     5    CONTINUE
11071     4 CONTINUE
11072
11073       IF (JNT.EQ.0) THEN
11074          IF (NTRY.LT.500) THEN
11075             GOTO 3
11076          ELSE
11077 C           WRITE(6,*) ' new impact parameter required (old= ',B,')'
11078             GOTO 16
11079          ENDIF
11080       ENDIF
11081
11082       IDIREC = 0
11083       IF (IJPROJ.EQ.7) THEN
11084          K = INT(ONE+DT_RNDM(X)*DBLE(KINT))
11085    10    CONTINUE
11086          IF (JNT0(K).EQ.0) THEN
11087             K = K+1
11088             IF (K.GT.KINT) K = 1
11089             GOTO 10
11090          ENDIF
11091 * supress Glauber-cascade by direct photon processes
11092          CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2)
11093          IF (IPNT.GT.0) THEN
11094             JNT   = 1
11095             JS(1) = 1
11096             DO 11 INB=1,NB
11097                JT(INB) = JT0(K,INB)
11098                IF (JT(INB).GT.0) GOTO 12
11099    11       CONTINUE
11100    12       CONTINUE
11101             INTER1(1) = 1
11102             INTER2(1) = INB
11103             IDIREC    = IPNT
11104          ELSE
11105             JNT   = JNT0(K)
11106             JS(1) = JS0(K)
11107             DO 13 INB=1,NB
11108                JT(INB) = JT0(K,INB)
11109    13       CONTINUE
11110             DO 14 I=1,JNT
11111                INTER1(I) = JI1(K,I)
11112                INTER2(I) = JI2(K,I)
11113    14       CONTINUE
11114          ENDIF
11115       ENDIF
11116
11117    19 CONTINUE
11118       INTA = 0
11119       INTB = 0
11120       DO 6 I=1,NA
11121         IF (JS(I).NE.0) INTA=INTA+1
11122     6 CONTINUE
11123       DO 7 I=1,NB
11124         IF (JT(I).NE.0) INTB=INTB+1
11125     7 CONTINUE
11126       ICWPG = INTA
11127       ICWTG = INTB
11128       ICIG  = JNT
11129       IPGLB = IPGLB+INTA
11130       ITGLB = ITGLB+INTB
11131       NGLB = NGLB+1
11132
11133       IF (NCOMPO.EQ.0) THEN
11134          NCALL = NCALL+1
11135          NWA(INTA) = NWA(INTA)+1
11136          NWB(INTB) = NWB(INTB)+1
11137       ENDIF
11138
11139       RETURN
11140       END
11141
11142 *$ CREATE DT_MODB.FOR
11143 *COPY DT_MODB
11144 *
11145 *===modb===============================================================*
11146 *
11147       SUBROUTINE DT_MODB(B,NIDX)
11148
11149 ************************************************************************
11150 * Sampling of impact parameter of collision.                           *
11151 *    B          impact parameter    (output)                           *
11152 *    NIDX       index of projectile/target material             (input)*
11153 * Based on the original version by Shmakov et al.                      *
11154 * This version dated 21.04.95 is revised by S. Roesler                 *
11155 *                                                                      *
11156 * Last change 27.12.2006 by S. Roesler.                                *
11157 ************************************************************************
11158
11159       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11160       SAVE
11161       PARAMETER ( LINP = 10 ,
11162      &            LOUT = 6 ,
11163      &            LDAT = 9 )
11164       PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0)
11165
11166       LOGICAL LEFT,LFIRST
11167
11168 * central particle production, impact parameter biasing
11169       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
11170       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11171 * Glauber formalism: parameters
11172       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11173      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11174      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11175      &                NSITEB,NSTATB
11176 * Glauber formalism: cross sections
11177       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11178      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11179      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11180      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11181      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11182      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11183      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11184      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11185      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11186      &                BSLOPE,NEBINI,NQBINI
11187
11188       DATA LFIRST /.TRUE./
11189
11190       NTARG = ABS(NIDX)
11191       IF (NIDX.LE.-1) THEN
11192          RA = RASH(1)
11193          RB = RBSH(NTARG)
11194       ELSE
11195          RA = RASH(NTARG)
11196          RB = RBSH(1)
11197       ENDIF
11198
11199       IF (ICENTR.EQ.2) THEN
11200          IF (RA.EQ.RB) THEN
11201             BB = DT_RNDM(B)*(0.3D0*RA)**2
11202             B  = SQRT(BB)
11203          ELSEIF(RA.LT.RB)THEN
11204             BB = DT_RNDM(B)*1.4D0*(RB-RA)**2
11205             B  = SQRT(BB)
11206          ELSEIF(RA.GT.RB)THEN
11207             BB = DT_RNDM(B)*1.4D0*(RA-RB)**2
11208             B  = SQRT(BB)
11209          ENDIF
11210       ELSE
11211     9    CONTINUE
11212          Y  = DT_RNDM(BB)
11213          I0 = 1
11214          I2 = NSITEB
11215    10    CONTINUE
11216          I1 = (I0+I2)/2
11217          LEFT = ((BSITE(0,1,NTARG,I0)-Y)
11218      &          *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO
11219          IF (LEFT) GOTO 20
11220          I0 = I1
11221          GOTO 30
11222    20    CONTINUE
11223          I2 = I1
11224    30    CONTINUE
11225          IF (I2-I0-2) 40,50,60
11226    40    CONTINUE
11227          I1 = I2+1
11228          IF (I1.GT.NSITEB) I1 = I0-1
11229          GOTO 70
11230    50    CONTINUE
11231          I1 = I0+1
11232          GOTO 70
11233    60    CONTINUE
11234          GOTO 10
11235    70    CONTINUE
11236          X0 = DBLE(I0-1)*BSTEP(NTARG)
11237          X1 = DBLE(I1-1)*BSTEP(NTARG)
11238          X2 = DBLE(I2-1)*BSTEP(NTARG)
11239          Y0 = BSITE(0,1,NTARG,I0)
11240          Y1 = BSITE(0,1,NTARG,I1)
11241          Y2 = BSITE(0,1,NTARG,I2)
11242    80    CONTINUE
11243          B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+
11244      &       X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+
11245      &       X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15)
11246 **sr 5.4.98: shift B by half the bin width to be in agreement with BPROD
11247          B = B+0.5D0*BSTEP(NTARG)
11248          IF (B.LT.ZERO) B = X1
11249          IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG)
11250          IF (ICENTR.LT.0) THEN
11251             IF (LFIRST) THEN
11252                LFIRST = .FALSE.
11253                IF (ICENTR.LE.-100) THEN
11254                   BIMIN  = 0.0D0
11255                ELSE
11256                   XSFRAC = 0.0D0
11257                ENDIF
11258                CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG)
11259                WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG),
11260      &                          BIMIN,BIMAX,XSFRAC*100.0D0,
11261      &                          XSFRAC*XSPRO(1,1,NTARG)
11262  10000         FORMAT(/,1X,'DT_MODB:      Biasing in impact parameter',
11263      &                /,15X,'---------------------------'/,/,4X,
11264      &                'average radii of proj / targ :',F10.3,' fm /',
11265      &                F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :',
11266      &                F10.3,' fm',/,/,21X,'b_lo / b_hi :',
11267      &                F10.3,' fm /',F7.3,' fm',/,5X,'percentage of',
11268      &                ' cross section :',F10.3,' %',/,5X,
11269      &                'corresponding cross section :',F10.3,' mb',/)
11270             ENDIF
11271             IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN
11272                B = BIMIN
11273             ELSE
11274                IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9
11275             ENDIF
11276          ENDIF
11277       ENDIF
11278
11279       RETURN
11280       END
11281
11282 *$ CREATE DT_SHFAST.FOR
11283 *COPY DT_SHFAST
11284 *
11285 *===shfast=============================================================*
11286 *
11287       SUBROUTINE DT_SHFAST(MODE,PPN,IBACK)
11288
11289       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11290       SAVE
11291       PARAMETER ( LINP = 10 ,
11292      &            LOUT = 6 ,
11293      &            LDAT = 9 )
11294       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1,
11295      &           ONE=1.0D0,TWO=2.0D0)
11296
11297       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11298 * Glauber formalism: parameters
11299       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11300      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11301      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11302      &                NSITEB,NSTATB
11303 * properties of interacting particles
11304       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11305 * Glauber formalism: cross sections
11306       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11307      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11308      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11309      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11310      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11311      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11312      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11313      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11314      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11315      &                BSLOPE,NEBINI,NQBINI
11316
11317       IBACK = 0
11318
11319       IF (MODE.EQ.2) THEN
11320          OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11321          WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN
11322  1000    FORMAT(1X,8I5,E15.5)
11323          WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11324  1001    FORMAT(1X,4E15.5)
11325          WRITE(47,1002) SIGSH,ROSH,GSH
11326  1002    FORMAT(1X,3E15.5)
11327          DO 10 I=1,100
11328             WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I)
11329    10    CONTINUE
11330          WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11331  1003    FORMAT(1X,2I10,3E15.5)
11332          CLOSE(47)
11333       ELSE
11334          OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11335          READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP
11336          IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND.
11337      &       (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ)
11338      &       .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND.
11339      &       (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN
11340             READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11341             READ(47,1002) SIGSH,ROSH,GSH
11342             DO 11 I=1,100
11343                READ(47,'(1X,E15.5)') BSITE(1,1,1,I)
11344    11       CONTINUE
11345             READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11346          ELSE
11347             IBACK = 1
11348          ENDIF
11349          CLOSE(47)
11350       ENDIF
11351
11352       RETURN
11353       END
11354
11355 *$ CREATE DT_POILIK.FOR
11356 *COPY DT_POILIK
11357 *
11358 *===poilik=============================================================*
11359 *
11360       SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE)
11361
11362       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
11363       SAVE
11364
11365       PARAMETER ( LINP = 10 ,
11366      &            LOUT = 6 ,
11367      &            LDAT = 9 )
11368       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0)
11369       PARAMETER (NE = 8)
11370
11371 **PHOJET105a
11372 C     CHARACTER*8 MDLNA
11373 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
11374 C     PARAMETER (IEETAB=10)
11375 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
11376 **PHOJET110
11377 C  model switches and parameters
11378       CHARACTER*8 MDLNA
11379       INTEGER ISWMDL,IPAMDL
11380       DOUBLE PRECISION PARMDL
11381       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11382 C  energy-interpolation table
11383       INTEGER IEETA2
11384       PARAMETER ( IEETA2 = 20 )
11385       INTEGER ISIMAX
11386       DOUBLE PRECISION SIGTAB,SIGECM
11387       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
11388 **
11389 * VDM parameter for photon-nucleus interactions
11390       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11391 **sr 22.7.97
11392       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11393 * Glauber formalism: cross sections
11394       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11395      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11396      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11397      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11398      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11399      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11400      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11401      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11402      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11403      &                BSLOPE,NEBINI,NQBINI
11404 **
11405
11406       DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/
11407
11408       IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3
11409
11410 * load cross sections from interpolation table
11411       IP = 1
11412       IF(ECM.LE.SIGECM(IP,1)) THEN
11413         I1 = 1
11414         I2 = 1
11415       ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
11416         DO 50 I=2,ISIMAX
11417           IF(ECM.LE.SIGECM(IP,I)) GOTO 200
11418   50    CONTINUE
11419  200    CONTINUE
11420         I1 = I-1
11421         I2 = I
11422       ELSE
11423         WRITE(LOUT,'(/1X,A,2E12.3)')
11424      &    'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
11425         I1 = ISIMAX
11426         I2 = ISIMAX
11427       ENDIF
11428       FAC2 = ZERO
11429       IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
11430      &                     /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
11431       FAC1 = ONE-FAC2
11432
11433       SIGANO = DT_SANO(ECM)
11434
11435 * cross section dependence on photon virtuality
11436       FSUP1 = ZERO
11437       DO  150 I=1,3
11438          FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I)))
11439      &                             /(ONE+VIRT/PARMDL(30+I))**2
11440  150  CONTINUE
11441       FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34))
11442       FAC1  = FAC1*FSUP1
11443       FAC2  = FAC2*FSUP1
11444       FSUP2 = ONE
11445
11446       ECMOLD = ECM
11447       Q2OLD  = VIRT
11448
11449     3 CONTINUE
11450
11451 C     SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
11452       CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2)
11453       IF (ISHAD(1).EQ.1) THEN
11454          SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
11455       ELSE
11456          SIGDIR = ZERO
11457       ENDIF
11458       SIGANO = FSUP1*FSUP2*SIGANO
11459       SIGTOT = SIGTOT-SIGDIR-SIGANO
11460       SIGDIR = SIGDIR/(FSUP1*FSUP2)
11461       SIGANO = SIGANO/(FSUP1*FSUP2)
11462       SIGTOT = SIGTOT+SIGDIR+SIGANO
11463
11464       RR = DT_RNDM(SIGTOT)
11465       IF (RR.LT.SIGDIR/SIGTOT) THEN
11466          IPNT = 1
11467       ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND.
11468      &        (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN
11469          IPNT = 2
11470       ELSE
11471          IPNT = 0
11472       ENDIF
11473       RPNT = (SIGDIR+SIGANO)/SIGTOT
11474 C     WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2
11475 C     WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO
11476 C     WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM
11477 C     WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT
11478       IF (MODE.EQ.1) RETURN
11479
11480 **sr 22.7.97
11481       K1   = 1
11482       K2   = 1
11483       RATE = ZERO
11484       IF (ECM.GE.ECMNN(NEBINI)) THEN
11485          K1   = NEBINI
11486          K2   = NEBINI
11487          RATE = ONE
11488       ELSEIF (ECM.GT.ECMNN(1)) THEN
11489          DO 10 I=2,NEBINI
11490             IF (ECM.LT.ECMNN(I)) THEN
11491                K1   = I-1
11492                K2   = I
11493                RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1))
11494                GOTO 11
11495             ENDIF
11496    10    CONTINUE
11497    11    CONTINUE
11498       ENDIF
11499       J1   = 1
11500       J2   = 1
11501       RATQ = ZERO
11502       IF (NQBINI.GT.1) THEN
11503          IF (VIRT.GE.Q2G(NQBINI)) THEN
11504             J1   = NQBINI
11505             J2   = NQBINI
11506             RATQ = ONE
11507          ELSEIF (VIRT.GT.Q2G(1)) THEN
11508             DO 12 I=2,NQBINI
11509                IF (VIRT.LT.Q2G(I)) THEN
11510                   J1   = I-1
11511                   J2   = I
11512                   RATQ = LOG10(   VIRT/MAX(Q2G(J1),TINY14))/
11513      &                   LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
11514                   GOTO 13
11515                ENDIF
11516    12       CONTINUE
11517    13       CONTINUE
11518          ENDIF
11519       ENDIF
11520       SGA = XSPRO(K1,J1,NTARG)+
11521      &      RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+
11522      &      RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+
11523      &      RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+
11524      &                 XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG))
11525       SDI = DBLE(NB)*SIGDIR
11526       SAN = DBLE(NB)*SIGANO
11527       SPL = SDI+SAN
11528       RR = DT_RNDM(SPL)
11529       IF (RR.LT.SDI/SGA) THEN
11530          IPNT = 1
11531       ELSEIF ((RR.GE.SDI/SGA).AND.
11532      &        (RR.LT.SPL/SGA)) THEN
11533          IPNT = 2
11534       ELSE
11535          IPNT = 0
11536       ENDIF
11537       RPNT = SPL/SGA
11538 C     WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM
11539 **
11540
11541       RETURN
11542       END
11543
11544 *$ CREATE DT_GLBINI.FOR
11545 *COPY DT_GLBINI
11546 *
11547 *===glbini=============================================================*
11548 *
11549       SUBROUTINE DT_GLBINI(WHAT)
11550
11551 ************************************************************************
11552 * Pre-initialization of profile function                               *
11553 * This version dated 28.11.00 is written by S. Roesler.                *
11554 *                                                                      *
11555 * Last change 27.12.2006 by S. Roesler.                                *
11556 ************************************************************************
11557
11558       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11559       SAVE
11560
11561       PARAMETER ( LINP = 10 ,
11562      &            LOUT = 6 ,
11563      &            LDAT = 9 )
11564       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14)
11565
11566       LOGICAL LCMS
11567
11568 * particle properties (BAMJET index convention)
11569       CHARACTER*8  ANAME
11570       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11571      &                IICH(210),IIBAR(210),K1(210),K2(210)
11572 * properties of interacting particles
11573       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11574       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11575 * emulsion treatment
11576       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11577      &                NCOMPO,IEMUL
11578 * Glauber formalism: flags and parameters for statistics
11579       LOGICAL LPROD
11580       CHARACTER*8 CGLB
11581       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11582 * number of data sets other than protons and nuclei
11583 * at the moment = 2 (pions and kaons)
11584       PARAMETER (MAXOFF=2)
11585       DIMENSION IJPINI(5),IOFFST(25)
11586       DATA IJPINI / 13, 15,  0,  0,  0/
11587 * Glauber data-set to be used for hadron projectiles
11588 * (0=proton, 1=pion, 2=kaon)
11589       DATA (IOFFST(K),K=1,25) /
11590      &  0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11591      &  0, 0, 1, 2, 2/
11592 * Acceptance interval for target nucleus mass
11593       PARAMETER (KBACC = 6)
11594 * flags for input different options
11595       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
11596       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
11597      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
11598
11599       PARAMETER (MAXMSS = 100)
11600       DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS)
11601       DIMENSION WHAT(6)
11602
11603       DATA JPEACH,JPSTEP / 18, 5 /
11604
11605 * temporary patch until fix has been implemented in phojet:
11606 *  maximum energy for pion projectile
11607       DATA ECMXPI / 100000.0D0 /
11608 *
11609 *--------------------------------------------------------------------------
11610 * general initializations
11611 *
11612 *  steps in projectile mass number for initialization
11613       IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4))
11614       IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5))
11615 *
11616 *  energy range and binning
11617       ELO  = ABS(WHAT(1))
11618       EHI  = ABS(WHAT(2))
11619       IF (ELO.GT.EHI) ELO = EHI
11620       NEBIN = MAX(INT(WHAT(3)),1)
11621       IF (ELO.EQ.EHI) NEBIN = 0
11622       LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO)
11623       IF (LCMS) THEN
11624          ECMINI = EHI
11625       ELSE
11626          ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2
11627      &                 +2.0D0*AAM(IJTARG)*EHI)
11628       ENDIF
11629 *
11630 *  default arguments for Glauber-routine
11631       XI  = ZERO
11632       Q2I = ZERO
11633 *
11634 *  initialize nuclear parameters, etc.
11635       CALL DT_BERTTP
11636       CALL DT_INCINI
11637 *
11638 *  open Glauber-data output file
11639       IDX = INDEX(CGLB,' ')
11640       K   = 12
11641       IF (IDX.GT.1) K = IDX-1
11642       OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
11643 *
11644 *--------------------------------------------------------------------------
11645 * Glauber-initialization for proton and nuclei projectiles
11646 *
11647 *  initialize phojet for proton-proton interactions
11648       ELAB = ZERO
11649       PLAB = ZERO
11650       CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11651       CALL DT_PHOINI
11652 *
11653 *  record projectile masses
11654       NASAV = 0
11655       NPROJ = MIN(IP,JPEACH)
11656       DO 10 KPROJ=1,NPROJ
11657          NASAV = NASAV+1
11658          IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11659          IASAV(NASAV) = KPROJ
11660    10 CONTINUE
11661       IF (IP.GT.JPEACH) THEN
11662          NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP)
11663          IF (NPROJ.EQ.0) THEN
11664             NASAV = NASAV+1
11665             IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11666             IASAV(NASAV) = IP
11667          ELSE
11668             DO 11 IPROJ=1,NPROJ
11669                KPROJ = JPEACH+IPROJ*JPSTEP
11670                NASAV = NASAV+1
11671                IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11672                IASAV(NASAV) = KPROJ
11673    11       CONTINUE
11674             IF (KPROJ.LT.IP) THEN
11675                NASAV = NASAV+1
11676                IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
11677                IASAV(NASAV) = IP
11678             ENDIF
11679          ENDIF
11680       ENDIF
11681 *
11682 *  record target masses
11683       NBSAV = 0
11684       NTARG = 1
11685       IF (NCOMPO.GT.0) NTARG = NCOMPO
11686       DO 12 ITARG=1,NTARG
11687          NBSAV = NBSAV+1
11688          IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! '
11689          IF (NCOMPO.GT.0) THEN
11690             IBSAV(NBSAV) = IEMUMA(ITARG)
11691          ELSE
11692             IBSAV(NBSAV) = IT
11693          ENDIF
11694    12 CONTINUE
11695 *
11696 *  print masses
11697       WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2))
11698  1000 FORMAT(I4,A,1P,2E13.5)
11699       NLINES = DBLE(NASAV)/18.0D0
11700       IF (NLINES.GT.0) THEN
11701          DO 13 I=1,NLINES
11702             IF (I.EQ.1) THEN
11703                WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18)
11704             ELSE
11705                WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I)
11706             ENDIF
11707    13    CONTINUE
11708       ENDIF
11709       I0 = 18*NLINES+1
11710       IF (I0.LE.NASAV) THEN
11711          IF (I0.EQ.1) THEN
11712             WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV)
11713          ELSE
11714             WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV)
11715          ENDIF
11716       ENDIF
11717       NLINES = DBLE(NBSAV)/18.0D0
11718       IF (NLINES.GT.0) THEN
11719          DO 14 I=1,NLINES
11720             IF (I.EQ.1) THEN
11721                WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18)
11722             ELSE
11723                WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I)
11724             ENDIF
11725    14    CONTINUE
11726       ENDIF
11727       I0 = 18*NLINES+1
11728       IF (I0.LE.NBSAV) THEN
11729          IF (I0.EQ.1) THEN
11730             WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV)
11731          ELSE
11732             WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV)
11733          ENDIF
11734       ENDIF
11735 *
11736 *  calculate Glauber-data for each energy and mass combination
11737 *
11738 *   loop over energy bins
11739       ELO = LOG10(ELO)
11740       EHI = LOG10(EHI)
11741       DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE)
11742       DO 1 IE=1,NEBIN+1
11743          E = ELO+DBLE(IE-1)*DEBIN
11744          E = 10**E
11745          IF (LCMS) THEN
11746             E   = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E)
11747             ECM = E
11748          ELSE
11749             PLAB = ZERO
11750             ECM  = ZERO
11751             E    = MAX(AAM(IJPROJ)+0.1D0,E)
11752             CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11753          ENDIF
11754 *
11755 *   loop over projectile and target masses
11756          DO 2 ITARG=1,NBSAV
11757             DO 3 IPROJ=1,NASAV
11758                CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ,
11759      &                                       XI,Q2I,ECM,1,1,-1)
11760     3       CONTINUE
11761     2    CONTINUE
11762 *
11763     1 CONTINUE
11764 *
11765 *--------------------------------------------------------------------------
11766 * Glauber-initialization for pion, kaon, ... projectiles
11767 *
11768       DO 6 IJ=1,MAXOFF
11769 *
11770 *  initialize phojet for this interaction
11771          ELAB = ZERO
11772          PLAB = ZERO
11773          IJPROJ = IJPINI(IJ)
11774          IP     = 1
11775          IPZ    = 1
11776 *
11777 *   temporary patch until fix has been implemented in phojet:
11778          IF (ECMINI.GT.ECMXPI) THEN
11779             CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1)
11780          ELSE
11781             CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
11782          ENDIF
11783          CALL DT_PHOINI
11784 *
11785 *  calculate Glauber-data for each energy and mass combination
11786 *
11787 *   loop over energy bins
11788          DO 4 IE=1,NEBIN+1
11789             E = ELO+DBLE(IE-1)*DEBIN
11790             E = 10**E
11791             IF (LCMS) THEN
11792                E   = MAX(2.0D0*AAM(IJPROJ)+TINY14,E)
11793                ECM = E
11794             ELSE
11795                PLAB = ZERO
11796                ECM  = ZERO
11797                E    = MAX(AAM(IJPROJ)+TINY14,E)
11798                CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
11799             ENDIF
11800 *
11801 *   loop over projectile and target masses
11802             DO 5 ITARG=1,NBSAV
11803                CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1)
11804     5       CONTINUE
11805 *
11806     4    CONTINUE
11807 *
11808     6 CONTINUE
11809
11810 *--------------------------------------------------------------------------
11811 * close output unit(s), etc.
11812 *
11813       CLOSE(LDAT)
11814
11815       RETURN
11816       END
11817
11818 *$ CREATE DT_GLBSET.FOR
11819 *COPY DT_GLBSET
11820 *
11821 *===glbset=============================================================*
11822 *
11823       SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE)
11824 ************************************************************************
11825 * Interpolation of pre-initialized profile functions                   *
11826 * This version dated 28.11.00 is written by S. Roesler.                *
11827 ************************************************************************
11828
11829       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11830       SAVE
11831
11832       PARAMETER ( LINP = 10 ,
11833      &            LOUT = 6 ,
11834      &            LDAT = 9 )
11835       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
11836
11837       LOGICAL LCMS,LREAD,LFRST1,LFRST2
11838
11839 * particle properties (BAMJET index convention)
11840       CHARACTER*8  ANAME
11841       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11842      &                IICH(210),IIBAR(210),K1(210),K2(210)
11843 * Glauber formalism: flags and parameters for statistics
11844       LOGICAL LPROD
11845       CHARACTER*8 CGLB
11846       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11847       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11848 * Glauber formalism: parameters
11849       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11850      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11851      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11852      &                NSITEB,NSTATB
11853 * Glauber formalism: cross sections
11854       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11855      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11856      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11857      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11858      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11859      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11860      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11861      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11862      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11863      &                BSLOPE,NEBINI,NQBINI
11864 * number of data sets other than protons and nuclei
11865 * at the moment = 2 (pions and kaons)
11866       PARAMETER (MAXOFF=2)
11867       DIMENSION IJPINI(5),IOFFST(25)
11868       DATA IJPINI / 13, 15,  0,  0,  0/
11869 * Glauber data-set to be used for hadron projectiles
11870 * (0=proton, 1=pion, 2=kaon)
11871       DATA (IOFFST(K),K=1,25) /
11872      &  0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
11873      &  0, 0, 1, 2, 2/
11874 * Acceptance interval for target nucleus mass
11875       PARAMETER (KBACC = 6)
11876 * emulsion treatment
11877       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11878      &                NCOMPO,IEMUL
11879
11880       PARAMETER (MAXSET=5000,
11881      &           MAXBIN=100)
11882       DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB)
11883       DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6),
11884      &          BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB),
11885      &          IAIDX(10)
11886
11887       DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./
11888 *
11889 * read data from file
11890 *
11891       IF (MODE.EQ.0) THEN
11892
11893          IF (LREAD) RETURN
11894
11895          DO 1 I=1,MAXSET
11896             DO 2 J=1,6
11897                XSIG(I,J) = ZERO
11898                XERR(I,J) = ZERO
11899     2       CONTINUE
11900             DO 3 J=1,KSITEB
11901                BPROFL(I,J) = ZERO
11902     3       CONTINUE
11903     1    CONTINUE
11904          DO 4 I=1,MAXBIN
11905             IABIN(I) = 0
11906             IBBIN(I) = 0
11907     4    CONTINUE
11908          DO 5 I=1,KSITEB
11909             BPRO0(I) = ZERO
11910             BPRO1(I) = ZERO
11911             BPRO(I)  = ZERO
11912     5    CONTINUE
11913
11914          IDX = INDEX(CGLB,' ')
11915          K   = 12
11916          IF (IDX.GT.1) K = IDX-1
11917          OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
11918          WRITE(LOUT,1000) CGLB(1:K)//'.glb'
11919  1000    FORMAT(/,' GLBSET: impact parameter distributions read from ',
11920      &          'file ',A12,/)
11921 *
11922 *  read binning information
11923          READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI
11924 *  return lower energy threshold to Fluka-interface
11925          ELAB = ELO
11926          LCMS = ELO.LT.ZERO
11927          WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:'
11928          IF (LCMS) THEN
11929             WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN
11930          ELSE
11931             WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN
11932          ENDIF
11933  1001    FORMAT(2X,A5,'  E_lo = ',1P,E9.3,'  E_hi = ',1P,E9.3,4X,
11934      &          'No. of bins:',I5,/)
11935          ELO  = LOG10(ABS(ELO))
11936          EHI  = LOG10(ABS(EHI))
11937          DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN))
11938          WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)'
11939          READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18)
11940          IF (NABIN.LT.18) THEN
11941             WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN)
11942          ELSE
11943             WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18)
11944          ENDIF
11945          IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !'
11946          IF (NABIN.GT.18) THEN
11947             NLINES = DBLE(NABIN-18)/18.0D0
11948             IF (NLINES.GT.0) THEN
11949                DO 7 I=1,NLINES
11950                   I0 = 18*(I+1)-17
11951                   READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
11952                   WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
11953     7          CONTINUE
11954             ENDIF
11955             I0 = 18*(NLINES+1)+1
11956             IF (I0.LE.NABIN) THEN
11957                READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
11958                WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
11959             ENDIF
11960          ENDIF
11961          WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)'
11962          READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18)
11963          IF (NBBIN.LT.18) THEN
11964             WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN)
11965          ELSE
11966             WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18)
11967          ENDIF
11968          IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !'
11969          IF (NBBIN.GT.18) THEN
11970             NLINES = DBLE(NBBIN-18)/18.0D0
11971             IF (NLINES.GT.0) THEN
11972                DO 8 I=1,NLINES
11973                   I0 = 18*(I+1)-17
11974                   READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
11975                   WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
11976     8          CONTINUE
11977             ENDIF
11978             I0 = 18*(NLINES+1)+1
11979             IF (I0.LE.NBBIN) THEN
11980                READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
11981                WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
11982             ENDIF
11983          ENDIF
11984 *  number of data sets to follow in the Glauber data file
11985 *   this variable is used for checks of consistency of projectile
11986 *   and target mass configurations given in header of Glauber data
11987 *   file and the data-sets which follow in this file
11988          NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN
11989 *
11990 *  read profile function data
11991          NSET  = 0
11992          NAIDX = 0
11993          IPOLD = 0
11994    10    CONTINUE
11995          NSET = NSET+1
11996          IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! '
11997          READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM
11998  1002    FORMAT(5I10,E15.5)
11999          IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN
12000             NAIDX = NAIDX+1
12001             IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !'
12002             IAIDX(NAIDX) = IP
12003             IPOLD = IP
12004          ENDIF
12005          READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6)
12006          READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6)
12007          NLINES = INT(DBLE(ISITEB)/7.0D0)
12008          IF (NLINES.GT.0) THEN
12009             DO 11 I=1,NLINES
12010                READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I)
12011    11       CONTINUE
12012          ENDIF
12013          I0 = 7*NLINES+1
12014          IF (I0.LE.ISITEB)
12015      &      READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB)
12016          GOTO 10
12017   100    CONTINUE
12018          NSET = NSET-1
12019          IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !'
12020          WRITE(LOUT,'(/,1X,A)')
12021      &   ' projectiles other than protons and nuclei: (particle index)'
12022          IF (NAIDX.GT.0) THEN
12023             WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX)
12024          ELSE
12025             WRITE(LOUT,'(6X,A)') 'none'
12026          ENDIF
12027 *
12028          CLOSE(LDAT)
12029          WRITE(LOUT,*)
12030          LREAD = .TRUE.
12031
12032          IF (NCOMPO.EQ.0) THEN
12033             DO 12 J=1,NBBIN
12034                NCOMPO = NCOMPO+1
12035                IEMUMA(NCOMPO) = IBBIN(J)
12036                IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2
12037                EMUFRA(NCOMPO) = 1.0D0
12038    12       CONTINUE
12039             IEMUL = 1
12040          ENDIF
12041 *
12042 * calculate profile function for certain set of parameters
12043 *
12044       ELSE
12045
12046 c        write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE
12047 *
12048 * check for type of projectile and set index-offset to entry in
12049 * Glauber data array correspondingly
12050          IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !'
12051          IF (IOFFST(IDPROJ).EQ.-1) THEN
12052             STOP ' GLBSET: no data for this projectile !'
12053          ELSEIF (IOFFST(IDPROJ).GT.0) THEN
12054             IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN
12055          ELSE
12056             IDXOFF = 0
12057          ENDIF
12058 *
12059 * get energy bin and interpolation factor
12060          IF (LCMS) THEN
12061             E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB)
12062          ELSE
12063             E = ELAB
12064          ENDIF
12065          E = LOG10(E)
12066          IF (E.LT.ELO) THEN
12067             IF (LFRST1) THEN
12068                WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E
12069                LFRST1 = .FALSE.
12070             ENDIF
12071             E = ELO
12072          ENDIF
12073          IF (E.GT.EHI) THEN
12074             IF (LFRST2) THEN
12075                WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E
12076                LFRST2 = .FALSE.
12077             ENDIF
12078             E = EHI
12079          ENDIF
12080          IE0  = (E-ELO)/DEBIN+1
12081          IE1  = IE0+1
12082          FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN
12083 *
12084 * get target nucleus index
12085          KB = 0
12086          NBACC = KBACC
12087          DO 20 I=1,NBBIN
12088             NBDIFF = ABS(NB-IBBIN(I))
12089             IF (NB.EQ.IBBIN(I)) THEN
12090                KB = I
12091                GOTO 21
12092             ELSEIF (NBDIFF.LE.NBACC) THEN
12093                KB = I
12094                NBACC = NBDIFF
12095             ENDIF
12096    20    CONTINUE
12097          IF (KB.NE.0) GOTO 21
12098          WRITE(LOUT,*) ' GLBSET: data not found for target ',NB
12099          STOP
12100    21    CONTINUE
12101 *
12102 * get projectile nucleus bin and interpolation factor
12103          KA0 = 0
12104          KA1 = 0
12105          FACNA = 0
12106          IF (IDXOFF.GT.0) THEN
12107             KA0 = 1
12108             KA1 = 1
12109             KABIN = 1
12110          ELSE
12111             IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !'
12112             DO 22 I=1,NABIN
12113                IF (NA.EQ.IABIN(I)) THEN
12114                   KA0 = I
12115                   KA1 = I
12116                   GOTO 23
12117                ELSEIF (NA.LT.IABIN(I)) THEN
12118                   KA0 = I-1
12119                   KA1 = I
12120                   GOTO 23
12121                ENDIF
12122    22       CONTINUE
12123             WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA
12124             STOP
12125    23       CONTINUE
12126             IF (KA0.NE.KA1)
12127      &         FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0))
12128             KABIN = NABIN
12129          ENDIF
12130 *
12131 * interpolate profile functions for interactions ka0-kb and ka1-kb
12132 * for energy E separately
12133          IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12134          IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12135          IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12136          IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12137          DO 30 I=1,ISITEB
12138             BPRO0(I) = BPROFL(IDX0,I)
12139      &                 +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I))
12140             BPRO1(I) = BPROFL(IDY0,I)
12141      &                 +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I))
12142    30    CONTINUE
12143          RADB  = DT_RNCLUS(NB)
12144          BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1)
12145          BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1)
12146 *
12147 * interpolate cross sections for energy E and projectile mass
12148          DO 31 I=1,6
12149             XS0   = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I))
12150             XS1   = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I))
12151             XS(I) = XS0+FACNA*(XS1-XS0)
12152             XE0   = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I))
12153             XE1   = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I))
12154             XE(I) = XE0+FACNA*(XE1-XE0)
12155    31    CONTINUE
12156 *
12157 * interpolate between ka0 and ka1
12158          RADA = DT_RNCLUS(NA)
12159          BMX  = 2.0D0*(RADA+RADB)
12160          BSTP = BMX/DBLE(ISITEB-1)
12161          BPRO(1) = ZERO
12162          DO 32 I=1,ISITEB-1
12163             B = DBLE(I)*BSTP
12164 *
12165 *   calculate values of profile functions at B
12166             IDX0 = B/BSTP0+1
12167             IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12168             IDX1 = MIN(IDX0+1,ISITEB)
12169             FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0
12170             BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0))
12171             IDX0 = B/BSTP1+1
12172             IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12173             IDX1 = MIN(IDX0+1,ISITEB)
12174             FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1
12175             BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0))
12176 *
12177             BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0)
12178    32    CONTINUE
12179 *
12180 * fill common dtglam
12181          NSITEB   = ISITEB
12182          RASH(1)  = RADA
12183          RBSH(1)  = RADB
12184          BMAX(1)  = BMX
12185          BSTEP(1) = BSTP
12186          DO 33 I=1,KSITEB
12187             BSITE(0,1,1,I) = BPRO(I)
12188    33    CONTINUE
12189 *
12190 * fill common dtglxs
12191          XSTOT(1,1,1) = XS(1)
12192          XSELA(1,1,1) = XS(2)
12193          XSQEP(1,1,1) = XS(3)
12194          XSQET(1,1,1) = XS(4)
12195          XSQE2(1,1,1) = XS(5)
12196          XSPRO(1,1,1) = XS(6)
12197          XETOT(1,1,1) = XE(1)
12198          XEELA(1,1,1) = XE(2)
12199          XEQEP(1,1,1) = XE(3)
12200          XEQET(1,1,1) = XE(4)
12201          XEQE2(1,1,1) = XE(5)
12202          XEPRO(1,1,1) = XE(6)
12203
12204       ENDIF
12205
12206       RETURN
12207       END
12208
12209 *$ CREATE DT_XKSAMP.FOR
12210 *COPY DT_XKSAMP
12211 *
12212 *===xksamp=============================================================*
12213 *
12214       SUBROUTINE DT_XKSAMP(NN,ECM)
12215
12216 ************************************************************************
12217 * Sampling of parton x-values and chain system for one interaction.    *
12218 *                                   processed by S. Roesler, 9.8.95    *
12219 ************************************************************************
12220
12221       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12222       SAVE
12223       PARAMETER ( LINP = 10 ,
12224      &            LOUT = 6 ,
12225      &            LDAT = 9 )
12226       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
12227 CPH      SAVE
12228
12229       PARAMETER (
12230 * lower cuts for (valence-sea/sea-valence) chain masses
12231 *   antiquark-quark (u/d-sea quark)    (s-sea quark)
12232      &               AMIU = 0.5D0,      AMIS = 0.8D0,
12233 *   quark-diquark   (u/d-sea quark)    (s-sea quark)
12234      &               AMAU = 2.6D0,      AMAS = 2.6D0,
12235 * maximum lower valence-x threshold
12236      &           XVMAX  = 0.98D0,
12237 * fraction of sea-diquarks sampled out of sea-partons
12238 **test
12239 C    &           FRCDIQ = 0.9D0,
12240 **
12241 *
12242      &           SQMA   = 0.7D0,
12243 *
12244 * maximum number of trials to generate x's for the required number
12245 * of sea quark pairs for a given hadron
12246      &           NSEATY = 12
12247 C    &           NSEATY = 3
12248      &          )
12249
12250       LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO
12251
12252       PARAMETER ( MAXNCL = 260,
12253      &            MAXVQU = MAXNCL,
12254      &            MAXSQU = 20*MAXVQU,
12255      &            MAXINT = MAXVQU+MAXSQU)
12256 * event history
12257       PARAMETER (NMXHKK=200000)
12258       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
12259      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
12260      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
12261 * particle properties (BAMJET index convention)
12262       CHARACTER*8  ANAME
12263       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12264      &                IICH(210),IIBAR(210),K1(210),K2(210)
12265 * interface between Glauber formalism and DPM
12266       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
12267      &                INTER1(MAXINT),INTER2(MAXINT)
12268 * properties of interacting particles
12269       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12270 * threshold values for x-sampling (DTUNUC 1.x)
12271       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
12272      &                SSMIMQ,VVMTHR
12273 * x-values of partons (DTUNUC 1.x)
12274       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
12275      &                XTVQ(MAXVQU),XTVD(MAXVQU),
12276      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
12277      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
12278 * flavors of partons (DTUNUC 1.x)
12279       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
12280      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
12281      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
12282      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
12283      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
12284      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
12285      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
12286 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12287       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
12288      &                IXPV,IXPS,IXTV,IXTS,
12289      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
12290      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
12291      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
12292      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
12293      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
12294      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
12295      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
12296      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
12297 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12298       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
12299      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
12300 * auxiliary common for chain system storage (DTUNUC 1.x)
12301       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
12302 * flags for input different options
12303       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12304       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12305      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12306 * various options for treatment of partons (DTUNUC 1.x)
12307 * (chain recombination, Cronin,..)
12308       LOGICAL LCO2CR,LINTPT
12309       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
12310      &                LCO2CR,LINTPT
12311
12312       DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU),
12313      &          INTLO(MAXINT)
12314
12315 * (1) initializations
12316 *-----------------------------------------------------------------------
12317
12318 **test
12319       IF (ECM.LT.4.5D0) THEN
12320 C        FRCDIQ = 0.6D0
12321          FRCDIQ = 0.4D0
12322       ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN
12323 C        FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0
12324          FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0
12325       ELSE
12326 C        FRCDIQ = 0.9D0
12327          FRCDIQ = 0.7D0
12328       ENDIF
12329 **
12330       DO 30 I=1,MAXSQU
12331          ZUOSP(I) = .FALSE.
12332          ZUOST(I) = .FALSE.
12333          IF (I.LE.MAXVQU) THEN
12334             ZUOVP(I) = .FALSE.
12335             ZUOVT(I) = .FALSE.
12336          ENDIF
12337    30 CONTINUE
12338
12339 * lower thresholds for x-selection
12340 *  sea-quarks       (default: CSEA=0.2)
12341       IF (ECM.LT.10.0D0) THEN
12342 **!!test
12343          XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM
12344 C        XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0
12345          NSEA  = NSEATY
12346 C        XSTHR = ONE/ECM**2
12347       ELSE
12348 **sr 30.3.98
12349 C        XSTHR = CSEA/ECM
12350          XSTHR = CSEA/ECM**2
12351 C        XSTHR = ONE/ECM**2
12352 **
12353          IF ((IP.GE.150).AND.(IT.GE.150))
12354      &      XSTHR = 2.5D0/(ECM*SQRT(ECM))
12355          NSEA  = NSEATY
12356       ENDIF
12357 *                   (default: SSMIMA=0.14) used for sea-diquarks (?)
12358       XSSTHR = SSMIMA/ECM
12359       BSQMA  = SQMA/ECM
12360 *  valence-quarks   (default: CVQ=1.0)
12361       XVTHR  = CVQ/ECM
12362 *  valence-diquarks (default: CDQ=2.0)
12363       XDTHR  = CDQ/ECM
12364
12365 * maximum-x for sea-quarks
12366       XVCUT  = XVTHR+XDTHR
12367       IF (XVCUT.GT.XVMAX) THEN
12368          XVCUT = XVMAX
12369          XVTHR = XVCUT/3.0D0
12370          XDTHR = XVCUT-XVTHR
12371       ENDIF
12372       XXSEAM = ONE-XVCUT
12373 **sr 18.4. test: DPMJET
12374 C     XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1))
12375 C    &            - XDTHR*(1.D0+0.3D0*DT_RNDM(V2))
12376 C    &             -0.01*(1.D0+1.5D0*DT_RNDM(V3))
12377 **
12378 * maximum number of sea-pairs allowed kinematically
12379 C     NSMAX  = INT(OHALF*XXSEAM/XSTHR)
12380       RNSMAX = OHALF*XXSEAM/XSTHR
12381       IF (RNSMAX.GT.10000.0D0) THEN
12382          NSMAX = 10000
12383       ELSE
12384          NSMAX = INT(OHALF*XXSEAM/XSTHR)
12385       ENDIF
12386 * check kinematical limit for valence-x thresholds
12387 * (should be obsolete now)
12388       IF (XVCUT.GT.XVMAX) THEN
12389          WRITE(LOUT,1000) XVCUT,ECM
12390  1000    FORMAT(' XKSAMP:    kin. limit for valence-x',
12391      &          '  thresholds not allowed (',2E9.3,')')
12392 C        XVTHR = XVMAX-XDTHR
12393 C        IF (XVTHR.LT.ZERO) STOP
12394          STOP
12395       ENDIF
12396
12397 * set eta for valence-x sampling (BETREJ)
12398 *   (UNON per default, UNOM used for projectile mesons only)
12399       IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN
12400          UNOPRV = UNOM
12401       ELSE
12402          UNOPRV = UNON
12403       ENDIF
12404
12405 * (2) select parton x-values of interacting projectile nucleons
12406 *-----------------------------------------------------------------------
12407
12408       IXPV = 0
12409       IXPS = 0
12410
12411       DO 100 IPP=1,IP
12412 *   get interacting projectile nucleon as sampled by Glauber
12413          IF (JSSH(IPP).NE.0) THEN
12414             IXSTMP = IXPS
12415             IXVTMP = IXPV
12416    99       CONTINUE
12417             IXPS   = IXSTMP
12418             IXPV   = IXVTMP
12419 *     JIPP is the actual number of sea-pairs sampled for this nucleon
12420             JIPP   = MIN(JSSH(IPP)-1,NSMAX)
12421    41       CONTINUE
12422             XXSEA  = ZERO
12423             IF (JIPP.GT.0) THEN
12424                XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR
12425 *???
12426                IF (XSTHR.GE.XSMAX) THEN
12427                   JIPP = JIPP-1
12428                   GOTO 41
12429                ENDIF
12430
12431 *>>>get x-values of sea-quark pairs
12432                NSCOUN = 0
12433                PLW = 0.5D0
12434    40          CONTINUE
12435 *     accumulator for sea x-values
12436                XXSEA  = ZERO
12437                NSCOUN = NSCOUN+1
12438                IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12439                IF (NSCOUN.GT.NSEA) THEN
12440 *     decrease the number of interactions after NSEA trials
12441                   JIPP   = JIPP-1
12442                   NSCOUN = 0
12443                ENDIF
12444                DO 70 ISQ=1,JIPP
12445 *     sea-quarks
12446                   IF (IPSQ(IXPS+1).LE.2) THEN
12447 **sr 8.4.98 (1/sqrt(x))
12448 C                    XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12449 C                    XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12450                      XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12451 **
12452                   ELSE
12453                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
12454                         XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12455                      ELSE
12456 **sr 8.4.98 (1/sqrt(x))
12457 C                       XPSQI = DT_SAMPEX(XSTHR,XSMAX)
12458 C                       XPSQI = DT_SAMSQX(XSTHR,XSMAX)
12459                         XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12460 **
12461                      ENDIF
12462                   ENDIF
12463 *     sea-antiquarks
12464                   IF (IPSAQ(IXPS+1).GE.-2) THEN
12465 **sr 8.4.98 (1/sqrt(x))
12466 C                    XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12467 C                    XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12468                      XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12469 **
12470                   ELSE
12471                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
12472                         XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12473                      ELSE
12474 **sr 8.4.98 (1/sqrt(x))
12475 C                       XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
12476 C                       XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
12477                         XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12478 **
12479                      ENDIF
12480                   ENDIF
12481                   XXSEA = XXSEA+XPSQI+XPSAQI
12482 *     check for maximum allowed sea x-value
12483                   IF (XXSEA.GE.XXSEAM) THEN
12484                      IXPS = IXPS-ISQ+1
12485                      GOTO 40
12486                   ENDIF
12487 *     accept this sea-quark pair
12488                   IXPS         = IXPS+1
12489                   XPSQ(IXPS)   = XPSQI
12490                   XPSAQ(IXPS)  = XPSAQI
12491                   IFROSP(IXPS) = IPP
12492                   ZUOSP(IXPS)  = .TRUE.
12493    70          CONTINUE
12494             ENDIF
12495
12496 *>>>get x-values of valence partons
12497 *     valence quark
12498             IF (XVTHR.GT.0.05D0) THEN
12499                XVHI  = ONE-XXSEA-XDTHR
12500                XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI)
12501             ELSE
12502    90          CONTINUE
12503                XPVQI = DT_DBETAR(OHALF,UNOPRV)
12504                IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR))
12505      &                                                     GOTO 90
12506             ENDIF
12507 *     valence diquark
12508             XPVDI = ONE-XPVQI-XXSEA
12509 *       reject according to x**1.5
12510             XDTMP = XPVDI**1.5D0
12511             IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99
12512 *     accept these valence partons
12513             IXPV         = IXPV+1
12514             XPVQ(IXPV)   = XPVQI
12515             XPVD(IXPV)   = XPVDI
12516             IFROVP(IXPV) = IPP
12517             ITOVP(IPP)   = IXPV
12518             ZUOVP(IXPV)  = .TRUE.
12519
12520          ENDIF
12521   100 CONTINUE
12522
12523 * (3) select parton x-values of interacting target nucleons
12524 *-----------------------------------------------------------------------
12525
12526       IXTV = 0
12527       IXTS = 0
12528
12529       DO 170 ITT=1,IT
12530 *   get interacting target nucleon as sampled by Glauber
12531          IF (JTSH(ITT).NE.0) THEN
12532             IXSTMP = IXTS
12533             IXVTMP = IXTV
12534   169       CONTINUE
12535             IXTS   = IXSTMP
12536             IXTV   = IXVTMP
12537 *     JITT is the actual number of sea-pairs sampled for this nucleon
12538             JITT   = MIN(JTSH(ITT)-1,NSMAX)
12539   111       CONTINUE
12540             XXSEA  = ZERO
12541             IF (JITT.GT.0) THEN
12542                XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR
12543 *???
12544                IF (XSTHR.GE.XSMAX) THEN
12545                   JITT = JITT-1
12546                   GOTO 111
12547                ENDIF
12548
12549 *>>>get x-values of sea-quark pairs
12550                NSCOUN = 0
12551                PLW = 0.5D0
12552   110          CONTINUE
12553 *     accumulator for sea x-values
12554                XXSEA  = ZERO
12555                NSCOUN = NSCOUN+1
12556                IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
12557                IF (NSCOUN.GT.NSEA)THEN
12558 *     decrease the number of interactions after NSEA trials
12559                   JITT   = JITT-1
12560                   NSCOUN = 0
12561                ENDIF
12562                DO 140 ISQ=1,JITT
12563 *     sea-quarks
12564                   IF (ITSQ(IXTS+1).LE.2) THEN
12565 **sr 8.4.98 (1/sqrt(x))
12566 C                    XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12567 C                    XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12568                      XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12569 **
12570                   ELSE
12571                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
12572                         XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12573                      ELSE
12574 **sr 8.4.98 (1/sqrt(x))
12575 C                       XTSQI = DT_SAMPEX(XSTHR,XSMAX)
12576 C                       XTSQI = DT_SAMSQX(XSTHR,XSMAX)
12577                         XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12578 **
12579                      ENDIF
12580                   ENDIF
12581 *     sea-antiquarks
12582                   IF (ITSAQ(IXTS+1).GE.-2) THEN
12583 **sr 8.4.98 (1/sqrt(x))
12584 C                    XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12585 C                    XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12586                      XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12587 **
12588                   ELSE
12589                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
12590                         XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
12591                      ELSE
12592 **sr 8.4.98 (1/sqrt(x))
12593 C                       XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
12594 C                       XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
12595                         XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
12596 **
12597                      ENDIF
12598                   ENDIF
12599                   XXSEA = XXSEA+XTSQI+XTSAQI
12600 *     check for maximum allowed sea x-value
12601                   IF (XXSEA.GE.XXSEAM) THEN
12602                      IXTS = IXTS-ISQ+1
12603                      GOTO 110
12604                   ENDIF
12605 *     accept this sea-quark pair
12606                   IXTS         = IXTS+1
12607                   XTSQ(IXTS)   = XTSQI
12608                   XTSAQ(IXTS)  = XTSAQI
12609                   IFROST(IXTS) = ITT
12610                   ZUOST(IXTS)  = .TRUE.
12611   140          CONTINUE
12612             ENDIF
12613
12614 *>>>get x-values of valence partons
12615 *     valence quark
12616             IF (XVTHR.GT.0.05D0) THEN
12617                XVHI  = ONE-XXSEA-XDTHR
12618                XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI)
12619             ELSE
12620   160          CONTINUE
12621                XTVQI = DT_DBETAR(OHALF,UNON)
12622                IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR))
12623      &                                                    GOTO 160
12624             ENDIF
12625 *     valence diquark
12626             XTVDI = ONE-XTVQI-XXSEA
12627 *       reject according to x**1.5
12628             XDTMP = XTVDI**1.5D0
12629             IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169
12630 *     accept these valence partons
12631             IXTV         = IXTV+1
12632             XTVQ(IXTV)   = XTVQI
12633             XTVD(IXTV)   = XTVDI
12634             IFROVT(IXTV) = ITT
12635             ITOVT(ITT)   = IXTV
12636             ZUOVT(IXTV)  = .TRUE.
12637
12638          ENDIF
12639   170 CONTINUE
12640
12641 * (4) get valence-valence chains
12642 *-----------------------------------------------------------------------
12643
12644       NVV = 0
12645       DO 240 I=1,NN
12646          INTLO(I) = .TRUE.
12647          IPVAL    = ITOVP(INTER1(I))
12648          ITVAL    = ITOVT(INTER2(I))
12649          IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN
12650             INTLO(I)      = .FALSE.
12651             ZUOVP(IPVAL)  = .FALSE.
12652             ZUOVT(ITVAL)  = .FALSE.
12653             NVV           = NVV+1
12654             ISKPCH(8,NVV) = 0
12655             INTVV1(NVV)   = IPVAL
12656             INTVV2(NVV)   = ITVAL
12657          ENDIF
12658   240 CONTINUE
12659
12660 * (5) get sea-valence chains
12661 *-----------------------------------------------------------------------
12662
12663       NSV = 0
12664       NDV = 0
12665       PLW = 0.5D0
12666       DO 270 I=1,NN
12667          IF (INTLO(I)) THEN
12668             IPVAL = ITOVP(INTER1(I))
12669             ITVAL = ITOVT(INTER2(I))
12670             DO 250 J=1,IXPS
12671                IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND.
12672      &                                ZUOVT(ITVAL)) THEN
12673                   ZUOSP(J)     = .FALSE.
12674                   ZUOVT(ITVAL) = .FALSE.
12675                   INTLO(I)     = .FALSE.
12676                   IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN
12677 *   sample sea-diquark pair
12678                      CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1)
12679                      IF (IREJ1.EQ.0) GOTO 260
12680                   ENDIF
12681                   NSV           = NSV+1
12682                   ISKPCH(4,NSV) = 0
12683                   INTSV1(NSV)   = J
12684                   INTSV2(NSV)   = ITVAL
12685
12686 *>>>correct chain kinematics according to minimum chain masses
12687 *     the actual chain masses
12688                   AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2
12689                   AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2
12690 *     get lower mass cuts
12691                   IF (IPSQ(J).EQ.3) THEN
12692 *       q being s-quark
12693                      AMCHK1 = AMAS
12694                      AMCHK2 = AMIS
12695                   ELSE
12696 *       q being u/d-quark
12697                      AMCHK1 = AMAU
12698                      AMCHK2 = AMIU
12699                   ENDIF
12700 *       q-qq chain
12701 *         chain mass above minimum - resampling of sea-q x-value
12702                   IF (AMSVQ1.GT.AMCHK1) THEN
12703                      XPSQTH      = AMCHK1/(XTVD(ITVAL)*ECM**2)
12704 **sr 8.4.98 (1/sqrt(x))
12705 C                    XPSQXX      = DT_SAMPEX(XPSQTH,XPSQ(J))
12706 C                    XPSQXX      = DT_SAMSQX(XPSQTH,XPSQ(J))
12707                      XPSQXX      = DT_SAMPLW(XPSQTH,XPSQ(J),PLW)
12708 **
12709                      XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX
12710                      XPSQ(J)     = XPSQXX
12711 *         chain mass below minimum - reset sea-q x-value and correct
12712 *                                    diquark-x of the same nucleon
12713                   ELSEIF (AMSVQ1.LT.AMCHK1) THEN
12714                      XPSQW       = AMCHK1/(XTVD(ITVAL)*ECM**2)
12715                      DXPSQ       = XPSQW-XPSQ(J)
12716                      IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12717                         XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12718                         XPSQ(J)     = XPSQW
12719                      ENDIF
12720                   ENDIF
12721 *       aq-q chain
12722 *         chain mass below minimum - reset sea-aq x-value and correct
12723 *                                    diquark-x of the same nucleon
12724                   IF (AMSVQ2.LT.AMCHK2) THEN
12725                      XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2)
12726                      DXPSQ = XPSQW-XPSAQ(J)
12727                      IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
12728                         XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
12729                         XPSAQ(J)    = XPSQW
12730                      ENDIF
12731                   ENDIF
12732 *>>>end of chain mass correction
12733
12734                   GOTO 260
12735                ENDIF
12736   250       CONTINUE
12737          ENDIF
12738   260    CONTINUE
12739   270 CONTINUE
12740
12741 * (6) get valence-sea chains
12742 *-----------------------------------------------------------------------
12743
12744       NVS = 0
12745       NVD = 0
12746       DO 300 I=1,NN
12747          IF (INTLO(I)) THEN
12748             IPVAL = ITOVP(INTER1(I))
12749             ITVAL = ITOVT(INTER2(I))
12750             DO 280 J=1,IXTS
12751                IF (ZUOVP(IPVAL).AND.ZUOST(J).AND.
12752      &                  (IFROST(J).EQ.INTER2(I))) THEN
12753                   ZUOST(J)     = .FALSE.
12754                   ZUOVP(IPVAL) = .FALSE.
12755                   INTLO(I)     = .FALSE.
12756                   IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
12757 *   sample sea-diquark pair
12758                      CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1)
12759                      IF (IREJ1.EQ.0) GOTO 290
12760                   ENDIF
12761                   NVS           = NVS + 1
12762                   ISKPCH(6,NVS) = 0
12763                   INTVS1(NVS)   = IPVAL
12764                   INTVS2(NVS)   = J
12765
12766 *>>>correct chain kinematics according to minimum chain masses
12767 *     the actual chain masses
12768                   AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2
12769                   AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2
12770 *     get lower mass cuts
12771                   IF (ITSQ(J).EQ.3) THEN
12772 *       q being s-quark
12773                      AMCHK1 = AMIS
12774                      AMCHK2 = AMAS
12775                   ELSE
12776 *       q being u/d-quark
12777                      AMCHK1 = AMIU
12778                      AMCHK2 = AMAU
12779                   ENDIF
12780 *       q-aq chain
12781 *         chain mass below minimum - reset sea-aq x-value and correct
12782 *                                    diquark-x of the same nucleon
12783                   IF (AMVSQ1.LT.AMCHK1) THEN
12784                      XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2)
12785                      DXTSQ = XTSQW-XTSAQ(J)
12786                      IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12787                         XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12788                         XTSAQ(J)    = XTSQW
12789                      ENDIF
12790                   ENDIF
12791 *       qq-q chain
12792 *         chain mass above minimum - resampling of sea-q x-value
12793                   IF (AMVSQ2.GT.AMCHK2) THEN
12794                      XTSQTH      = AMCHK2/(XPVD(IPVAL)*ECM**2)
12795 **sr 8.4.98 (1/sqrt(x))
12796 C                    XTSQXX      = DT_SAMPEX(XTSQTH,XTSQ(J))
12797 C                    XTSQXX      = DT_SAMSQX(XTSQTH,XTSQ(J))
12798                      XTSQXX      = DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
12799 **
12800                      XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX
12801                      XTSQ(J)     = XTSQXX
12802 *         chain mass below minimum - reset sea-q x-value and correct
12803 *                                    diquark-x of the same nucleon
12804                   ELSEIF (AMVSQ2.LT.AMCHK2) THEN
12805                      XTSQW       = AMCHK2/(XPVD(IPVAL)*ECM**2)
12806                      DXTSQ       = XTSQW-XTSQ(J)
12807                      IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
12808                         XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
12809                         XTSQ(J)     = XTSQW
12810                      ENDIF
12811                   ENDIF
12812 *>>>end of chain mass correction
12813
12814                   GOTO 290
12815                ENDIF
12816   280       CONTINUE
12817          ENDIF
12818   290    CONTINUE
12819   300 CONTINUE
12820
12821 * (7) get sea-sea chains
12822 *-----------------------------------------------------------------------
12823
12824       NSS = 0
12825       NDS = 0
12826       NSD = 0
12827       DO 420 I=1,NN
12828          IF (INTLO(I)) THEN
12829             IPVAL = ITOVP(INTER1(I))
12830             ITVAL = ITOVT(INTER2(I))
12831 *   loop over target partons not yet matched
12832             DO 400 J=1,IXTS
12833                IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN
12834 *   loop over projectile partons not yet matched
12835                   DO 390 JJ=1,IXPS
12836                      IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN
12837                         ZUOSP(JJ)     = .FALSE.
12838                         ZUOST(J)      = .FALSE.
12839                         INTLO(I)      = .FALSE.
12840                         NSS           = NSS+1
12841                         ISKPCH(1,NSS) = 0
12842                         INTSS1(NSS)   = JJ
12843                         INTSS2(NSS)   = J
12844
12845 *---->chain recombination option
12846                         VALFRA        = DBLE(NVV/(NVV+IXPS+IXTS))
12847                         IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA))
12848      &                                                             THEN
12849 *       sea-sea chains may recombine with valence-valence chains
12850 *       only if they have the same projectile or target nucleon
12851                            DO 4201 IVV=1,NVV
12852                               IF (ISKPCH(8,IVV).NE.99) THEN
12853                                  IXVPR = INTVV1(IVV)
12854                                  IXVTA = INTVV2(IVV)
12855                                  IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR.
12856      &                               (INTER2(I).EQ.IFROVT(IXVTA))) THEN
12857 *         recombination possible, drop old v-v and s-s chains
12858                                     ISKPCH(1,NSS) = 99
12859                                     ISKPCH(8,IVV) = 99
12860
12861 *         (a) assign new s-v chains
12862 *         ~~~~~~~~~~~~~~~~~~~~~~~~~
12863                                     IF (LSEADI.AND.
12864      &                                  (DT_RNDM(VALFRA).GT.FRCDIQ))
12865      &                                                             THEN
12866 *           sample sea-diquark pair
12867                                        CALL DT_SAMSDQ(ECM,IXVTA,JJ,2,
12868      &                                                      IREJ1)
12869                                        IF (IREJ1.EQ.0) GOTO 4202
12870                                     ENDIF
12871                                     NSV           = NSV+1
12872                                     ISKPCH(4,NSV) = 0
12873                                     INTSV1(NSV)   = JJ
12874                                     INTSV2(NSV)   = IXVTA
12875 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
12876 *           the actual chain masses
12877                                     AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA)
12878      &                                                     *ECM**2
12879                                     AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA)
12880      &                                                     *ECM**2
12881 *           get lower mass cuts
12882                                     IF (IPSQ(JJ).EQ.3) THEN
12883 *             q being s-quark
12884                                        AMCHK1 = AMAS
12885                                        AMCHK2 = AMIS
12886                                     ELSE
12887 *             q being u/d-quark
12888                                        AMCHK1 = AMAU
12889                                        AMCHK2 = AMIU
12890                                     ENDIF
12891 *           q-qq chain
12892 *             chain mass above minimum - resampling of sea-q x-value
12893                                     IF (AMSVQ1.GT.AMCHK1) THEN
12894                                        XPSQTH      =
12895      &                                    AMCHK1/(XTVD(IXVTA)*ECM**2)
12896 **sr 8.4.98 (1/sqrt(x))
12897                                        XPSQXX      =
12898      &                                    DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW)
12899 C    &                                    DT_SAMSQX(XPSQTH,XPSQ(JJ))
12900 C    &                                    DT_SAMPEX(XPSQTH,XPSQ(JJ))
12901 **
12902                                        XPVD(IPVAL) =
12903      &                                    XPVD(IPVAL)+XPSQ(JJ)-XPSQXX
12904                                        XPSQ(JJ)    = XPSQXX
12905 *             chain mass below minimum - reset sea-q x-value and correct
12906 *                                        diquark-x of the same nucleon
12907                                     ELSEIF (AMSVQ1.LT.AMCHK1) THEN
12908                                        XPSQW =
12909      &                                    AMCHK1/(XTVD(IXVTA)*ECM**2)
12910                                        DXPSQ = XPSQW-XPSQ(JJ)
12911                                        IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
12912      &                                                            THEN
12913                                           XPVD(IPVAL) =
12914      &                                       XPVD(IPVAL)-DXPSQ
12915                                           XPSQ(JJ)    = XPSQW
12916                                        ENDIF
12917                                     ENDIF
12918 *           aq-q chain
12919 *             chain mass below minimum - reset sea-aq x-value and correct
12920 *                                        diquark-x of the same nucleon
12921                                     IF (AMSVQ2.LT.AMCHK2) THEN
12922                                        XPSQW =
12923      &                                    AMCHK2/(XTVQ(IXVTA)*ECM**2)
12924                                        DXPSQ = XPSQW-XPSAQ(JJ)
12925                                        IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
12926      &                                                            THEN
12927                                           XPVD(IPVAL) =
12928      &                                       XPVD(IPVAL)-DXPSQ
12929                                           XPSAQ(JJ)   = XPSQW
12930                                        ENDIF
12931                                     ENDIF
12932 *>>>>>>>>>>>end of chain mass correction
12933  4202                               CONTINUE
12934
12935 *         (b) assign new v-s chains
12936 *         ~~~~~~~~~~~~~~~~~~~~~~~~~
12937                                     IF (LSEADI.AND.(
12938      &                                  DT_RNDM(AMSVQ2).GT.FRCDIQ))
12939      &                                                             THEN
12940 *           sample sea-diquark pair
12941                                        CALL DT_SAMSDQ(ECM,IXVPR,J,1,
12942      &                                                      IREJ1)
12943                                        IF (IREJ1.EQ.0) GOTO 4203
12944                                     ENDIF
12945                                     NVS           = NVS+1
12946                                     ISKPCH(6,NVS) = 0
12947                                     INTVS1(NVS)   = IXVPR
12948                                     INTVS2(NVS)   = J
12949 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
12950 *           the actual chain masses
12951                                     AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2
12952                                     AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2
12953 *           get lower mass cuts
12954                                     IF (ITSQ(J).EQ.3) THEN
12955 *             q being s-quark
12956                                        AMCHK1 = AMIS
12957                                        AMCHK2 = AMAS
12958                                     ELSE
12959 *             q being u/d-quark
12960                                        AMCHK1 = AMIU
12961                                        AMCHK2 = AMAU
12962                                     ENDIF
12963 *           q-aq chain
12964 *             chain mass below minimum - reset sea-aq x-value and correct
12965 *                                        diquark-x of the same nucleon
12966                                     IF (AMVSQ1.LT.AMCHK1) THEN
12967                                        XTSQW =
12968      &                                    AMCHK1/(XPVQ(IXVPR)*ECM**2)
12969                                        DXTSQ = XTSQW-XTSAQ(J)
12970                                        IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
12971      &                                                            THEN
12972                                           XTVD(ITVAL) =
12973      &                                       XTVD(ITVAL)-DXTSQ
12974                                           XTSAQ(J)    = XTSQW
12975                                        ENDIF
12976                                     ENDIF
12977                                     IF (AMVSQ2.GT.AMCHK2) THEN
12978                                        XTSQTH      =
12979      &                                    AMCHK2/(XPVD(IXVPR)*ECM**2)
12980 **sr 8.4.98 (1/sqrt(x))
12981                                        XTSQXX      =
12982      &                                    DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
12983 C    &                                    DT_SAMSQX(XTSQTH,XTSQ(J))
12984 C    &                                    DT_SAMPEX(XTSQTH,XTSQ(J))
12985 **
12986                                        XTVD(ITVAL) =
12987      &                                    XTVD(ITVAL)+XTSQ(J)-XTSQXX
12988                                        XTSQ(J)     = XTSQXX
12989                                     ELSEIF (AMVSQ2.LT.AMCHK2) THEN
12990                                        XTSQW =
12991      &                                    AMCHK2/(XPVD(IXVPR)*ECM**2)
12992                                        DXTSQ = XTSQW-XTSQ(J)
12993                                        IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
12994      &                                                            THEN
12995                                           XTVD(ITVAL) =
12996      &                                       XTVD(ITVAL)-DXTSQ
12997                                           XTSQ(J)     = XTSQW
12998                                        ENDIF
12999                                     ENDIF
13000 *>>>>>>>>>end of chain mass correction
13001  4203                               CONTINUE
13002 *       jump out of s-s chain loop
13003                                     GOTO 420
13004                                  ENDIF
13005                               ENDIF
13006  4201                      CONTINUE
13007                         ENDIF
13008 *---->end of chain recombination option
13009
13010 *     sample sea-diquark pair (projectile)
13011                         IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN
13012                            CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1)
13013                            IF (IREJ1.EQ.0) THEN
13014                               ISKPCH(1,NSS) = 99
13015                               GOTO 410
13016                            ENDIF
13017                         ENDIF
13018 *     sample sea-diquark pair (target)
13019                         IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13020                            CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1)
13021                            IF (IREJ1.EQ.0) THEN
13022                               ISKPCH(1,NSS) = 99
13023                               GOTO 410
13024                            ENDIF
13025                         ENDIF
13026 *>>>>>correct chain kinematics according to minimum chain masses
13027 *     the actual chain masses
13028                         SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2
13029                         SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2
13030 *     check for lower mass cuts
13031                         IF ((SSMA1Q.LT.SSMIMQ).OR.
13032      &                      (SSMA2Q.LT.SSMIMQ)) THEN
13033                            IPVAL = ITOVP(INTER1(I))
13034                            ITVAL = ITOVT(INTER2(I))
13035                            IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND.
13036      &                         (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN
13037 *       maximum allowed x values for sea quarks
13038                               XSPMAX = ONE-XPVQ(IPVAL)-XDTHR-
13039      &                                           1.2D0*XSSTHR
13040                               XSTMAX = ONE-XTVQ(ITVAL)-XDTHR-
13041      &                                           1.2D0*XSSTHR
13042 *       resampling of x values not possible - skip sea-sea chains
13043                               IF ((XSPMAX.LE.XSSTHR+0.05D0).OR.
13044      &                            (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380
13045 *       resampling of x for projectile sea quark pair
13046                               ICOUS = 0
13047   310                         CONTINUE
13048                               ICOUS = ICOUS+1
13049                               IF (XSSTHR.GT.0.05D0) THEN
13050                                  XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13051      &                                                         XSPMAX)
13052                                  XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13053      &                                                         XSPMAX)
13054                               ELSE
13055   320                            CONTINUE
13056                                  XPSQI = DT_DBETAR(XSEACU,UNOSEA)
13057                                  IF ((XPSQI.LT.XSSTHR).OR.
13058      &                               (XPSQI.GT.XSPMAX))  GOTO 320
13059   330                            CONTINUE
13060                                  XPSAQI = DT_DBETAR(XSEACU,UNOSEA)
13061                                  IF ((XPSAQI.LT.XSSTHR).OR.
13062      &                               (XPSAQI.GT.XSPMAX)) GOTO 330
13063                               ENDIF
13064 *       final test of remaining x for projectile diquark
13065                               XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI
13066      &                                            +XPSQ(JJ)+XPSAQ(JJ)
13067                               IF (XPVDCO.LE.XDTHR) THEN
13068 *!!!
13069 C                                IF (ICOUS.LT.5) GOTO 310
13070                                  IF (ICOUS.LT.0.5D0) GOTO 310
13071                                  GOTO 380
13072                               ENDIF
13073 *       resampling of x for target sea quark pair
13074                               ICOUS = 0
13075   350                         CONTINUE
13076                               ICOUS = ICOUS+1
13077                               IF (XSSTHR.GT.0.05D0) THEN
13078                                  XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13079      &                                                         XSTMAX)
13080                                  XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13081      &                                                         XSTMAX)
13082                               ELSE
13083   360                            CONTINUE
13084                                  XTSQI = DT_DBETAR(XSEACU,UNOSEA)
13085                                  IF ((XTSQI.LT.XSSTHR).OR.
13086      &                               (XTSQI.GT.XSTMAX))  GOTO 360
13087   370                            CONTINUE
13088                                  XTSAQI = DT_DBETAR(XSEACU,UNOSEA)
13089                                  IF ((XTSAQI.LT.XSSTHR).OR.
13090      &                               (XTSAQI.GT.XSTMAX)) GOTO 370
13091                               ENDIF
13092 *       final test of remaining x for target diquark
13093                               XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI
13094      &                                            +XTSQ(J)+XTSAQ(J)
13095                               IF (XTVDCO.LT.XDTHR) THEN
13096                                  IF (ICOUS.LT.5) GOTO 350
13097                                  GOTO 380
13098                               ENDIF
13099                               XPVD(IPVAL) = XPVDCO
13100                               XTVD(ITVAL) = XTVDCO
13101                               XPSQ(JJ)    = XPSQI
13102                               XPSAQ(JJ)   = XPSAQI
13103                               XTSQ(J)     = XTSQI
13104                               XTSAQ(J)    = XTSAQI
13105 *>>>>>end of chain mass correction
13106                               GOTO 410
13107                            ENDIF
13108 *     come here to discard s-s interaction
13109 *     resampling of x values not allowed or unsuccessful
13110   380                      CONTINUE
13111                            INTLO(I)  = .FALSE.
13112                            ZUOST(J)  = .TRUE.
13113                            ZUOSP(JJ) = .TRUE.
13114                            NSS       = NSS-1
13115                         ENDIF
13116 *   consider next s-s interaction
13117                         GOTO 410
13118                      ENDIF
13119   390             CONTINUE
13120                ENDIF
13121   400       CONTINUE
13122          ENDIF
13123   410    CONTINUE
13124   420 CONTINUE
13125
13126 * correct x-values of valence quarks for non-matching sea quarks
13127       DO 430 I=1,IXPS
13128          IF (ZUOSP(I)) THEN
13129             IPVAL       = ITOVP(IFROSP(I))
13130             XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I)
13131             XPSQ(I)     = ZERO
13132             XPSAQ(I)    = ZERO
13133             ZUOSP(I)    = .FALSE.
13134          ENDIF
13135   430 CONTINUE
13136       DO 440 I=1,IXTS
13137          IF (ZUOST(I)) THEN
13138             ITVAL       = ITOVT(IFROST(I))
13139             XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I)
13140             XTSQ(I)     = ZERO
13141             XTSAQ(I)    = ZERO
13142             ZUOST(I)    = .FALSE.
13143          ENDIF
13144   440 CONTINUE
13145       DO 450 I=1,IXPV
13146          IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13
13147   450 CONTINUE
13148       DO 460 I=1,IXTV
13149          IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14
13150   460 CONTINUE
13151
13152       RETURN
13153       END
13154
13155 *$ CREATE DT_SAMSDQ.FOR
13156 *COPY DT_SAMSDQ
13157 *
13158 *===samsdq=============================================================*
13159 *
13160       SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ)
13161
13162 ************************************************************************
13163 * SAMpling of Sea-DiQuarks                                             *
13164 *              ECM        cm-energy of the nucleon-nucleon system      *
13165 *              IDX1,2     indices of x-values of the participating     *
13166 *                         partons (IDX2 is always the sea-q-pair to be *
13167 *                         changed to sea-qq-pair)                      *
13168 *              MODE       = 1  valence-q - sea-diq                     *
13169 *                         = 2  sea-diq   - valence-q                   *
13170 *                         = 3  sea-q     - sea-diq                     *
13171 *                         = 4  sea-diq   - sea-q                       *
13172 * Based on DIQVS, DIQSV, DIQSSD, DIQDSS.                               *
13173 * This version dated 17.10.95 is written by S. Roesler                 *
13174 ************************************************************************
13175
13176       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13177       SAVE
13178
13179       PARAMETER (ZERO=0.0D0)
13180
13181 * threshold values for x-sampling (DTUNUC 1.x)
13182       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
13183      &                SSMIMQ,VVMTHR
13184 * various options for treatment of partons (DTUNUC 1.x)
13185 * (chain recombination, Cronin,..)
13186       LOGICAL LCO2CR,LINTPT
13187       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
13188      &                LCO2CR,LINTPT
13189       PARAMETER ( MAXNCL = 260,
13190      &            MAXVQU = MAXNCL,
13191      &            MAXSQU = 20*MAXVQU,
13192      &            MAXINT = MAXVQU+MAXSQU)
13193 * x-values of partons (DTUNUC 1.x)
13194       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
13195      &                XTVQ(MAXVQU),XTVD(MAXVQU),
13196      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
13197      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
13198 * flavors of partons (DTUNUC 1.x)
13199       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
13200      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
13201      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
13202      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
13203      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
13204      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
13205      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
13206 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13207       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
13208      &                IXPV,IXPS,IXTV,IXTS,
13209      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
13210      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
13211      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
13212      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
13213      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
13214      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
13215      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
13216      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
13217 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13218       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
13219      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
13220 * auxiliary common for chain system storage (DTUNUC 1.x)
13221       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
13222
13223       IREJ = 0
13224 *  threshold-x for valence diquarks
13225       XDTHR = CDQ/ECM
13226
13227       GOTO (1,2,3,4) MODE
13228
13229 *---------------------------------------------------------------------
13230 * proj. valence partons - targ. sea partons
13231 * get x-values and flavors for target sea-diquark pair
13232
13233     1 CONTINUE
13234       IDXVP = IDX1
13235       IDXST = IDX2
13236
13237 *  index of corr. val-diquark-x in target nucleon
13238       IDXVT = ITOVT(IFROST(IDXST))
13239 *  available x above diquark thresholds for valence- and sea-diquarks
13240       XXD   = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13241
13242       IF (XXD.GE.ZERO) THEN
13243 *  x-values for the three diquarks of the target nucleon
13244          RR1    = DT_RNDM(XXD)
13245          RR2    = DT_RNDM(RR1)
13246          RR3    = DT_RNDM(RR2)
13247          SR123  = RR1+RR2+RR3
13248          XXTV   = XDTHR+RR1*XXD/SR123
13249          XXTSQ  = XDTHR+RR2*XXD/SR123
13250          XXTSAQ = XDTHR+RR3*XXD/SR123
13251       ELSE
13252          XXTV   = XTVD(IDXVT)
13253          XXTSQ  = XTSQ(IDXST)
13254          XXTSAQ = XTSAQ(IDXST)
13255       ENDIF
13256 *  flavor of the second quarks in the sea-diquark pair
13257       ITSQ2(IDXST)  = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13258       ITSAQ2(IDXST) = -ITSQ2(IDXST)
13259 *  check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains
13260       AM1    = XXTSQ *XPVQ(IDXVP)*ECM**2
13261       AM2    = XXTSAQ*XPVD(IDXVP)*ECM**2
13262       IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13263 *    ss-asas pair
13264      &     ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0))            ) THEN
13265          IREJ = 1
13266          RETURN
13267       ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13268 *    at least one strange quark
13269      &         ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0))        ) THEN
13270          IREJ = 1
13271          RETURN
13272       ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13273          IREJ = 1
13274          RETURN
13275       ENDIF
13276 *  accept the new sea-diquark
13277       XTVD(IDXVT)   = XXTV
13278       XTSQ(IDXST)   = XXTSQ
13279       XTSAQ(IDXST)  = XXTSAQ
13280       NVD           = NVD+1
13281       INTVD1(NVD)   = IDXVP
13282       INTVD2(NVD)   = IDXST
13283       ISKPCH(7,NVD) = 0
13284       RETURN
13285
13286 *---------------------------------------------------------------------
13287 * proj. sea partons - targ. valence partons
13288 * get x-values and flavors for projectile sea-diquark pair
13289
13290     2 CONTINUE
13291       IDXSP = IDX2
13292       IDXVT = IDX1
13293
13294 *  index of corr. val-diquark-x in projectile nucleon
13295       IDXVP = ITOVP(IFROSP(IDXSP))
13296 *  available x above diquark thresholds for valence- and sea-diquarks
13297       XXD   = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13298
13299       IF (XXD.GE.ZERO) THEN
13300 *  x-values for the three diquarks of the projectile nucleon
13301          RR1    = DT_RNDM(XXD)
13302          RR2    = DT_RNDM(RR1)
13303          RR3    = DT_RNDM(RR2)
13304          SR123  = RR1+RR2+RR3
13305          XXPV   = XDTHR+RR1*XXD/SR123
13306          XXPSQ  = XDTHR+RR2*XXD/SR123
13307          XXPSAQ = XDTHR+RR3*XXD/SR123
13308       ELSE
13309          XXPV   = XPVD(IDXVP)
13310          XXPSQ  = XPSQ(IDXSP)
13311          XXPSAQ = XPSAQ(IDXSP)
13312       ENDIF
13313 *  flavor of the second quarks in the sea-diquark pair
13314       IPSQ2(IDXSP)  = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13315       IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13316 *  check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains
13317       AM1    = XXPSQ *XTVQ(IDXVT)*ECM**2
13318       AM2    = XXPSAQ*XTVD(IDXVT)*ECM**2
13319       IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13320 *    ss-asas pair
13321      &     ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0))            ) THEN
13322          IREJ = 1
13323          RETURN
13324       ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13325 *    at least one strange quark
13326      &         ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0))        ) THEN
13327          IREJ = 1
13328          RETURN
13329       ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13330          IREJ = 1
13331          RETURN
13332       ENDIF
13333 *  accept the new sea-diquark
13334       XPVD(IDXVP)   = XXPV
13335       XPSQ(IDXSP)   = XXPSQ
13336       XPSAQ(IDXSP)  = XXPSAQ
13337       NDV           = NDV+1
13338       INTDV1(NDV)   = IDXSP
13339       INTDV2(NDV)   = IDXVT
13340       ISKPCH(5,NDV) = 0
13341       RETURN
13342
13343 *---------------------------------------------------------------------
13344 * proj. sea partons - targ. sea partons
13345 * get x-values and flavors for target sea-diquark pair
13346
13347     3 CONTINUE
13348       IDXSP = IDX1
13349       IDXST = IDX2
13350
13351 *  index of corr. val-diquark-x in target nucleon
13352       IDXVT = ITOVT(IFROST(IDXST))
13353 *  available x above diquark thresholds for valence- and sea-diquarks
13354       XXD   = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13355
13356       IF (XXD.GE.ZERO) THEN
13357 *  x-values for the three diquarks of the target nucleon
13358          RR1    = DT_RNDM(XXD)
13359          RR2    = DT_RNDM(RR1)
13360          RR3    = DT_RNDM(RR2)
13361          SR123  = RR1+RR2+RR3
13362          XXTV   = XDTHR+RR1*XXD/SR123
13363          XXTSQ  = XDTHR+RR2*XXD/SR123
13364          XXTSAQ = XDTHR+RR3*XXD/SR123
13365       ELSE
13366          XXTV   = XTVD(IDXVT)
13367          XXTSQ  = XTSQ(IDXST)
13368          XXTSAQ = XTSAQ(IDXST)
13369       ENDIF
13370 *  flavor of the second quarks in the sea-diquark pair
13371       ITSQ2(IDXST)  = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13372       ITSAQ2(IDXST) = -ITSQ2(IDXST)
13373 *  check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains
13374       AM1    = XXTSQ *XPSQ(IDXSP)*ECM**2
13375       AM2    = XXTSAQ*XPSAQ(IDXSP)*ECM**2
13376       IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13377 *    ss-asas pair
13378      &     ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0))            ) THEN
13379          IREJ = 1
13380          RETURN
13381       ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13382 *    at least one strange quark
13383      &         ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0))        ) THEN
13384          IREJ = 1
13385          RETURN
13386       ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13387          IREJ = 1
13388          RETURN
13389       ENDIF
13390 *  accept the new sea-diquark
13391       XTVD(IDXVT)   = XXTV
13392       XTSQ(IDXST)   = XXTSQ
13393       XTSAQ(IDXST)  = XXTSAQ
13394       NSD           = NSD+1
13395       INTSD1(NSD)   = IDXSP
13396       INTSD2(NSD)   = IDXST
13397       ISKPCH(3,NSD) = 0
13398       RETURN
13399
13400 *---------------------------------------------------------------------
13401 * proj. sea partons - targ. sea partons
13402 * get x-values and flavors for projectile sea-diquark pair
13403
13404     4 CONTINUE
13405       IDXSP = IDX2
13406       IDXST = IDX1
13407
13408 *  index of corr. val-diquark-x in projectile nucleon
13409       IDXVP = ITOVP(IFROSP(IDXSP))
13410 *  available x above diquark thresholds for valence- and sea-diquarks
13411       XXD   = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13412
13413       IF (XXD.GE.ZERO) THEN
13414 *  x-values for the three diquarks of the projectile nucleon
13415          RR1    = DT_RNDM(XXD)
13416          RR2    = DT_RNDM(RR1)
13417          RR3    = DT_RNDM(RR2)
13418          SR123  = RR1+RR2+RR3
13419          XXPV   = XDTHR+RR1*XXD/SR123
13420          XXPSQ  = XDTHR+RR2*XXD/SR123
13421          XXPSAQ = XDTHR+RR3*XXD/SR123
13422       ELSE
13423          XXPV   = XPVD(IDXVP)
13424          XXPSQ  = XPSQ(IDXSP)
13425          XXPSAQ = XPSAQ(IDXSP)
13426       ENDIF
13427 *  flavor of the second quarks in the sea-diquark pair
13428       IPSQ2(IDXSP)  = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13429       IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13430 *  check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains
13431       AM1    = XXPSQ *XTSQ(IDXST)*ECM**2
13432       AM2    = XXPSAQ*XTSAQ(IDXST)*ECM**2
13433       IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13434 *    ss-asas pair
13435      &     ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0))            ) THEN
13436          IREJ = 1
13437          RETURN
13438       ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13439 *    at least one strange quark
13440      &         ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0))        ) THEN
13441          IREJ = 1
13442          RETURN
13443       ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
13444          IREJ = 1
13445          RETURN
13446       ENDIF
13447 *  accept the new sea-diquark
13448       XPVD(IDXVP)   = XXPV
13449       XPSQ(IDXSP)   = XXPSQ
13450       XPSAQ(IDXSP)  = XXPSAQ
13451       NDS           = NDS+1
13452       INTDS1(NDS)   = IDXSP
13453       INTDS2(NDS)   = IDXST
13454       ISKPCH(2,NDS) = 0
13455       RETURN
13456       END
13457
13458 *$ CREATE DT_DIFEVT.FOR
13459 *COPY DT_DIFEVT
13460 *
13461 *===difevt=============================================================*
13462 *
13463       SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP,
13464      &                  IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ)
13465
13466 ************************************************************************
13467 * Interface to treatment of diffractive interactions.                  *
13468 *  (input)          IFP1/2        PDG-indizes of projectile partons    *
13469 *                                 (baryon: IFP2 - adiquark)            *
13470 *                   PP(4)         projectile 4-momentum                *
13471 *                   IFT1/2        PDG-indizes of target partons        *
13472 *                                 (baryon: IFT1 - adiquark)            *
13473 *                   PT(4)         target 4-momentum                    *
13474 *  (output)         JDIFF = 0     no diffraction                       *
13475 *                         = 1/-1  LMSD/LMDD                            *
13476 *                         = 2/-2  HMSD/HMDD                            *
13477 *                   NCSY          counter for two-chain systems        *
13478 *                                 dumped to DTEVT1                     *
13479 * This version dated 14.02.95 is written by S. Roesler                 *
13480 ************************************************************************
13481
13482       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13483       SAVE
13484       PARAMETER ( LINP = 10 ,
13485      &            LOUT = 6 ,
13486      &            LDAT = 9 )
13487       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5,
13488      &           OHALF=0.5D0)
13489
13490 * event history
13491       PARAMETER (NMXHKK=200000)
13492       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
13493      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
13494      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
13495 * extended event history
13496       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
13497      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
13498      &                IHIST(2,NMXHKK)
13499 * flags for diffractive interactions (DTUNUC 1.x)
13500       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
13501
13502       DIMENSION PP(4),PT(4)
13503
13504       LOGICAL LFIRST
13505       DATA LFIRST /.TRUE./
13506
13507       IREJ   = 0
13508       JDIFF  = 0
13509       IFLAGD = JDIFF
13510
13511 * cm. energy
13512       XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
13513      &          (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
13514 * identities of projectile hadron / target nucleon
13515       KPROJ = IDT_ICIHAD(IDHKK(MOP))
13516       KTARG = IDT_ICIHAD(IDHKK(MOT))
13517
13518 * single diffractive xsections
13519       CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM)
13520 * double diffractive xsections
13521 **!! no double diff yet
13522 C     CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM)
13523       DDTOT = 0.0D0
13524       DDHM  = 0.0D0
13525 **!!
13526 * total inelastic xsection
13527 C     SIGIN  = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM)
13528       DUMZER = ZERO
13529       CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL)
13530       SIGIN  = MAX(SIGTO-SIGEL,ZERO)
13531
13532 * fraction of diffractive processes
13533       FRADIF = (SDTOT+DDTOT)/SIGIN
13534
13535       IF (LFIRST) THEN
13536          WRITE(LOUT,1000) XM,SDTOT,SIGIN
13537  1000    FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ',
13538      &          F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ',
13539      &          F5.1,' mb',/)
13540          LFIRST = .FALSE.
13541       ENDIF
13542
13543       IF ((DT_RNDM(DDHM).LE.FRADIF).OR.
13544      &    (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN
13545 * diffractive interaction requested by x-section or by user
13546          FRASD  = SDTOT/(SDTOT+DDTOT)
13547          FRASDH = SDHM/SDTOT
13548 **sr needs to be specified!!
13549 C        FRADDH = DDHM/DDTOT
13550          FRADDH = 1.0D0
13551 **
13552          IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN
13553 *   single diffraction
13554             KDIFF = 1
13555             IF (DT_RNDM(DDTOT).LE.FRASDH) THEN
13556                KP = 2
13557                KT = 0
13558                IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND.
13559      &               ISINGD.NE.3) THEN
13560                   KP = 0
13561                   KT = 2
13562                ENDIF
13563             ELSE
13564                KP = 1
13565                KT = 0
13566                IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND.
13567      &               ISINGD.NE.3) THEN
13568                   KP = 0
13569                   KT = 1
13570                ENDIF
13571             ENDIF
13572          ELSE
13573 *   double diffraction
13574             KDIFF = -1
13575             IF (DT_RNDM(FRADDH).LE.FRADDH) THEN
13576                KP = 2
13577                KT = 2
13578             ELSE
13579                KP = 1
13580                KT = 1
13581             ENDIF
13582          ENDIF
13583          CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13584      &               IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13585          IF (IREJ1.EQ.0) THEN
13586             IFLAGD = 2*KDIFF
13587             IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF
13588          ELSE
13589             GOTO 9999
13590          ENDIF
13591       ENDIF
13592       JDIFF = IFLAGD
13593
13594       RETURN
13595
13596  9999 CONTINUE
13597       IREJ  = 1
13598       RETURN
13599       END
13600
13601 *$ CREATE DT_DIFFKI.FOR
13602 *COPY DT_DIFFKI
13603 *
13604 *===difkin=============================================================*
13605 *
13606       SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
13607      &                  IFT1,IFT2,PT,MOT,KT,NCSY,IREJ)
13608
13609 ************************************************************************
13610 * Kinematics of diffractive nucleon-nucleon interaction.               *
13611 *          IFP1/2   PDG-indizes of projectile partons                  *
13612 *                   (baryon: IFP2 - adiquark)                          *
13613 *          PP(4)    projectile 4-momentum                              *
13614 *          IFT1/2   PDG-indizes of target partons                      *
13615 *                   (baryon: IFT1 - adiquark)                          *
13616 *          PT(4)    target 4-momentum                                  *
13617 *          KP   = 0 projectile quasi-elastically scattered             *
13618 *               = 1            excited to low-mass diff. state         *
13619 *               = 2            excited to high-mass diff. state        *
13620 *          KT   = 0 target     quasi-elastically scattered             *
13621 *               = 1            excited to low-mass diff. state         *
13622 *               = 2            excited to high-mass diff. state        *
13623 * This version dated 12.02.95 is written by S. Roesler                 *
13624 ************************************************************************
13625
13626       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13627       SAVE
13628       PARAMETER ( LINP = 10 ,
13629      &            LOUT = 6 ,
13630      &            LDAT = 9 )
13631       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5)
13632
13633       LOGICAL LSTART
13634
13635 * particle properties (BAMJET index convention)
13636       CHARACTER*8  ANAME
13637       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
13638      &                IICH(210),IIBAR(210),K1(210),K2(210)
13639 * flags for input different options
13640       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
13641       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
13642      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
13643 * rejection counter
13644       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
13645      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
13646      &                IREXCI(3),IRDIFF(2),IRINC
13647 * kinematics of diffractive interactions (DTUNUC 1.x)
13648       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13649      &                PPF(4),PTF(4),
13650      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13651      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13652
13653       DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4),
13654      &          PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4)
13655
13656       DATA LSTART /.TRUE./
13657
13658       IF (LSTART) THEN
13659          WRITE(LOUT,2000)
13660  2000    FORMAT(/,1X,'DIFEVT:  diffractive interactions treated ')
13661          LSTART = .FALSE.
13662       ENDIF
13663
13664       IREJ = 0
13665
13666 * initialize common /DTDIKI/
13667       CALL DT_DIFINI
13668 * store momenta of initial incoming particles for emc-check
13669       IF (LEMCCK) THEN
13670          CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM)
13671          CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM)
13672       ENDIF
13673
13674 * masses of initial particles
13675       XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2
13676       XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2
13677       IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999
13678       XMP  = SQRT(XMP2)
13679       XMT  = SQRT(XMT2)
13680 * check quark-input (used to adjust coherence cond. for M-selection)
13681       IBP  = 0
13682       IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1
13683       IBT  = 0
13684       IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1
13685
13686 * parameter for Lorentz-transformation into nucleon-nucleon cms
13687       DO 3 K=1,4
13688          PITOT(K) = PP(K)+PT(K)
13689     3 CONTINUE
13690       XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2
13691       IF (XMTOT2.LE.ZERO) THEN
13692          WRITE(LOUT,1000) XMTOT2
13693  1000    FORMAT(1X,'DIFEVT:   negative cm. energy!  ',
13694      &          'XMTOT2 = ',E12.3)
13695          GOTO 9999
13696       ENDIF
13697       XMTOT = SQRT(XMTOT2)
13698       DO 4 K=1,4
13699          BGTOT(K) = PITOT(K)/XMTOT
13700     4 CONTINUE
13701 * transformation of nucleons into cms
13702       CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2),
13703      &            PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4))
13704       CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2),
13705      &            PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4))
13706 * rotation angles
13707       COD = PP1(3)/PPTOT
13708 C     SID = SQRT((ONE-COD)*(ONE+COD))
13709       PPT = SQRT(PP1(1)**2+PP1(2)**2)
13710       SID = PPT/PPTOT
13711       COF = ONE
13712       SIF = ZERO
13713       IF(PPTOT*SID.GT.TINY10) THEN
13714          COF   = PP1(1)/(SID*PPTOT)
13715          SIF   = PP1(2)/(SID*PPTOT)
13716          ANORF = SQRT(COF*COF+SIF*SIF)
13717          COF   = COF/ANORF
13718          SIF   = SIF/ANORF
13719       ENDIF
13720 * check consistency
13721       DO 5 K=1,4
13722          DEV1(K) = ABS(PP1(K)+PT1(K))
13723     5 CONTINUE
13724       DEV1(4) = ABS(DEV1(4)-XMTOT)
13725       IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR.
13726      &    (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10))     THEN
13727          WRITE(LOUT,1001) DEV1
13728  1001    FORMAT(1X,'DIFEVT:   inconsitent Lorentz-transformation! ',
13729      &          /,8X,4E12.3)
13730          GOTO 9999
13731       ENDIF
13732
13733 * select x-fractions in high-mass diff. interactions
13734       IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT)
13735
13736 * select diffractive masses
13737 * - projectile
13738       IF (KP.EQ.1) THEN
13739          XMPF = DT_XMLMD(XMTOT)
13740          CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1)
13741          IF (IREJ1.GT.0) GOTO 9999
13742       ELSEIF (KP.EQ.2) THEN
13743          XMPF = DT_XMHMD(XMTOT,IBP,1)
13744       ELSE
13745          XMPF = XMP
13746       ENDIF
13747 * - target
13748       IF (KT.EQ.1) THEN
13749          XMTF = DT_XMLMD(XMTOT)
13750          CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1)
13751          IF (IREJ1.GT.0) GOTO 9999
13752       ELSEIF (KT.EQ.2) THEN
13753          XMTF = DT_XMHMD(XMTOT,IBT,2)
13754       ELSE
13755          XMTF = XMT
13756       ENDIF
13757
13758 * kinematical treatment of "two-particle" system (masses - XMPF,XMTF)
13759       XMPF2 = XMPF**2
13760       XMTF2 = XMTF**2
13761       PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT)
13762       PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2)
13763
13764 * select momentum transfer (all t-values used here are <0)
13765 *   minimum absolute value to produce diffractive masses
13766       TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3))
13767       TT   = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1)
13768       IF (IREJ1.GT.0) GOTO 9999
13769
13770 * longitudinal momentum of excited/elastically scattered projectile
13771       PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT)
13772 * total transverse momentum due to t-selection
13773       PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2
13774       IF (PPBLT2.LT.ZERO) THEN
13775          WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT
13776  1002    FORMAT(1X,'DIFEVT:   inconsistent transverse momentum! ',
13777      &          E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3)
13778          GOTO 9999
13779       ENDIF
13780       CALL DT_DSFECF(SINPHI,COSPHI)
13781       PPBLT     = SQRT(PPBLT2)
13782       PPBLOB(1) = COSPHI*PPBLT
13783       PPBLOB(2) = SINPHI*PPBLT
13784
13785 * rotate excited/elastically scattered projectile into n-n cms.
13786       CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF,
13787      &                                                    XX,YY,ZZ)
13788       PPBLOB(1) = XX
13789       PPBLOB(2) = YY
13790       PPBLOB(3) = ZZ
13791
13792 * 4-momentum of excited/elastically scattered target and of exchanged
13793 * Pomeron
13794       DO 6 K=1,4
13795          IF (K.LT.4) PTBLOB(K) = -PPBLOB(K)
13796          PPOM1(K) = PP1(K)-PPBLOB(K)
13797     6 CONTINUE
13798       PTBLOB(4) = XMTOT-PPBLOB(4)
13799
13800 * Lorentz-transformation back into system of initial diff. collision
13801       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13802      &            PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4),
13803      &            PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4))
13804       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13805      &            PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4),
13806      &            PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4))
13807       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
13808      &            PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4),
13809      &            PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4))
13810
13811 * store 4-momentum of elastically scattered particle (in single diff.
13812 * events)
13813       IF (KP.EQ.0) THEN
13814          DO 7 K=1,4
13815             PSC(K) = PPF(K)
13816     7    CONTINUE
13817       ELSEIF (KT.EQ.0) THEN
13818          DO 8 K=1,4
13819             PSC(K) = PTF(K)
13820     8    CONTINUE
13821       ENDIF
13822
13823 * check consistency of kinematical treatment so far
13824       IF (LEMCCK) THEN
13825          CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM)
13826          CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM)
13827          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1)
13828          IF (IREJ1.NE.0) GOTO 9999
13829       ENDIF
13830       DO 9 K=1,4
13831          DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K))
13832          DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K))
13833     9 CONTINUE
13834       IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR.
13835      &    (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR.
13836      &    (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR.
13837      &    (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5))     THEN
13838          WRITE(LOUT,1003) DEV1,DEV2
13839  1003    FORMAT(1X,'DIFEVT:   inconsitent kinematical treatment!  ',
13840      &          2(/,8X,4E12.3))
13841          GOTO 9999
13842       ENDIF
13843
13844 * kinematical treatment for low-mass diffraction
13845       CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1)
13846       IF (IREJ1.NE.0) GOTO 9999
13847
13848 * dump diffractive chains into DTEVT1
13849       CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
13850       IF (IREJ1.NE.0) GOTO 9999
13851
13852       RETURN
13853
13854  9999 CONTINUE
13855       IRDIFF(1) = IRDIFF(1)+1
13856       IREJ      = 1
13857       RETURN
13858       END
13859
13860 *$ CREATE DT_XMHMD.FOR
13861 *COPY DT_XMHMD
13862 *
13863 *===xmhmd==============================================================*
13864 *
13865       DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE)
13866
13867 ************************************************************************
13868 * Diffractive mass in high mass single/double diffractive events.      *
13869 * This version dated 11.02.95 is written by S. Roesler                 *
13870 ************************************************************************
13871
13872       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13873       SAVE
13874       PARAMETER ( LINP = 10 ,
13875      &            LOUT = 6 ,
13876      &            LDAT = 9 )
13877       PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)
13878
13879 * kinematics of diffractive interactions (DTUNUC 1.x)
13880       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
13881      &                PPF(4),PTF(4),
13882      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
13883      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
13884
13885 C     DATA XCOLOW /0.05D0/
13886       DATA XCOLOW /0.15D0/
13887
13888       DT_XMHMD = ZERO
13889       XH = XPH(2)
13890       IF (MODE.EQ.2) XH = XTH(2)
13891
13892 * minimum Pomeron-x for high-mass diffraction
13893 * (adjusted to get a smooth transition between HM and LM component)
13894       R = DT_RNDM(XH)
13895       XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2)
13896       IF (ECM.LE.300.0D0) THEN
13897          RR     = (1.0D0-EXP(-((ECM/140.0D0)**4)))
13898          XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2)
13899       ENDIF
13900 * maximum Pomeron-x for high-mass diffraction
13901 * (coherence condition, adjusted to fit to experimental data)
13902       IF (IB.NE.0) THEN
13903 *   baryon-diffraction
13904          XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2)))
13905       ELSE
13906 *   meson-diffraction
13907          XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2)))
13908       ENDIF
13909 * check boundaries
13910       IF (XDIMIN.GE.XDIMAX) THEN
13911          XDIMIN = OHALF*XDIMAX
13912       ENDIF
13913
13914       KLOOP = 0
13915     1 CONTINUE
13916       KLOOP = KLOOP+1
13917       IF (KLOOP.GT.20) RETURN
13918 * sample Pomeron-x from 1/x-distribution (critical Pomeron)
13919       XDIFF = DT_SAMPEX(XDIMIN,XDIMAX)
13920 * corr. diffr. mass
13921       DT_XMHMD = ECM*SQRT(XDIFF)
13922       IF (DT_XMHMD.LT.2.5D0) GOTO 1
13923
13924       RETURN
13925       END
13926
13927 *$ CREATE DT_XMLMD.FOR
13928 *COPY DT_XMLMD
13929 *
13930 *===xmlmd==============================================================*
13931 *
13932       DOUBLE PRECISION FUNCTION DT_XMLMD(ECM)
13933
13934 ************************************************************************
13935 * Diffractive mass in high mass single/double diffractive events.      *
13936 * This version dated 11.02.95 is written by S. Roesler                 *
13937 ************************************************************************
13938
13939       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13940       SAVE
13941       PARAMETER ( LINP = 10 ,
13942      &            LOUT = 6 ,
13943      &            LDAT = 9 )
13944
13945 * minimum Pomeron-x for low-mass diffraction
13946 C     AMO = 1.5D0
13947       AMO = 2.0D0
13948 * maximum Pomeron-x for low-mass diffraction
13949 * (adjusted to get a smooth transition between HM and LM component)
13950       R   = DT_RNDM(AMO)
13951       SAM = 1.0D0
13952       IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4))
13953       R   = DT_RNDM(AMO)*SAM
13954       AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0)
13955       AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX
13956
13957 * selection of diffractive mass
13958 * (adjusted to get a smooth transition between HM and LM component)
13959       R   = DT_RNDM(AMU)
13960       IF (ECM.LE.50.0D0) THEN
13961          DT_XMLMD = AMO*(AMU/AMO)**R
13962       ELSE
13963          A = 0.7D0
13964          IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2)))
13965          DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A))
13966       ENDIF
13967
13968       RETURN
13969       END
13970
13971 *$ CREATE DT_TDIFF.FOR
13972 *COPY DT_TDIFF
13973 *
13974 *===tdiff==============================================================*
13975 *
13976       DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ)
13977
13978 ************************************************************************
13979 * t-selection for single/double diffractive interactions.              *
13980 *          ECM      cm. energy                                         *
13981 *          TMIN     minimum momentum transfer to produce diff. masses  *
13982 *          XM1/XM2  diffractively produced masses                      *
13983 *                   (for single diffraction XM2 is obsolete)           *
13984 *          K1/K2= 0 not excited                                        *
13985 *               = 1 low-mass excitation                                *
13986 *               = 2 high-mass excitation                               *
13987 * This version dated 11.02.95 is written by S. Roesler                 *
13988 ************************************************************************
13989
13990       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13991       SAVE
13992       PARAMETER ( LINP = 10 ,
13993      &            LOUT = 6 ,
13994      &            LDAT = 9 )
13995       PARAMETER (ZERO=0.0D0)
13996
13997       PARAMETER ( BTP0   = 3.7D0,
13998      &            ALPHAP = 0.24D0 )
13999
14000       IREJ   = 0
14001       NCLOOP = 0
14002       DT_TDIFF  = ZERO
14003
14004       IF (K1.GT.0) THEN
14005          XM1 = XM1I
14006          XM2 = XM2I
14007       ELSE
14008          XM1 = XM2I
14009       ENDIF
14010       XDI = (XM1/ECM)**2
14011       IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN
14012 * slope for single diffraction
14013          SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI)
14014       ELSE
14015 * slope for double diffraction
14016          SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2)
14017       ENDIF
14018
14019     1 CONTINUE
14020       NCLOOP = NCLOOP+1
14021       IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999
14022       Y = DT_RNDM(XDI)
14023       T = -LOG(1.0D0-Y)/SLOPE
14024       IF (ABS(T).LE.ABS(TMIN)) GOTO 1
14025       DT_TDIFF = -ABS(T)
14026
14027       RETURN
14028
14029  9999 CONTINUE
14030       WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2
14031  1000 FORMAT(1X,'DT_TDIFF:   t-selection rejected!',/,
14032      &       1X,'ECM  = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ',
14033      &       E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2)
14034       IREJ = 1
14035       RETURN
14036       END
14037
14038 *$ CREATE DT_XVALHM.FOR
14039 *COPY DT_XVALHM
14040 *
14041 *===xvalhm=============================================================*
14042 *
14043       SUBROUTINE DT_XVALHM(KP,KT)
14044
14045 ************************************************************************
14046 * Sampling of parton x-values in high-mass diffractive interactions.   *
14047 * This version dated 12.02.95 is written by S. Roesler                 *
14048 ************************************************************************
14049
14050       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14051       SAVE
14052       PARAMETER ( LINP = 10 ,
14053      &            LOUT = 6 ,
14054      &            LDAT = 9 )
14055       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2)
14056
14057 * kinematics of diffractive interactions (DTUNUC 1.x)
14058       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14059      &                PPF(4),PTF(4),
14060      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14061      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14062 * various options for treatment of partons (DTUNUC 1.x)
14063 * (chain recombination, Cronin,..)
14064       LOGICAL LCO2CR,LINTPT
14065       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
14066      &                LCO2CR,LINTPT
14067
14068       DATA UNON,XVQTHR /2.0D0,0.8D0/
14069
14070       IF (KP.EQ.2) THEN
14071 * x-fractions of projectile valence partons
14072     1    CONTINUE
14073          XPH(1) = DT_DBETAR(OHALF,UNON)
14074          IF (XPH(1).GE.XVQTHR) GOTO 1
14075          XPH(2) = ONE-XPH(1)
14076 * x-fractions of Pomeron q-aq-pair
14077          XPOLO = TINY2
14078          XPOHI = ONE-TINY2
14079          XPPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14080          XPPO(2) = ONE-XPPO(1)
14081 * flavors of Pomeron q-aq-pair
14082          IFLAV    = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ))
14083          IFPPO(1) = IFLAV
14084          IFPPO(2) = -IFLAV
14085          IF (DT_RNDM(UNON).GT.OHALF) THEN
14086             IFPPO(1) = -IFLAV
14087             IFPPO(2) = IFLAV
14088          ENDIF
14089       ENDIF
14090
14091       IF (KT.EQ.2) THEN
14092 * x-fractions of projectile target partons
14093     2    CONTINUE
14094          XTH(1) = DT_DBETAR(OHALF,UNON)
14095          IF (XTH(1).GE.XVQTHR) GOTO 2
14096          XTH(2) = ONE-XTH(1)
14097 * x-fractions of Pomeron q-aq-pair
14098          XPOLO = TINY2
14099          XPOHI = ONE-TINY2
14100          XTPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14101          XTPO(2) = ONE-XTPO(1)
14102 * flavors of Pomeron q-aq-pair
14103          IFLAV    = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ))
14104          IFTPO(1) = IFLAV
14105          IFTPO(2) = -IFLAV
14106          IF (DT_RNDM(XPOLO).GT.OHALF) THEN
14107             IFTPO(1) = -IFLAV
14108             IFTPO(2) = IFLAV
14109          ENDIF
14110       ENDIF
14111
14112       RETURN
14113       END
14114
14115 *$ CREATE DT_LM2RES.FOR
14116 *COPY DT_LM2RES
14117 *
14118 *===lm2res=============================================================*
14119 *
14120       SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ)
14121
14122 ************************************************************************
14123 * Check low-mass diffractive excitation for resonance mass.            *
14124 *   (input)   IF1/2    PDG-indizes of valence partons                  *
14125 *   (in/out)  XM       diffractive mass requested/corrected            *
14126 *   (output)  IDR/IDXR id./BAMJET-index of resonance                   *
14127 * This version dated 12.02.95 is written by S. Roesler                 *
14128 ************************************************************************
14129
14130       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14131       SAVE
14132       PARAMETER ( LINP = 10 ,
14133      &            LOUT = 6 ,
14134      &            LDAT = 9 )
14135       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14136
14137 * kinematics of diffractive interactions (DTUNUC 1.x)
14138       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14139      &                PPF(4),PTF(4),
14140      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14141      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14142
14143       IREJ = 0
14144       IF1B = 0
14145       IF2B = 0
14146       XMI  = XM
14147
14148 * BAMJET indices of partons
14149       IF1A = IDT_IPDG2B(IF1,1,2)
14150       IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2)
14151       IF2A = IDT_IPDG2B(IF2,1,2)
14152       IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2)
14153
14154 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq)
14155       IDCH = 2
14156       IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1
14157
14158 * check for resonance mass
14159       CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1)
14160       IF (IREJ1.NE.0) GOTO 9999
14161
14162       XM = XMN
14163       RETURN
14164
14165  9999 CONTINUE
14166       IREJ = 1
14167       RETURN
14168       END
14169
14170 *$ CREATE DT_LMKINE.FOR
14171 *COPY DT_LMKINE
14172 *
14173 *===lmkine=============================================================*
14174 *
14175       SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ)
14176
14177 ************************************************************************
14178 * Kinematical treatment of low-mass excitations.                       *
14179 * This version dated 12.02.95 is written by S. Roesler                 *
14180 ************************************************************************
14181
14182       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14183       SAVE
14184       PARAMETER ( LINP = 10 ,
14185      &            LOUT = 6 ,
14186      &            LDAT = 9 )
14187       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14188
14189 * flags for input different options
14190       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14191       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14192      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14193 * kinematics of diffractive interactions (DTUNUC 1.x)
14194       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14195      &                PPF(4),PTF(4),
14196      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14197      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14198
14199       DIMENSION P1(4),P2(4)
14200
14201       IREJ = 0
14202
14203       IF (KP.EQ.1) THEN
14204          PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2)
14205          POE  = PPF(4)/PABS
14206          FAC1 = OHALF*(POE+ONE)
14207          FAC2 = -OHALF*(POE-ONE)
14208          DO 1 K=1,3
14209             PPLM1(K) = FAC1*PPF(K)
14210             PPLM2(K) = FAC2*PPF(K)
14211     1    CONTINUE
14212          PPLM1(4) = FAC1*PABS
14213          PPLM2(4) = -FAC2*PABS
14214          IF (IMSHL.EQ.1) THEN
14215             XM1 = PYMASS(IFP1)
14216             XM2 = PYMASS(IFP2)
14217             CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1)
14218             IF (IREJ1.NE.0) GOTO 9999
14219             DO 2 K=1,4
14220                PPLM1(K) = P1(K)
14221                PPLM2(K) = P2(K)
14222     2       CONTINUE
14223          ENDIF
14224       ENDIF
14225
14226       IF (KT.EQ.1) THEN
14227          PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2)
14228          POE  = PTF(4)/PABS
14229          FAC1 = OHALF*(POE+ONE)
14230          FAC2 = -OHALF*(POE-ONE)
14231          DO 3 K=1,3
14232             PTLM2(K) = FAC1*PTF(K)
14233             PTLM1(K) = FAC2*PTF(K)
14234     3    CONTINUE
14235          PTLM2(4) = FAC1*PABS
14236          PTLM1(4) = -FAC2*PABS
14237          IF (IMSHL.EQ.1) THEN
14238             XM1 = PYMASS(IFT1)
14239             XM2 = PYMASS(IFT2)
14240             CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1)
14241             IF (IREJ1.NE.0) GOTO 9999
14242             DO 4 K=1,4
14243                PTLM1(K) = P1(K)
14244                PTLM2(K) = P2(K)
14245     4       CONTINUE
14246          ENDIF
14247       ENDIF
14248
14249       RETURN
14250
14251  9999 CONTINUE
14252       WRITE(LOUT,'(A)') 'LMKINE:   kinematical treatment rejected'
14253       IREJ = 1
14254       RETURN
14255       END
14256
14257 *$ CREATE DT_DIFINI.FOR
14258 *COPY DT_DIFINI
14259 *
14260 *===difini=============================================================*
14261 *
14262       SUBROUTINE DT_DIFINI
14263
14264 ************************************************************************
14265 * Initialization of common /DTDIKI/                                    *
14266 * This version dated 12.02.95 is written by S. Roesler                 *
14267 ************************************************************************
14268
14269       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14270       SAVE
14271       PARAMETER ( LINP = 10 ,
14272      &            LOUT = 6 ,
14273      &            LDAT = 9 )
14274       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14275
14276 * kinematics of diffractive interactions (DTUNUC 1.x)
14277       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14278      &                PPF(4),PTF(4),
14279      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14280      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14281
14282       DO 1 K=1,4
14283          PPOM(K)  = ZERO
14284          PSC(K)   = ZERO
14285          PPF(K)   = ZERO
14286          PTF(K)   = ZERO
14287          PPLM1(K) = ZERO
14288          PPLM2(K) = ZERO
14289          PTLM1(K) = ZERO
14290          PTLM2(K) = ZERO
14291     1 CONTINUE
14292       DO 2 K=1,2
14293          XPH(K)   = ZERO
14294          XPPO(K)  = ZERO
14295          XTH(K)   = ZERO
14296          XTPO(K)  = ZERO
14297          IFPPO(K) = 0
14298          IFTPO(K) = 0
14299     2 CONTINUE
14300       IDPR  = 0
14301       IDXPR = 0
14302       IDTR  = 0
14303       IDXTR = 0
14304
14305       RETURN
14306       END
14307
14308 *$ CREATE DT_DIFPUT.FOR
14309 *COPY DT_DIFPUT
14310 *
14311 *===difput=============================================================*
14312 *
14313       SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,
14314      &                                                          IREJ)
14315
14316 ************************************************************************
14317 * Dump diffractive chains into DTEVT1                                  *
14318 * This version dated 12.02.95 is written by S. Roesler                 *
14319 ************************************************************************
14320
14321       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14322       SAVE
14323       PARAMETER ( LINP = 10 ,
14324      &            LOUT = 6 ,
14325      &            LDAT = 9 )
14326       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14327
14328       LOGICAL LCHK
14329
14330 * kinematics of diffractive interactions (DTUNUC 1.x)
14331       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14332      &                PPF(4),PTF(4),
14333      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14334      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14335 * event history
14336       PARAMETER (NMXHKK=200000)
14337       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14338      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14339      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14340 * extended event history
14341       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14342      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14343      &                IHIST(2,NMXHKK)
14344 * rejection counter
14345       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
14346      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
14347      &                IREXCI(3),IRDIFF(2),IRINC
14348
14349       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4),
14350      &          P1(4),P2(4),P3(4),P4(4)
14351
14352       IREJ = 0
14353
14354       IF (KP.EQ.1) THEN
14355          DO 1 K=1,4
14356             PCH(K) = PPLM1(K)+PPLM2(K)
14357     1    CONTINUE
14358          ID1 = IFP1
14359          ID2 = IFP2
14360          IF (DT_RNDM(PT).GT.OHALF) THEN
14361             ID1 = IFP2
14362             ID2 = IFP1
14363          ENDIF
14364          CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3),
14365      &                                        PPLM1(4),0,0,0)
14366          CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3),
14367      &                                        PPLM2(4),0,0,0)
14368          CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14369      &                                              IDPR,IDXPR,8)
14370       ELSEIF (KP.EQ.2) THEN
14371          DO 2 K=1,4
14372             PP1(K) = XPH(1)*PP(K)
14373             PP2(K) = XPH(2)*PP(K)
14374             PT1(K) = -XPPO(1)*PPOM(K)
14375             PT2(K) = -XPPO(2)*PPOM(K)
14376     2    CONTINUE
14377          CALL  DT_CHKCSY(IFP1,IFPPO(1),LCHK)
14378          XM1 = ZERO
14379          XM2 = ZERO
14380          IF (LCHK) THEN
14381             CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14382             IF (IREJ1.NE.0) GOTO 9999
14383             CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14384             IF (IREJ1.NE.0) GOTO 9999
14385             DO 3 K=1,4
14386                PP1(K) = P1(K)
14387                PT1(K) = P2(K)
14388                PP2(K) = P3(K)
14389                PT2(K) = P4(K)
14390     3       CONTINUE
14391             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14392      &                                                       0,0,8)
14393             CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14394      &                                             PT1(4),0,0,8)
14395             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14396      &                                                       0,0,8)
14397             CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14398      &                                             PT2(4),0,0,8)
14399          ELSE
14400             CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14401             IF (IREJ1.NE.0) GOTO 9999
14402             CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14403             IF (IREJ1.NE.0) GOTO 9999
14404             DO 4 K=1,4
14405                PP1(K) = P1(K)
14406                PT2(K) = P2(K)
14407                PP2(K) = P3(K)
14408                PT1(K) = P4(K)
14409     4       CONTINUE
14410             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
14411      &                                                       0,0,8)
14412             CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
14413      &                                                PT2(4),0,0,8)
14414             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
14415      &                                                       0,0,8)
14416             CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
14417      &                                                PT1(4),0,0,8)
14418          ENDIF
14419          NCSY = NCSY+1
14420       ELSE
14421          CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4),
14422      &                                                        0,0,0)
14423       ENDIF
14424
14425       IF (KT.EQ.1) THEN
14426          DO 5 K=1,4
14427             PCH(K) = PTLM1(K)+PTLM2(K)
14428     5    CONTINUE
14429          ID1 = IFT1
14430          ID2 = IFT2
14431          IF (DT_RNDM(PT).GT.OHALF) THEN
14432             ID1 = IFT2
14433             ID2 = IFT1
14434          ENDIF
14435          CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3),
14436      &                                              PTLM1(4),0,0,0)
14437          CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3),
14438      &                                              PTLM2(4),0,0,0)
14439          CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
14440      &                                              IDTR,IDXTR,8)
14441       ELSEIF (KT.EQ.2) THEN
14442          DO 6 K=1,4
14443             PP1(K) = XTPO(1)*PPOM(K)
14444             PP2(K) = XTPO(2)*PPOM(K)
14445             PT1(K) = XTH(2)*PT(K)
14446             PT2(K) = XTH(1)*PT(K)
14447     6    CONTINUE
14448          CALL  DT_CHKCSY(IFTPO(1),IFT1,LCHK)
14449          XM1 = ZERO
14450          XM2 = ZERO
14451          IF (LCHK) THEN
14452             CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
14453             IF (IREJ1.NE.0) GOTO 9999
14454             CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
14455             IF (IREJ1.NE.0) GOTO 9999
14456             DO 7 K=1,4
14457                PP1(K) = P1(K)
14458                PT1(K) = P2(K)
14459                PP2(K) = P3(K)
14460                PT2(K) = P4(K)
14461     7       CONTINUE
14462             CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14463      &                                                PP1(4),0,0,8)
14464             CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14465      &                                                       0,0,8)
14466             CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14467      &                                                PP2(4),0,0,8)
14468             CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14469      &                                                       0,0,8)
14470          ELSE
14471             CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
14472             IF (IREJ1.NE.0) GOTO 9999
14473             CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
14474             IF (IREJ1.NE.0) GOTO 9999
14475             DO 8 K=1,4
14476                PP1(K) = P1(K)
14477                PT2(K) = P2(K)
14478                PP2(K) = P3(K)
14479                PT1(K) = P4(K)
14480     8       CONTINUE
14481             CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
14482      &                                                PP1(4),0,0,8)
14483             CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
14484      &                                                       0,0,8)
14485             CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
14486      &                                                PP2(4),0,0,8)
14487             CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
14488      &                                                       0,0,8)
14489          ENDIF
14490          NCSY = NCSY+1
14491       ELSE
14492          CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4),
14493      &                                                        0,0,0)
14494       ENDIF
14495
14496       RETURN
14497
14498  9999 CONTINUE
14499       IRDIFF(2) = IRDIFF(2)+1
14500       IREJ      = 1
14501       RETURN
14502       END
14503
14504 *$ CREATE DT_EVTFRG.FOR
14505 *COPY DT_EVTFRG
14506 *
14507 *===evtfrg=============================================================*
14508 *
14509       SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ)
14510
14511 ************************************************************************
14512 * Hadronization of chains in DTEVT1.                                   *
14513 *                                                                      *
14514 * Input:                                                               *
14515 *   KMODE = 1   hadronization of PHOJET-chains (id=77xxx)              *
14516 *         = 2   hadronization of DTUNUC-chains (id=88xxx)              *
14517 *   NFRG  if KMODE = 1 : upper index of PHOJET-scatterings to be       *
14518 *                        hadronized with one PYEXEC call               *
14519 *         if KMODE = 2 : max. number of DTUNUC-chains to be hadronized *
14520 *                        with one PYEXEC call                          *
14521 * Output:                                                              *
14522 *   NPYMEM      number of entries in JETSET-common after hadronization *
14523 *   IREJ        rejection flag                                         *
14524 *                                                                      *
14525 * This version dated 17.09.00 is written by S. Roesler                 *
14526 ************************************************************************
14527
14528       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14529       SAVE
14530       PARAMETER ( LINP = 10 ,
14531      &            LOUT = 6 ,
14532      &            LDAT = 9 )
14533       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1)
14534       PARAMETER (ONE=1.0D0,ZERO=0.0D0)
14535
14536       LOGICAL LACCEP
14537
14538       PARAMETER (MXJOIN=200)
14539
14540 * event history
14541       PARAMETER (NMXHKK=200000)
14542       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14543      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14544      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14545 * extended event history
14546       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14547      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14548      &                IHIST(2,NMXHKK)
14549 * flags for input different options
14550       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14551       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14552      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14553 * statistics
14554       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
14555      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
14556      &                ICEVTG(8,0:30)
14557 * flags for diffractive interactions (DTUNUC 1.x)
14558       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
14559 * nucleon-nucleon event-generator
14560       CHARACTER*8 CMODEL
14561       LOGICAL LPHOIN
14562       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
14563 * phojet
14564 C  model switches and parameters
14565       CHARACTER*8 MDLNA
14566       INTEGER ISWMDL,IPAMDL
14567       DOUBLE PRECISION PARMDL
14568       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
14569 * jetset
14570       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14571       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
14572       PARAMETER (MAXLND=4000)
14573       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
14574       INTEGER PYK
14575       DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
14576       INTEGER PYCOMP
14577       MODE = KMODE
14578       ISTSTG = 7
14579       IF (MODE.NE.1) ISTSTG = 8
14580       IREJ = 0
14581
14582       IP     = 0
14583       ISH    = 0
14584       INIEMC = 1
14585       NEND   = NHKK
14586       NACCEP = 0
14587       IFRG   = 0
14588       IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
14589       DO 10 I=NPOINT(3),NEND
14590 * sr 14.02.00: seems to be not necessary anymore, commented
14591 C        LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
14592 C    &            ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
14593          LACCEP = .TRUE.
14594 * pick up chains from dtevt1
14595          IDCHK = IDHKK(I)/10000
14596          IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN
14597             IF (IDCHK.EQ.7) THEN
14598                IPJE = IDHKK(I)-IDCHK*10000
14599                IF (IPJE.NE.IFRG) THEN
14600                   IFRG = IPJE
14601                   IF (IFRG.GT.NFRG) GOTO 16
14602                ENDIF
14603             ELSE
14604                IPJE = 1
14605                IFRG = IFRG+1
14606                IF (IFRG.GT.NFRG) THEN
14607                   NFRG = -1
14608                   GOTO 16
14609                ENDIF
14610             ENDIF
14611 *   statistics counter
14612 c           IF (IDCH(I).LE.8)
14613 c    &         ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
14614 c           IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
14615 * special treatment for small chains already corrected to hadrons
14616             IF (IDRES(I).NE.0) THEN
14617                IF (IDRES(I).EQ.11) THEN
14618                   ID = IDXRES(I)
14619                ELSE
14620                   ID = IDT_IPDGHA(IDXRES(I))
14621                ENDIF
14622                IF (LEMCCK) THEN
14623                   CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
14624      &                              PHKK(4,I),INIEMC,IDUM,IDUM)
14625                   INIEMC = 2
14626                ENDIF
14627                IP = IP+1
14628                IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
14629                P(IP,1) = PHKK(1,I)
14630                P(IP,2) = PHKK(2,I)
14631                P(IP,3) = PHKK(3,I)
14632                P(IP,4) = PHKK(4,I)
14633                P(IP,5) = PHKK(5,I)
14634                K(IP,1) = 1
14635                K(IP,2) = ID
14636                K(IP,3) = 0
14637                K(IP,4) = 0
14638                K(IP,5) = 0
14639                IHIST(2,I) = 10000*IPJE+IP
14640                IF (IHIST(1,I).LE.-100) THEN
14641                   ISH = ISH+1
14642                   IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14643                   ISJOIN(ISH) = I
14644                ENDIF
14645                N = IP
14646                IHISMO(IP) = I
14647             ELSE
14648                IJ  = 0
14649                DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
14650                   IF (LEMCCK) THEN
14651                      CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK),
14652      &                                   PHKK(4,KK),INIEMC,IDUM,IDUM)
14653                      CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM)
14654                      INIEMC = 2
14655                   ENDIF
14656                   ID = IDHKK(KK)
14657                   IF (ID.EQ.0) ID = 21
14658 c                  PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
14659 c                  AM0  = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
14660 c                  AMRQ   = PYMASS(ID)
14661 c                  AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
14662 c                  IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
14663 c     &                (ABS(IDIFF).EQ.0)) THEN
14664 cC                    WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
14665 c                     DELTA      = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
14666 c                     PHKK(4,KK) = PHKK(4,KK)+DELTA
14667 c                     PTOT1      = PTOT-DELTA
14668 c                     PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
14669 c                     PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
14670 c                     PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
14671 c                     PHKK(5,KK) = AMRQ
14672 c                  ENDIF
14673                   IP = IP+1
14674                   IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
14675                   P(IP,1) = PHKK(1,KK)
14676                   P(IP,2) = PHKK(2,KK)
14677                   P(IP,3) = PHKK(3,KK)
14678                   P(IP,4) = PHKK(4,KK)
14679                   P(IP,5) = PHKK(5,KK)
14680                   K(IP,1) = 1
14681                   K(IP,2) = ID
14682                   K(IP,3) = 0
14683                   K(IP,4) = 0
14684                   K(IP,5) = 0
14685                   IHIST(2,KK) = 10000*IPJE+IP
14686                   IF (IHIST(1,KK).LE.-100) THEN
14687                      ISH = ISH+1
14688                      IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
14689                      ISJOIN(ISH) = KK
14690                   ENDIF
14691                   IJ = IJ+1
14692                   IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
14693                   IJOIN(IJ)  = IP
14694                   IHISMO(IP) = I
14695    11          CONTINUE
14696                N = IP
14697 * join the two-parton system
14698                CALL PYJOIN(IJ,IJOIN)
14699             ENDIF
14700             IDHKK(I) = 99999
14701          ENDIF
14702    10 CONTINUE
14703    16 CONTINUE
14704       N = IP
14705
14706       IF (IP.GT.0) THEN
14707
14708 * final state parton shower
14709          DO 136 NPJE=1,IPJE
14710             IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
14711                IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
14712                   DO 130 K1=1,ISH
14713                      IF (ISJOIN(K1).EQ.0) GOTO 130
14714                      I = ISJOIN(K1)
14715                      IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
14716      &                                                       GOTO 130
14717                      IH1 = IHIST(2,I)/10000
14718                      IF (IH1.NE.NPJE) GOTO 130
14719                      IH1 = IHIST(2,I)-IH1*10000
14720                      DO 135 K2=K1+1,ISH
14721                         IF (ISJOIN(K2).EQ.0) GOTO 135
14722                         II = ISJOIN(K2)
14723                         IH2 = IHIST(2,II)/10000
14724                         IF (IH2.NE.NPJE) GOTO 135
14725                         IH2 = IHIST(2,II)-IH2*10000
14726                         IF (IHIST(1,I).EQ.IHIST(1,II)) THEN
14727                            PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2)
14728                            PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2)
14729                            RQLUN = MIN(PT1,PT2)
14730                            CALL PYSHOW(IH1,IH2,RQLUN)
14731
14732                            ISJOIN(K1) = 0
14733                            ISJOIN(K2) = 0
14734                            GOTO 130
14735                         ENDIF
14736  135                 CONTINUE
14737  130              CONTINUE
14738                ENDIF
14739             ENDIF
14740  136     CONTINUE
14741
14742          CALL DT_INITJS(MODE)
14743 * hadronization
14744
14745          CALL PYEXEC
14746
14747          IF (MSTU(24).NE.0) THEN
14748             WRITE(LOUT,*) ' JETSET-reject at event',
14749      &                    NEVHKK,MSTU(24),KMODE
14750 C           CALL DT_EVTOUT(4)
14751
14752 C           CALL PYLIST(2)
14753
14754             GOTO 9999
14755          ENDIF
14756
14757 *   number of entries in LUJETS
14758
14759          NLINES = PYK(0,1)
14760
14761          NPYMEM = NLINES
14762
14763          DO 12 I=1,NLINES
14764             IFLG(I) = 0
14765    12    CONTINUE
14766
14767          DO 13 II=1,NLINES
14768
14769             IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
14770
14771 *  pick up mother resonance if possible and put it together with
14772 *  their decay-products into the common
14773                IDXMOR = K(II,3)
14774                IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
14775                   KFMOR = K(IDXMOR,2)
14776                   ISMOR = K(IDXMOR,1)
14777                ELSE
14778                   KFMOR = 91
14779                   ISMOR = 1
14780                ENDIF
14781                IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
14782      &             (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
14783                   ID = K(IDXMOR,2)
14784                   MO = IHISMO(PYK(IDXMOR,15))
14785                   PX = PYP(IDXMOR,1)
14786                   PY = PYP(IDXMOR,2)
14787                   PZ = PYP(IDXMOR,3)
14788                   PE = PYP(IDXMOR,4)
14789                   CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14790                   IFLG(IDXMOR) = 1
14791                   MO = NHKK
14792                   DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
14793                      IF (PYK(JDAUG,7).EQ.1) THEN
14794                         ID = PYK(JDAUG,8)
14795                         PX = PYP(JDAUG,1)
14796                         PY = PYP(JDAUG,2)
14797                         PZ = PYP(JDAUG,3)
14798                         PE = PYP(JDAUG,4)
14799                         CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14800                         IF (LEMCCK) THEN
14801                            PX = -PYP(JDAUG,1)
14802                            PY = -PYP(JDAUG,2)
14803                            PZ = -PYP(JDAUG,3)
14804                            PE = -PYP(JDAUG,4)
14805                            CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14806                         ENDIF
14807                         IFLG(JDAUG) = 1
14808                      ENDIF
14809    15             CONTINUE
14810                ELSE
14811 *  there was no mother resonance
14812                   MO = IHISMO(PYK(II,15))
14813                   ID = PYK(II,8)
14814                   PX = PYP(II,1)
14815                   PY = PYP(II,2)
14816                   PZ = PYP(II,3)
14817                   PE = PYP(II,4)
14818                   CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
14819                   IF (LEMCCK) THEN
14820                      PX = -PYP(II,1)
14821                      PY = -PYP(II,2)
14822                      PZ = -PYP(II,3)
14823                      PE = -PYP(II,4)
14824                      CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
14825                   ENDIF
14826                ENDIF
14827             ENDIF
14828    13    CONTINUE
14829          IF (LEMCCK) THEN
14830             CHKLEV = TINY1
14831             CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
14832 C           IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
14833          ENDIF
14834
14835 * global energy-momentum & flavor conservation check
14836 **sr 16.5. this check is skipped in case of phojet-treatment
14837          IF (MCGENE.EQ.1)
14838      &      CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
14839
14840 * update statistics-counter for diffraction
14841 c        IF (IFLAGD.NE.0) THEN
14842 c           ICDIFF(1) = ICDIFF(1)+1
14843 c           IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
14844 c           IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
14845 c           IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
14846 c           IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
14847 c        ENDIF
14848
14849       ENDIF
14850
14851       RETURN
14852
14853  9999 CONTINUE
14854       IREJ = 1
14855       RETURN
14856       END
14857
14858 *$ CREATE DT_DECAYS.FOR
14859 *COPY DT_DECAYS
14860 *
14861 *===decay==============================================================*
14862 *
14863       SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
14864
14865 ************************************************************************
14866 * Resonance-decay.                                                     *
14867 * This subroutine replaces DDECAY/DECHKK.                              *
14868 *             PIN(4)      4-momentum of resonance          (input)     *
14869 *             IDXIN       BAMJET-index of resonance        (input)     *
14870 *             POUT(20,4)  4-momenta of decay-products      (output)    *
14871 *             IDXOUT(20)  BAMJET-indices of decay-products (output)    *
14872 *             NSEC        number of secondaries            (output)    *
14873 * Adopted from the original version DECHKK.                            *
14874 * This version dated 09.01.95 is written by S. Roesler                 *
14875 ************************************************************************
14876
14877       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14878       SAVE
14879       PARAMETER ( LINP = 10 ,
14880      &            LOUT = 6 ,
14881      &            LDAT = 9 )
14882       PARAMETER (TINY17=1.0D-17)
14883
14884 * HADRIN: decay channel information
14885       PARAMETER (IDMAX9=602)
14886       CHARACTER*8 ZKNAME
14887       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
14888 * particle properties (BAMJET index convention)
14889       CHARACTER*8  ANAME
14890       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
14891      &                IICH(210),IIBAR(210),K1(210),K2(210)
14892 * flags for input different options
14893       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14894       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14895      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14896
14897       DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20),
14898      &          EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3),
14899      &          CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3)
14900
14901 * ISTAB = 1 strong and weak decays
14902 *       = 2 strong decays only
14903 *       = 3 strong decays, weak decays for charmed particles and tau
14904 *           leptons only
14905       DATA ISTAB /2/
14906
14907       IREJ = 0
14908       NSEC = 0
14909 * put initial resonance to stack
14910       NSTK = 1
14911       IDXSTK(NSTK) = IDXIN
14912       DO 5 I=1,4
14913          PI(NSTK,I) = PIN(I)
14914     5 CONTINUE
14915
14916 * store initial configuration for energy-momentum cons. check
14917       IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3),
14918      &                                   PI(NSTK,4),1,IDUM,IDUM)
14919
14920   100 CONTINUE
14921 * get particle from stack
14922       IDXI = IDXSTK(NSTK)
14923 * skip stable particles
14924       IF (ISTAB.EQ.1) THEN
14925          IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10
14926          IF ((IDXI.GE.  1).AND.(IDXI.LE.  7)) GOTO 10
14927       ELSEIF (ISTAB.EQ.2) THEN
14928          IF ((IDXI.GE.  1).AND.(IDXI.LE. 30)) GOTO 10
14929          IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
14930          IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10
14931          IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10
14932          IF ( IDXI.EQ.109)                    GOTO 10
14933          IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10
14934       ELSEIF (ISTAB.EQ.3) THEN
14935          IF ((IDXI.GE.  1).AND.(IDXI.LE. 23)) GOTO 10
14936          IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
14937          IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10
14938          IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10
14939       ENDIF
14940
14941 * calculate direction cosines and Lorentz-parameter of decaying part.
14942       PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2)
14943       PTOT = MAX(PTOT,TINY17)
14944       DO 1 I=1,3
14945          DCOS(I) = PI(NSTK,I)/PTOT
14946     1 CONTINUE
14947       GAM  = PI(NSTK,4)/AAM(IDXI)
14948       BGAM = PTOT/AAM(IDXI)
14949
14950 * get decay-channel
14951       KCHAN = K1(IDXI)-1
14952     2 CONTINUE
14953       KCHAN = KCHAN+1
14954       IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
14955
14956 * identities of secondaries
14957       IDX(1) = NZK(KCHAN,1)
14958       IDX(2) = NZK(KCHAN,2)
14959       IF (IDX(2).LT.1) GOTO 9999
14960       IDX(3) = NZK(KCHAN,3)
14961
14962 * handle decay in rest system of decaying particle
14963       IF (IDX(3).EQ.0) THEN
14964 *   two-particle decay
14965          NDEC = 2
14966          CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2),
14967      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
14968      &               AAM(IDX(1)),AAM(IDX(2)))
14969       ELSE
14970 *   three-particle decay
14971          NDEC = 3
14972          CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3),
14973      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
14974      &               CODF(3),COFF(3),SIFF(3),
14975      &               AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3)))
14976       ENDIF
14977       NSTK = NSTK-1
14978
14979 * transform decay products back
14980       DO 3 I=1,NDEC
14981          NSTK = NSTK+1
14982          CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3),
14983      &               CODF(I),COFF(I),SIFF(I),PF(I),EF(I),
14984      &               PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4))
14985 * add particle to stack
14986          IDXSTK(NSTK) = IDX(I)
14987          DO 4 J=1,3
14988             PI(NSTK,J) = DCOSF(J)*PFF(I)
14989     4    CONTINUE
14990     3 CONTINUE
14991       GOTO 100
14992
14993    10 CONTINUE
14994 * stable particle, put to output-arrays
14995       NSEC = NSEC+1
14996       DO 6 I=1,4
14997          POUT(NSEC,I) = PI(NSTK,I)
14998     6 CONTINUE
14999       IDXOUT(NSEC) = IDXSTK(NSTK)
15000 * store secondaries for energy-momentum conservation check
15001       IF (LEMCCK)
15002      &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
15003      &            -POUT(NSEC,4),2,IDUM,IDUM)
15004       NSTK = NSTK-1
15005       IF (NSTK.GT.0) GOTO 100
15006
15007 * check energy-momentum conservation
15008       IF (LEMCCK) THEN
15009          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
15010          IF (IREJ1.NE.0) GOTO 9999
15011       ENDIF
15012
15013       RETURN
15014
15015  9999 CONTINUE
15016       IREJ = 1
15017       RETURN
15018       END
15019
15020 *$ CREATE DT_DECAY1.FOR
15021 *COPY DT_DECAY1
15022 *
15023 *===decay1=============================================================*
15024 *
15025       SUBROUTINE DT_DECAY1
15026
15027 ************************************************************************
15028 * Decay of resonances stored in DTEVT1.                                *
15029 * This version dated 20.01.95 is written by S. Roesler                 *
15030 ************************************************************************
15031
15032       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15033       SAVE
15034       PARAMETER ( LINP = 10 ,
15035      &            LOUT = 6 ,
15036      &            LDAT = 9 )
15037
15038 * event history
15039       PARAMETER (NMXHKK=200000)
15040       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15041      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15042      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15043 * extended event history
15044       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15045      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15046      &                IHIST(2,NMXHKK)
15047
15048       DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
15049
15050       NEND = NHKK
15051 C     DO 1 I=NPOINT(5),NEND
15052       DO 1 I=NPOINT(4),NEND
15053          IF (ABS(ISTHKK(I)).EQ.1) THEN
15054             DO 2 K=1,4
15055                PIN(K) = PHKK(K,I)
15056     2       CONTINUE
15057             IDXIN = IDBAM(I)
15058             CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15059             IF (NSEC.GT.1) THEN
15060                DO 3 N=1,NSEC
15061                   IDHAD = IDT_IPDGHA(IDXOUT(N))
15062                   CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2),
15063      &                               POUT(N,3),POUT(N,4),0,0,0)
15064     3          CONTINUE
15065             ENDIF
15066          ENDIF
15067     1 CONTINUE
15068
15069       RETURN
15070       END
15071
15072 *$ CREATE DT_DECPI0.FOR
15073 *COPY DT_DECPI0
15074 *
15075 *===decpi0=============================================================*
15076 *
15077       SUBROUTINE DT_DECPI0
15078
15079 ************************************************************************
15080 * Decay of pi0 handled with JETSET.                                    *
15081 * This version dated 18.02.96 is written by S. Roesler                 *
15082 ************************************************************************
15083
15084       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15085       SAVE
15086       PARAMETER ( LINP = 10 ,
15087      &            LOUT = 6 ,
15088      &            LDAT = 9 )
15089       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0)
15090
15091 * event history
15092       PARAMETER (NMXHKK=200000)
15093       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15094      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15095      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15096 * extended event history
15097       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15098      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15099      &                IHIST(2,NMXHKK)
15100       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15101       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15102       PARAMETER (MAXLND=4000)
15103       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15104 * flags for input different options
15105       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15106       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15107      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15108
15109       INTEGER PYCOMP,PYK
15110
15111       DIMENSION IHISMO(NMXHKK),P1(4)
15112
15113       TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
15114
15115       CALL DT_INITJS(2)
15116 * allow pi0 decay
15117       KC = PYCOMP(111)
15118       MDCY(KC,1) = 1
15119
15120       NN  = 0
15121       INI = 0
15122       DO 1 I=1,NHKK
15123          IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
15124             IF (INI.EQ.0) THEN
15125                INI = 1
15126             ELSE
15127                INI = 2
15128             ENDIF
15129             IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15130      &                                    PHKK(4,I),INI,IDUM,IDUM)
15131             PT    = SQRT(PHKK(1,I)**2+PHKK(2,I)**2)
15132             PTOT  = SQRT(PT**2+PHKK(3,I)**2)
15133             COSTH = PHKK(3,I)/(PTOT+TINY10)
15134             IF (COSTH.GT.ONE) THEN
15135                THETA = ZERO
15136             ELSEIF (COSTH.LT.-ONE) THEN
15137                THETA = TWOPI/2.0D0
15138             ELSE
15139                THETA = ACOS(COSTH)
15140             ENDIF
15141             PHI     = ASIN(PHKK(2,I)/(PT  +TINY10))
15142             IF (PHKK(1,I).LT.0.0D0)
15143      &         PHI  = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
15144             ENER    = PHKK(4,I)
15145             NN      = NN+1
15146             KTEMP   = MSTU(10)
15147             MSTU(10)= 1
15148             P(NN,5) = PHKK(5,I)
15149             CALL PY1ENT(NN,111,ENER,THETA,PHI)
15150             MSTU(10)  = KTEMP
15151             IHISMO(NN)= I
15152          ENDIF
15153     1 CONTINUE
15154       IF (NN.GT.0) THEN
15155          CALL PYEXEC
15156          NLINES = PYK(0,1)
15157          DO 2 II=1,NLINES
15158             IF (PYK(II,7).EQ.1) THEN
15159                DO 3 KK=1,4
15160                   P1(KK) = PYP(II,KK)
15161     3          CONTINUE
15162                ID = PYK(II,8)
15163                MO = IHISMO(PYK(II,15))
15164                CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
15165                IF (LEMCCK)
15166      &            CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
15167      &                                            IDUM,IDUM)
15168 *sr: flag with neg. sign (for HELIOS p/A-W jobs)
15169                ISTHKK(MO) = -2
15170             ENDIF
15171     2    CONTINUE
15172          IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
15173       ENDIF
15174       MDCY(KC,1) = 0
15175
15176       RETURN
15177       END
15178
15179 *$ CREATE DT_DTWOPD.FOR
15180 *COPY DT_DTWOPD
15181 *
15182 *===dtwopd=============================================================*
15183 *
15184       SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
15185      &                                            COF2,SIF2,AM1,AM2)
15186
15187 ************************************************************************
15188 * Two-particle decay.                                                  *
15189 *  UMO                 cm-energy of the decaying system       (input)  *
15190 *  AM1/AM2             masses of the decay products           (input)  *
15191 *  ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) *
15192 *  COD,COF,SIF         direction cosines of the decay prod.   (output) *
15193 * Revised by S. Roesler, 20.11.95                                      *
15194 ************************************************************************
15195
15196       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15197       SAVE
15198       PARAMETER ( LINP = 10 ,
15199      &            LOUT = 6 ,
15200      &            LDAT = 9 )
15201       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
15202
15203       IF (UMO.LT.(AM1+AM2)) THEN
15204          WRITE(LOUT,1000) UMO,AM1,AM2
15205  1000    FORMAT(1X,'DTWOPD:    inconsistent kinematics - UMO,AM1,AM2 ',
15206      &          3E12.3)
15207          STOP
15208       ENDIF
15209
15210       ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
15211       ECM2 = UMO-ECM1
15212       PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
15213       PCM2 = PCM1
15214       CALL DT_DSFECF(SIF1,COF1)
15215       COD1 = TWO*DT_RNDM(PCM2)-ONE
15216       COD2 = -COD1
15217       COF2 = -COF1
15218       SIF2 = -SIF1
15219
15220       RETURN
15221       END
15222
15223 *$ CREATE DT_DTHREP.FOR
15224 *COPY DT_DTHREP
15225 *
15226 *===dthrep=============================================================*
15227 *
15228       SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
15229      &                  SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
15230
15231 ************************************************************************
15232 * Three-particle decay.                                                *
15233 *  UMO                 cm-energy of the decaying system       (input)  *
15234 *  AM1/2/3             masses of the decay products           (input)  *
15235 *  ECM1/2/2,PCM1/2/3   cm-energies/momenta of the decay prod. (output) *
15236 *  COD,COF,SIF         direction cosines of the decay prod.   (output) *
15237 *                                                                      *
15238 * Threpd89: slight revision by A. Ferrari                              *
15239 * Last change on   11-oct-93   by    Alfredo Ferrari, INFN - Milan     *
15240 * Revised by S. Roesler, 20.11.95                                      *
15241 ************************************************************************
15242
15243       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15244       SAVE
15245       PARAMETER ( LINP = 10 ,
15246      &            LOUT = 6 ,
15247      &            LDAT = 9 )
15248
15249       PARAMETER ( ANGLSQ = 2.5D-31 )
15250       PARAMETER ( AZRZRZ = 1.0D-30 )
15251       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
15252       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
15253       PARAMETER ( ONEONE = 1.D+00 )
15254       PARAMETER ( TWOTWO = 2.D+00 )
15255       PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
15256
15257       COMMON /HNGAMR/ REDU,AMO,AMM(15)
15258 * flags for input different options
15259       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15260       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15261      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15262
15263       DIMENSION F(5),XX(5)
15264       DATA EPS /AZRZRZ/
15265
15266       UMOO=UMO+UMO
15267 C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
15268 C***J. VON NEUMANN - RANDOM - SELECTION OF S2
15269 C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
15270       UUMO=UMO
15271       AAM1=AM1
15272       AAM2=AM2
15273       AAM3=AM3
15274       GU=(AM2+AM3)**2
15275       GO=(UMO-AM1)**2
15276 *     UFAK=1.0000000000001D0
15277 *     IF (GU.GT.GO) UFAK=0.9999999999999D0
15278       IF (GU.GT.GO) THEN
15279          UFAK=ONEMNS
15280       ELSE
15281          UFAK=ONEPLS
15282       END IF
15283       OFAK=2.D0-UFAK
15284       GU=GU*UFAK
15285       GO=GO*OFAK
15286       DS2=(GO-GU)/99.D0
15287       AM11=AM1*AM1
15288       AM22=AM2*AM2
15289       AM33=AM3*AM3
15290       UMO2=UMO*UMO
15291       RHO2=0.D0
15292       S22=GU
15293       DO 124 I=1,100
15294          S21=S22
15295          S22=GU+(I-1.D0)*DS2
15296          RHO1=RHO2
15297          RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
15298      *                                             (S22+EPS)
15299          IF(RHO2.LT.RHO1) GO TO 125
15300   124 CONTINUE
15301   125 S2SUP=(S22-S21)*.5D0+S21
15302       SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
15303      *                                           (S2SUP+EPS)
15304       SUPRHO=SUPRHO*1.05D0
15305       XO=S21-DS2
15306       IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
15307       IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
15308       XX(1)=XO
15309       XX(3)=S22
15310       X1=(XO+S22)*0.5D0
15311       XX(2)=X1
15312       F(3)=RHO2
15313       F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS)
15314       F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS)
15315       DO 126 I=1,16
15316          X4=(XX(1)+XX(2))*0.5D0
15317          X5=(XX(2)+XX(3))*0.5D0
15318          F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/
15319      *                                               (X4+EPS)
15320          F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
15321      *                                               (X5+EPS)
15322          XX(4)=X4
15323          XX(5)=X5
15324          DO 128 II=1,5
15325             IA=II
15326             DO 128 III=IA,5
15327                IF (F (II).GE.F (III)) GO TO 128
15328                FH=F(II)
15329                F(II)=F(III)
15330                F(III)=FH
15331                FH=XX(II)
15332                XX(II)=XX(III)
15333                XX(III)=FH
15334 128      CONTINUE
15335          SUPRHO=F(1)
15336          S2SUP=XX(1)
15337          DO 129 II=1,3
15338             IA=II
15339             DO 129 III=IA,3
15340                IF (XX(II).GE.XX(III)) GO TO 129
15341                FH=F(II)
15342                F(II)=F(III)
15343                F(III)=FH
15344                FH=XX(II)
15345                XX(II)=XX(III)
15346                XX(III)=FH
15347 129      CONTINUE
15348 126   CONTINUE
15349       AM23=(AM2+AM3)**2
15350       ITH=0
15351       REDU=2.D0
15352     1 CONTINUE
15353       ITH=ITH+1
15354       IF (ITH.GT.200) REDU=-9.D0
15355       IF (ITH.GT.200) GO TO 400
15356       C=DT_RNDM(REDU)
15357 *     S2=AM23+C*((UMO-AM1)**2-AM23)
15358       S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
15359       Y=DT_RNDM(S2)
15360       Y=Y*SUPRHO
15361       RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
15362       IF(Y.GT.RHO) GO TO 1
15363 C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
15364       S1=DT_RNDM(S2)
15365       S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
15366      &RHO*.5D0
15367       S3=UMO2+AM11+AM22+AM33-S1-S2
15368       ECM1=(UMO2+AM11-S2)/UMOO
15369       ECM2=(UMO2+AM22-S3)/UMOO
15370       ECM3=(UMO2+AM33-S1)/UMOO
15371       PCM1=SQRT((ECM1+AM1)*(ECM1-AM1))
15372       PCM2=SQRT((ECM2+AM2)*(ECM2-AM2))
15373       PCM3=SQRT((ECM3+AM3)*(ECM3-AM3))
15374       CALL DT_DSFECF(SFE,CFE)
15375 C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
15376 C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
15377       PCM12 = PCM1 * PCM2
15378       IF ( PCM12 .LT. ANGLSQ ) GO TO 200
15379       COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12
15380       GO TO 300
15381  200  CONTINUE
15382          UW=DT_RNDM(S1)
15383          COSTH=(UW-0.5D+00)*2.D+00
15384  300  CONTINUE
15385 *     IF(ABS(COSTH).GT.0.9999999999999999D0)
15386 *    &COSTH=SIGN(0.9999999999999999D0,COSTH)
15387       IF(ABS(COSTH).GT.ONEONE)
15388      &COSTH=SIGN(ONEONE,COSTH)
15389       IF (REDU.LT.1.D+00) RETURN
15390       COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3)
15391 *     IF(ABS(COSTH2).GT.0.9999999999999999D0)
15392 *    &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
15393       IF(ABS(COSTH2).GT.ONEONE)
15394      &COSTH2=SIGN(ONEONE,COSTH2)
15395       SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2))
15396       SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH))
15397       SINTH1=COSTH2*SINTH-COSTH*SINTH2
15398       COSTH1=COSTH*COSTH2+SINTH2*SINTH
15399 C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
15400 C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
15401 C***THE DIRECTION OF PARTICLE 3
15402 C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
15403       CX11=-COSTH1
15404       CY11=SINTH1*CFE
15405       CZ11=SINTH1*SFE
15406       CX22=-COSTH2
15407       CY22=-SINTH2*CFE
15408       CZ22=-SINTH2*SFE
15409       CALL DT_DSFECF(SIF3,COF3)
15410       COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
15411       SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
15412     2 FORMAT(5F20.15)
15413       COD1=CX11*COD3+CZ11*SID3
15414       CHLP=(ONEONE-COD1)*(ONEONE+COD1)
15415       IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3,
15416      &CX11,CZ11
15417       SID1=SQRT(CHLP)
15418       COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1
15419       SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1
15420       COD2=CX22*COD3+CZ22*SID3
15421       SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2))
15422       COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2
15423       SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2
15424  400  CONTINUE
15425 * === Energy conservation check: === *
15426       EOCHCK = UMO - ECM1 - ECM2 - ECM3
15427 *     SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
15428 *     SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
15429 *     SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
15430       PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3
15431       PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2
15432      &       + PCM3 * COF3 * SID3
15433       PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2
15434      &       + PCM3 * SIF3 * SID3
15435       EOCMPR = 1.D-12 * UMO
15436       IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK)
15437      &     .GT. EOCMPR ) THEN
15438 **sr 5.5.95 output-unit changed
15439          IF (IOULEV(1).GT.0) THEN
15440             WRITE(LOUT,*)
15441      &      ' *** Threpd: energy/momentum conservation failure! ***',
15442      &      EOCHCK,PXCHCK,PYCHCK,PZCHCK
15443             WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
15444          ENDIF
15445 **
15446       END IF
15447       RETURN
15448       END
15449
15450 *$ CREATE DT_DBKLAS.FOR
15451 *COPY DT_DBKLAS
15452 *
15453 *===dbklas=============================================================*
15454 *
15455       SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
15456
15457       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15458       SAVE
15459       PARAMETER ( LINP = 10 ,
15460      &            LOUT = 6 ,
15461      &            LDAT = 9 )
15462
15463 * quark-content to particle index conversion (DTUNUC 1.x)
15464       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15465      &                IA08(6,21),IA10(6,21)
15466
15467       IF (I) 20,20,10
15468 * baryons
15469    10 CONTINUE
15470       CALL DT_INDEXD(J,K,IND)
15471       I8  = IB08(I,IND)
15472       I10 = IB10(I,IND)
15473       IF (I8.LE.0) I8 = I10
15474       RETURN
15475 * antibaryons
15476    20 CONTINUE
15477       II = IABS(I)
15478       JJ = IABS(J)
15479       KK = IABS(K)
15480       CALL DT_INDEXD(JJ,KK,IND)
15481       I8  = IA08(II,IND)
15482       I10 = IA10(II,IND)
15483       IF (I8.LE.0) I8 = I10
15484
15485       RETURN
15486       END
15487
15488 *$ CREATE DT_INDEXD.FOR
15489 *COPY DT_INDEXD
15490 *
15491 *===indexd=============================================================*
15492 *
15493       SUBROUTINE DT_INDEXD(KA,KB,IND)
15494
15495       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15496       SAVE
15497       PARAMETER ( LINP = 10 ,
15498      &            LOUT = 6 ,
15499      &            LDAT = 9 )
15500
15501       KP = KA*KB
15502       KS = KA+KB
15503       IF (KP.EQ.1) IND=1
15504       IF (KP.EQ.2) IND=2
15505       IF (KP.EQ.3) IND=3
15506       IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
15507       IF (KP.EQ.5) IND=5
15508       IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6
15509       IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7
15510       IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8
15511       IF (KP.EQ.8)  IND=9
15512       IF (KP.EQ.10) IND=10
15513       IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11
15514       IF (KP.EQ.9)  IND=12
15515       IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13
15516       IF (KP.EQ.15) IND=14
15517       IF (KP.EQ.18) IND=15
15518       IF (KP.EQ.16) IND=16
15519       IF (KP.EQ.20) IND=17
15520       IF (KP.EQ.24) IND=18
15521       IF (KP.EQ.25) IND=19
15522       IF (KP.EQ.30) IND=20
15523       IF (KP.EQ.36) IND=21
15524
15525       RETURN
15526       END
15527
15528 *$ CREATE DT_DCHANT.FOR
15529 *COPY DT_DCHANT
15530 *
15531 *===dchant=============================================================*
15532 *
15533       SUBROUTINE DT_DCHANT
15534
15535       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15536       SAVE
15537       PARAMETER ( LINP = 10 ,
15538      &            LOUT = 6 ,
15539      &            LDAT = 9 )
15540       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15541
15542 * HADRIN: decay channel information
15543       PARAMETER (IDMAX9=602)
15544       CHARACTER*8 ZKNAME
15545       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15546 * particle properties (BAMJET index convention)
15547       CHARACTER*8  ANAME
15548       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15549      &                IICH(210),IIBAR(210),K1(210),K2(210)
15550
15551       DIMENSION HWT(IDMAX9)
15552
15553 * change of weights wt from absolut values into the sum of wt of a dec.
15554       DO 10 J=1,IDMAX9
15555          HWT(J) = ZERO
15556    10 CONTINUE
15557 C     DO 999 KKK=1,210
15558 C        WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
15559 C    &      ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
15560 C    &      K1(KKK),K2(KKK)
15561 C 999 CONTINUE
15562 C     STOP
15563       DO 30 I=1,210
15564          IK1 = K1(I)
15565          IK2 = K2(I)
15566          HV  = ZERO
15567          DO 20 J=IK1,IK2
15568             HV     = HV+WT(J)
15569             HWT(J) = HV
15570 **sr 13.1.95
15571             IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1
15572  1000       FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
15573    20    CONTINUE
15574    30 CONTINUE
15575       DO 40 J=1,IDMAX9
15576          WT(J) = HWT(J)
15577    40 CONTINUE
15578
15579       RETURN
15580       END
15581
15582 *$ CREATE DT_DDATAR.FOR
15583 *COPY DT_DDATAR
15584 *
15585 *===ddatar=============================================================*
15586 *
15587       SUBROUTINE DT_DDATAR
15588
15589       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15590       SAVE
15591       PARAMETER ( LINP = 10 ,
15592      &            LOUT = 6 ,
15593      &            LDAT = 9 )
15594       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15595
15596 * quark-content to particle index conversion (DTUNUC 1.x)
15597       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
15598      &                IA08(6,21),IA10(6,21)
15599
15600       DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
15601
15602       DATA IV/ 33, 34, 38,123,  0,  0, 32, 33, 39,124,
15603      &          0,  0, 36, 37, 96,127,  0,  0,126,125,
15604      &        128,129,14*0/
15605       DATA IP/ 23, 14, 16,116,  0,  0, 13, 23, 25,117,
15606      &          0,  0, 15, 24, 31,120,  0,  0,119,118,
15607      &        121,122,14*0/
15608       DATA IB/  0,  1, 21,140,  0,  0,  8, 22,137,  0,
15609      &          0, 97,138,  0,  0,146,  0,  0,  0,  0,
15610      &          0,  1,  8, 22,137,  0,  0,  0, 20,142,
15611      &          0,  0, 98,139,  0,  0,147,  0,  0,  0,
15612      &          0,  0, 21, 22, 97,138,  0,  0, 20, 98,
15613      &        139,  0,  0,  0,145,  0,  0,148,  0,  0,
15614      &          0,  0,  0,140,137,138,146,  0,  0,142,
15615      &        139,147,  0,  0,145,148,           50*0/
15616       DATA IBB/53, 54,104,161,  0,  0, 55,105,162,  0,
15617      &          0,107,164,  0,  0,167,  0,  0,  0,  0,
15618      &          0, 54, 55,105,162,  0,  0, 56,106,163,
15619      &          0,  0,108,165,  0,  0,168,  0,  0,  0,
15620      &          0,  0,104,105,107,164,  0,  0,106,108,
15621      &        165,  0,  0,109,166,  0,  0,169,  0,  0,
15622      &          0,  0,  0,161,162,164,167,  0,  0,163,
15623      &        165,168,  0,  0,166,169,  0,  0,170,47*0/
15624       DATA IA/  0,  2, 99,152,  0,  0,  9,100,149,  0,
15625      &          0,102,150,  0,  0,158,  0,  0,  0,  0,
15626      &          0,  2,  9,100,149,  0,  0,  0,101,154,
15627      &          0,  0,103,151,  0,  0,159,  0,  0,  0,
15628      &          0,  0, 99,100,102,150,  0,  0,101,103,
15629      &        151,  0,  0,  0,157,  0,  0,160,  0,  0,
15630      &          0,  0,  0,152,149,150,158,  0,  0,154,
15631      &        151,159,  0,  0,157,160,           50*0/
15632       DATA IAA/67, 68,110,171,  0,  0, 69,111,172,  0,
15633      &          0,113,174,  0,  0,177,  0,  0,  0,  0,
15634      &          0, 68, 69,111,172,  0,  0, 70,112,173,
15635      &          0,  0,114,175,  0,  0,178,  0,  0,  0,
15636      &          0,  0,110,111,113,174,  0,  0,112,114,
15637      &        175,  0,  0,115,176,  0,  0,179,  0,  0,
15638      &          0,  0,  0,171,172,174,177,  0,  0,173,
15639      &        175,178,  0,  0,176,179,  0,  0,180,47*0/
15640
15641       L=0
15642       DO 2 I=1,6
15643          DO 1 J=1,6
15644             L = L+1
15645             IMPS(I,J) = IP(L)
15646             IMVE(I,J) = IV(L)
15647     1    CONTINUE
15648     2 CONTINUE
15649       L=0
15650       DO 4 I=1,6
15651          DO 3 J=1,21
15652             L = L+1
15653             IB08(I,J) = IB(L)
15654             IB10(I,J) = IBB(L)
15655             IA08(I,J) = IA(L)
15656             IA10(I,J) = IAA(L)
15657     3    CONTINUE
15658     4 CONTINUE
15659 C     A1  = 0.88D0
15660 C     B1  = 3.0D0
15661 C     B2  = 3.0D0
15662 C     B3  = 8.0D0
15663 C     LT  = 0
15664 C     LB  = 0
15665 C     BET = 12.0D0
15666 C     AS  = 0.25D0
15667 C     B8  = 0.33D0
15668 C     AME = 0.95D0
15669 C     DIQ = 0.375D0
15670 C     ISU = 4
15671
15672       RETURN
15673       END
15674
15675 *$ CREATE DT_INITJS.FOR
15676 *COPY DT_INITJS
15677 *
15678 *===initjs=============================================================*
15679 *
15680       SUBROUTINE DT_INITJS(MODE)
15681
15682 ************************************************************************
15683 * Initialize JETSET paramters.                                         *
15684 *           MODE = 0 default settings                                  *
15685 *                = 1 PHOJET settings                                   *
15686 *                = 2 DTUNUC settings                                   *
15687 * This version dated 16.02.96 is written by S. Roesler                 *
15688 *                                                                      *
15689 * Last change 27.12.2006 by S. Roesler.                                *
15690 ************************************************************************
15691
15692       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15693       SAVE
15694       PARAMETER ( LINP = 10 ,
15695      &            LOUT = 6 ,
15696      &            LDAT = 9 )
15697       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
15698
15699       LOGICAL LFIRST,LFIRDT,LFIRPH
15700
15701       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15702       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15703       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15704 * flags for particle decays
15705       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
15706      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
15707      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
15708 * flags for input different options
15709       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15710       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15711      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15712
15713       INTEGER PYCOMP
15714
15715       DIMENSION IDXSTA(40)
15716       DATA IDXSTA
15717 *          K0s   pi0  lam   alam  sig+  asig+ sig-  asig- tet0  atet0
15718      &  /  310,  111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322,
15719 *          tet- atet-  om-  aom-   D+    D-    D0    aD0   Ds+   aDs+
15720      &    3312,-3312, 3334,-3334,  411, -411,  421, -421,  431, -431,
15721 *          etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+
15722      &     441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232,
15723 *         Ksic0 aKsic+aKsic0 sig0 asig0
15724      &    4132,-4232,-4132, 3212,-3212, 5*0/
15725
15726       DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
15727
15728       IF (LFIRST) THEN
15729 * save default settings
15730          PDEF1  = PARJ(1)
15731          PDEF2  = PARJ(2)
15732          PDEF3  = PARJ(3)
15733          PDEF5  = PARJ(5)
15734          PDEF6  = PARJ(6)
15735          PDEF7  = PARJ(7)
15736          PDEF18 = PARJ(18)
15737          PDEF19 = PARJ(19)
15738          PDEF21 = PARJ(21)
15739          PDEF42 = PARJ(42)
15740          MDEF12 = MSTJ(12)
15741 * LUJETS / PYJETS array-dimensions
15742          MSTU(4) = 4000
15743 * increase maximum number of JETSET-error prints
15744          MSTU(22) = 50000
15745 * prevent particles decaying
15746          DO 1 I=1,35
15747             IF (I.LT.34) THEN
15748                KC = PYCOMP(IDXSTA(I))
15749                IF (KC.GT.0) THEN
15750                   IF (I.EQ.2) THEN
15751 *  pi0 decay
15752 C                    MDCY(KC,1) = 1
15753                      MDCY(KC,1) = 0
15754 **cr mode
15755 C                 ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
15756 C   &                    (I.EQ.8).OR.(I.EQ.10)) THEN
15757 C                 ELSEIF (I.EQ.4) THEN
15758 C                    MDCY(KC,1) = 1
15759 **
15760                   ELSE
15761 C AM                     MDCY(KC,1) = 0
15762                   ENDIF
15763                ENDIF
15764             ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
15765                KC = PYCOMP(IDXSTA(I))
15766                IF (KC.GT.0) THEN
15767 C AM                 MDCY(KC,1) = 0
15768                ENDIF
15769             ENDIF
15770     1    CONTINUE
15771 *
15772 *
15773 * popcorn:
15774          IF (PDB.LE.ZERO) THEN
15775 *   no popcorn-mechanism
15776             MSTJ(12) = 1
15777          ELSE
15778             MSTJ(12) = 3
15779             PARJ(5)  = PDB
15780          ENDIF
15781 * set JETSET-parameter requested by input cards
15782          IF (NMSTU.GT.0) THEN
15783             DO 2 I=1,NMSTU
15784                MSTU(IMSTU(I)) = MSTUX(I)
15785     2       CONTINUE
15786          ENDIF
15787          IF (NMSTJ.GT.0) THEN
15788             DO 3 I=1,NMSTJ
15789                MSTJ(IMSTJ(I)) = MSTJX(I)
15790     3       CONTINUE
15791          ENDIF
15792          IF (NPARU.GT.0) THEN
15793             DO 4 I=1,NPARU
15794                PARU(IPARU(I)) = PARUX(I)
15795     4       CONTINUE
15796          ENDIF
15797          LFIRST = .FALSE.
15798       ENDIF
15799 *
15800 * PARJ(1)  suppression of qq-aqaq pair prod. compared to
15801 *          q-aq pair prod.                      (default: 0.1)
15802 * PARJ(2)  strangeness suppression               (default: 0.3)
15803 * PARJ(3)  extra suppression of strange diquarks (default: 0.4)
15804 * PARJ(6)  extra suppression of sas-pair shared by B and
15805 *          aB in BMaB                           (default: 0.5)
15806 * PARJ(7)  extra suppression of strange meson M in BMaB
15807 *          configuration                        (default: 0.5)
15808 * PARJ(18) spin 3/2 baryon suppression           (default: 1.0)
15809 * PARJ(21) width sigma in Gaussian p_x, p_y transverse
15810 *          momentum distrib. for prim. hadrons  (default: 0.35)
15811 * PARJ(42) b-parameter for symmetric Lund-fragmentation
15812 *          function                             (default: 0.9 GeV^-2)
15813 *
15814 * PHOJET settings
15815       IF (MODE.EQ.1) THEN
15816 *   JETSET default
15817 C        PARJ(1)  = PDEF1
15818 C        PARJ(2)  = PDEF2
15819 C        PARJ(3)  = PDEF3
15820 C        PARJ(6)  = PDEF6
15821 C        PARJ(7)  = PDEF7
15822 C        PARJ(18) = PDEF18
15823 C        PARJ(21) = PDEF21
15824 C        PARJ(42) = PDEF42
15825 **sr 18.11.98 parameter tuning
15826 C        PARJ(1)  = 0.092D0
15827 C        PARJ(2)  = 0.25D0
15828 C        PARJ(3)  = 0.45D0
15829 C        PARJ(19) = 0.3D0
15830 C        PARJ(21) = 0.45D0
15831 C        PARJ(42) = 1.0D0
15832 **sr 28.04.99 parameter tuning (May 99 minor modifications)
15833          PARJ(1)  = 0.085D0
15834          PARJ(2)  = 0.26D0
15835          PARJ(3)  = 0.8D0
15836          PARJ(11) = 0.38D0
15837          PARJ(18) = 0.3D0
15838          PARJ(19) = 0.4D0
15839          PARJ(21) = 0.36D0
15840          PARJ(41) = 0.3D0
15841          PARJ(42) = 0.86D0
15842          IF (NPARJ.GT.0) THEN
15843             DO 10 I=1,NPARJ
15844                IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
15845    10       CONTINUE
15846          ENDIF
15847          IF (LFIRPH) THEN
15848             WRITE(LOUT,'(1X,A)')
15849      &         'DT_INITJS: JETSET-parameter for PHOJET'
15850             CALL DT_JSPARA(0)
15851             LFIRPH = .FALSE.
15852          ENDIF
15853 * DTUNUC settings
15854       ELSEIF (MODE.EQ.2) THEN
15855          IF (IFRAG(2).EQ.1) THEN
15856 **sr parameters before 9.3.96
15857 C           PARJ(2)  = 0.27D0
15858 C           PARJ(3)  = 0.6D0
15859 C           PARJ(6)  = 0.75D0
15860 C           PARJ(7)  = 0.75D0
15861 C           PARJ(21) = 0.55D0
15862 C           PARJ(42) = 1.3D0
15863 **sr 18.11.98 parameter tuning
15864 C           PARJ(1)  = 0.05D0
15865 C           PARJ(2)  = 0.27D0
15866 C           PARJ(3)  = 0.4D0
15867 C           PARJ(19) = 0.2D0
15868 C           PARJ(21) = 0.45D0
15869 C           PARJ(42) = 1.0D0
15870 **sr 28.04.99 parameter tuning
15871             PARJ(1)  = 0.11D0
15872             PARJ(2)  = 0.36D0
15873             PARJ(3)  = 0.8D0
15874             PARJ(19) = 0.2D0
15875             PARJ(21) = 0.3D0
15876             PARJ(41) = 0.3D0
15877             PARJ(42) = 0.58D0
15878             IF (NPARJ.GT.0) THEN
15879                DO 20 I=1,NPARJ
15880                   IF (IPARJ(I).LT.0) THEN
15881                      IDX = ABS(IPARJ(I))
15882                      PARJ(IDX) = PARJX(I)
15883                   ENDIF
15884    20          CONTINUE
15885             ENDIF
15886             IF (LFIRDT) THEN
15887                WRITE(LOUT,'(1X,A)')
15888      &           'DT_INITJS: JETSET-parameter for DTUNUC'
15889                CALL DT_JSPARA(0)
15890                LFIRDT = .FALSE.
15891             ENDIF
15892          ELSEIF (IFRAG(2).EQ.2) THEN
15893             PARJ(1)  = 0.11D0
15894             PARJ(2)  = 0.27D0
15895             PARJ(3)  = 0.3D0
15896             PARJ(6)  = 0.35D0
15897             PARJ(7)  = 0.45D0
15898             PARJ(18) = 0.66D0
15899 C           PARJ(21) = 0.55D0
15900 C           PARJ(42) = 1.0D0
15901             PARJ(21) = 0.60D0
15902             PARJ(42) = 1.3D0
15903          ELSE
15904             PARJ(1)  = PDEF1
15905             PARJ(2)  = PDEF2
15906             PARJ(3)  = PDEF3
15907             PARJ(6)  = PDEF6
15908             PARJ(7)  = PDEF7
15909             PARJ(18) = PDEF18
15910             PARJ(21) = PDEF21
15911             PARJ(42) = PDEF42
15912          ENDIF
15913       ELSE
15914          PARJ(1)  = PDEF1
15915          PARJ(2)  = PDEF2
15916          PARJ(3)  = PDEF3
15917          PARJ(5)  = PDEF5
15918          PARJ(6)  = PDEF6
15919          PARJ(7)  = PDEF7
15920          PARJ(18) = PDEF18
15921          PARJ(19) = PDEF19
15922          PARJ(21) = PDEF21
15923          PARJ(42) = PDEF42
15924          MSTJ(12) = MDEF12
15925       ENDIF
15926
15927       RETURN
15928       END
15929
15930 *$ CREATE DT_JSPARA.FOR
15931 *COPY DT_JSPARA
15932 *
15933 *===jspara=============================================================*
15934 *
15935       SUBROUTINE DT_JSPARA(MODE)
15936
15937       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15938       SAVE
15939       PARAMETER ( LINP = 10 ,
15940      &            LOUT = 6 ,
15941      &            LDAT = 9 )
15942       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
15943      &           ONE=1.0D0,ZERO=0.0D0)
15944
15945       LOGICAL LFIRST
15946
15947       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15948
15949       DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
15950
15951       DATA LFIRST /.TRUE./
15952
15953 * save the default JETSET-parameter on the first call
15954       IF (LFIRST) THEN
15955          DO 1 I=1,200
15956             ISTU(I) = MSTU(I)
15957             QARU(I) = PARU(I)
15958             ISTJ(I) = MSTJ(I)
15959             QARJ(I) = PARJ(I)
15960     1    CONTINUE
15961          LFIRST = .FALSE.
15962       ENDIF
15963
15964       WRITE(LOUT,1000)
15965  1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
15966
15967 * compare the default JETSET-parameter with the present values
15968       DO 2 I=1,200
15969          IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
15970             WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
15971 C           ISTU(I) = MSTU(I)
15972          ENDIF
15973          DIFF = ABS(PARU(I)-QARU(I))
15974          IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
15975             WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
15976 C           QARU(I) = PARU(I)
15977          ENDIF
15978          IF (MSTJ(I).NE.ISTJ(I)) THEN
15979             WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
15980 C           ISTJ(I) = MSTJ(I)
15981          ENDIF
15982          DIFF = ABS(PARJ(I)-QARJ(I))
15983          IF (DIFF.GE.1.0D-5) THEN
15984             WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
15985 C           QARJ(I) = PARJ(I)
15986          ENDIF
15987     2 CONTINUE
15988  1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
15989  1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
15990
15991       RETURN
15992       END
15993
15994 *$ CREATE DT_FOZOCA.FOR
15995 *COPY DT_FOZOCA
15996 *
15997 *===fozoca=============================================================*
15998 *
15999       SUBROUTINE DT_FOZOCA(LFZC,IREJ)
16000
16001 ************************************************************************
16002 * This subroutine treats the complete FOrmation ZOne supressed intra-  *
16003 * nuclear CAscade.                                                     *
16004 *               LFZC = .true.  cascade has been treated                *
16005 *                    = .false. cascade skipped                         *
16006 * This is a completely revised version of the original FOZOKL.         *
16007 * This version dated 18.11.95 is written by S. Roesler                 *
16008 ************************************************************************
16009
16010       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16011       SAVE
16012       PARAMETER ( LINP = 10 ,
16013      &            LOUT = 6 ,
16014      &            LDAT = 9 )
16015       PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
16016       PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16017
16018       LOGICAL LSTART,LCAS,LFZC
16019
16020 * event history
16021       PARAMETER (NMXHKK=200000)
16022       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16023      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16024      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16025 * extended event history
16026       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16027      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16028      &                IHIST(2,NMXHKK)
16029 * rejection counter
16030       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
16031      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
16032      &                IREXCI(3),IRDIFF(2),IRINC
16033 * properties of interacting particles
16034       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
16035 * Glauber formalism: collision properties
16036       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16037      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16038 * flags for input different options
16039       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16040       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16041      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16042 * final state after intranuclear cascade step
16043       COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16044 * parameter for intranuclear cascade
16045       LOGICAL LPAULI
16046       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16047
16048       DIMENSION NCWOUN(2)
16049
16050       DATA LSTART /.TRUE./
16051
16052       LFZC = .TRUE.
16053       IREJ = 0
16054
16055 * skip cascade if hadron-hadron interaction or if supressed by user
16056       IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999
16057 * skip cascade if not all possible chains systems are hadronized
16058       DO 1 I=1,8
16059          IF (.NOT.LHADRO(I)) GOTO 9999
16060     1 CONTINUE
16061
16062       IF (LSTART) THEN
16063          WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD
16064  1000    FORMAT(/,1X,'FOZOCA:  intranuclear cascade treated for a ',
16065      &          'maximum of',I4,' generations',/,10X,'formation time ',
16066      &          'parameter:',F5.1,'  fm/c',9X,'modus:',I2)
16067          IF (ITAUVE.EQ.1) WRITE(LOUT,1001)
16068          IF (ITAUVE.EQ.2) WRITE(LOUT,1002)
16069  1001    FORMAT(10X,'p_t dependent formation zone',/)
16070  1002    FORMAT(10X,'constant formation zone',/)
16071          LSTART = .FALSE.
16072       ENDIF
16073
16074 * in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons
16075 * which may interact with final state particles are stored in a seperate
16076 * array - here all proj./target nucleon-indices (just for simplicity)
16077       NOINC = 0
16078       DO 9 I=1,NPOINT(1)-1
16079          NOINC = NOINC+1
16080          IDXINC(NOINC) = I
16081     9 CONTINUE
16082
16083 * initialize Pauli-principle treatment (find wounded nucleons)
16084       NWOUND(1) = 0
16085       NWOUND(2) = 0
16086       NCWOUN(1) = 0
16087       NCWOUN(2) = 0
16088       DO 2 J=1,NPOINT(1)
16089          DO 3 I=1,2
16090             IF (ISTHKK(J).EQ.10+I) THEN
16091                NWOUND(I) = NWOUND(I)+1
16092                EWOUND(I,NWOUND(I)) = PHKK(4,J)
16093                IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1
16094             ENDIF
16095     3    CONTINUE
16096     2 CONTINUE
16097
16098 * modify nuclear potential for wounded nucleons
16099       IPRCL  = IP -NWOUND(1)
16100       IPZRCL = IPZ-NCWOUN(1)
16101       ITRCL  = IT -NWOUND(2)
16102       ITZRCL = ITZ-NCWOUN(2)
16103       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
16104
16105       NSTART = NPOINT(4)
16106       NEND   = NHKK
16107
16108     7 CONTINUE
16109       DO 8 I=NSTART,NEND
16110
16111          IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
16112 * select nucleus the cascade starts first (proj. - 1, target - -1)
16113             NCAS   = 1
16114 *   projectile/target with probab. 1/2
16115             IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN
16116                IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16117 *   in the nucleus with highest mass
16118             ELSEIF (INCMOD.EQ.2) THEN
16119                IF (IP.GT.IT) THEN
16120                   NCAS = -NCAS
16121                ELSEIF (IP.EQ.IT) THEN
16122                   IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16123                ENDIF
16124 * the nucleus the cascade starts first is requested to be the one
16125 * moving in the direction of the secondary
16126             ELSEIF (INCMOD.EQ.3) THEN
16127                NCAS = INT(SIGN(1.0D0,PHKK(3,I)))
16128             ENDIF
16129 * check that the selected "nucleus" is not a hadron
16130             IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR.
16131      &          ((NCAS.EQ.-1).AND.(IT.LE.1)))    NCAS = -NCAS
16132
16133 * treat intranuclear cascade in the nucleus selected first
16134             LCAS = .FALSE.
16135             CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16136             IF (IREJ1.NE.0) GOTO 9998
16137 * treat intranuclear cascade in the other nucleus if this isn't a had.
16138             NCAS = -NCAS
16139             IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR.
16140      &          ((NCAS.EQ.-1).AND.(IT.GT.1)))    THEN
16141                IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
16142                IF (IREJ1.NE.0) GOTO 9998
16143             ENDIF
16144
16145          ENDIF
16146
16147     8 CONTINUE
16148       NSTART = NEND+1
16149       NEND   = NHKK
16150       IF (NSTART.LE.NEND) GOTO 7
16151
16152       RETURN
16153
16154  9998 CONTINUE
16155 * reject this event
16156       IRINC = IRINC+1
16157       IREJ = 1
16158
16159  9999 CONTINUE
16160 * intranucl. cascade not treated because of interaction properties or
16161 * it is supressed by user or it was rejected or...
16162       LFZC = .FALSE.
16163 * reset flag characterizing direction of motion in n-n-cms
16164 **sr14-11-95
16165 C     DO 9990 I=NPOINT(5),NHKK
16166 C        IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
16167 C9990 CONTINUE
16168
16169       RETURN
16170       END
16171
16172 *$ CREATE DT_INUCAS.FOR
16173 *COPY DT_INUCAS
16174 *
16175 *===inucas=============================================================*
16176 *
16177       SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
16178
16179 ************************************************************************
16180 * Formation zone supressed IntraNUclear CAScade for one final state    *
16181 * particle.                                                            *
16182 *           IT, IP    mass numbers of target, projectile nuclei        *
16183 *           IDXCAS    index of final state particle in DTEVT1          *
16184 *           NCAS =  1 intranuclear cascade in projectile               *
16185 *                = -1 intranuclear cascade in target                   *
16186 * This version dated 18.11.95 is written by S. Roesler                 *
16187 ************************************************************************
16188
16189       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16190       SAVE
16191       PARAMETER ( LINP = 10 ,
16192      &            LOUT = 6 ,
16193      &            LDAT = 9 )
16194
16195       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
16196      &           OHALF=0.5D0,ONE=1.0D0)
16197       PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16198       PARAMETER (TWOPI=6.283185307179586454D+00)
16199       PARAMETER (PLOWH=0.01D0,PHIH=9.0D0)
16200
16201       LOGICAL LABSOR,LCAS
16202
16203 * event history
16204       PARAMETER (NMXHKK=200000)
16205       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16206      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16207      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16208 * extended event history
16209       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16210      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16211      &                IHIST(2,NMXHKK)
16212 * final state after inc step
16213       PARAMETER (MAXFSP=10)
16214       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
16215 * flags for input different options
16216       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16217       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16218      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16219 * particle properties (BAMJET index convention)
16220       CHARACTER*8  ANAME
16221       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
16222      &                IICH(210),IIBAR(210),K1(210),K2(210)
16223 * Glauber formalism: collision properties
16224       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16225      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16226 * nuclear potential
16227       LOGICAL LFERMI
16228       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
16229      &                EBINDP(2),EBINDN(2),EPOT(2,210),
16230      &                ETACOU(2),ICOUL,LFERMI
16231 * parameter for intranuclear cascade
16232       LOGICAL LPAULI
16233       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16234 * final state after intranuclear cascade step
16235       COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16236 * nucleon-nucleon event-generator
16237       CHARACTER*8 CMODEL
16238       LOGICAL LPHOIN
16239       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
16240 * statistics: residual nuclei
16241       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
16242      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
16243      &                NINCST(2,4),NINCEV(2),
16244      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
16245      &                NRESPB(2),NRESCH(2),NRESEV(4),
16246      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
16247      &                NEVAFI(2,2)
16248
16249       DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4),
16250      &          PCAS1(5),PNUC(5),BGTA(4),
16251      &          BGCAS(2),GACAS(2),BECAS(2),
16252      &          RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2)
16253
16254       DATA PDIF /0.545D0/
16255
16256       IREJ = 0
16257
16258 * update counter
16259       IF (NINCEV(1).NE.NEVHKK) THEN
16260          NINCEV(1) = NEVHKK
16261          NINCEV(2) = NINCEV(2)+1
16262       ENDIF
16263
16264 * "BAMJET-index" of this hadron
16265       IDCAS = IDBAM(IDXCAS)
16266       IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
16267
16268 * skip gammas, electrons, etc..
16269       IF (AAM(IDCAS).LT.TINY2) RETURN
16270
16271 * Lorentz-trsf. into projectile rest system
16272       IF (IP.GT.1) THEN
16273          CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16274      &               PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3),
16275      &               PCAS(1,4),IDCAS,-2)
16276          PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2)
16277          PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1))
16278          IF (PCAS(1,5).GT.ZERO) THEN
16279             PCAS(1,5) = SQRT(PCAS(1,5))
16280          ELSE
16281             PCAS(1,5) = AAM(IDCAS)
16282          ENDIF
16283          DO 20 K=1,3
16284             COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
16285    20    CONTINUE
16286 * Lorentz-parameters
16287 *   particle rest system --> projectile rest system
16288          BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10)
16289          GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10)
16290          BECAS(1) = BGCAS(1)/GACAS(1)
16291       ELSE
16292          DO 21 K=1,5
16293             PCAS(1,K) = ZERO
16294             IF (K.LE.3) COSCAS(1,K) = ZERO
16295    21    CONTINUE
16296          PTOCAS(1) = ZERO
16297          BGCAS(1)  = ZERO
16298          GACAS(1)  = ZERO
16299          BECAS(1)  = ZERO
16300       ENDIF
16301 * Lorentz-trsf. into target rest system
16302       IF (IT.GT.1) THEN
16303 * LEPTO: final state particles are already in target rest frame
16304 C        IF (MCGENE.EQ.3) THEN
16305 C           PCAS(2,1) = PHKK(1,IDXCAS)
16306 C           PCAS(2,2) = PHKK(2,IDXCAS)
16307 C           PCAS(2,3) = PHKK(3,IDXCAS)
16308 C           PCAS(2,4) = PHKK(4,IDXCAS)
16309 C        ELSE
16310             CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
16311      &                  PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3),
16312      &                  PCAS(2,4),IDCAS,-3)
16313 C        ENDIF
16314          PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2)
16315          PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2))
16316          IF (PCAS(2,5).GT.ZERO) THEN
16317             PCAS(2,5) = SQRT(PCAS(2,5))
16318          ELSE
16319             PCAS(2,5) = AAM(IDCAS)
16320          ENDIF
16321          DO 22 K=1,3
16322             COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
16323    22    CONTINUE
16324 * Lorentz-parameters
16325 *   particle rest system --> target rest system
16326          BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10)
16327          GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10)
16328          BECAS(2) = BGCAS(2)/GACAS(2)
16329       ELSE
16330          DO 23 K=1,5
16331             PCAS(2,K) = ZERO
16332             IF (K.LE.3) COSCAS(2,K) = ZERO
16333    23    CONTINUE
16334          PTOCAS(2) = ZERO
16335          BGCAS(2)  = ZERO
16336          GACAS(2)  = ZERO
16337          BECAS(2)  = ZERO
16338       ENDIF
16339
16340 * radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
16341 * potential (see CONUCL)
16342       RNUC(1)  = (RPROJ+4.605D0*PDIF)*FM2MM
16343       RNUC(2)  = (RTARG+4.605D0*PDIF)*FM2MM
16344 * impact parameter (the projectile moving along z)
16345       BIMPC(1) = ZERO
16346       BIMPC(2) = BIMPAC*FM2MM
16347
16348 * get position of initial hadron in projectile/target rest-syst.
16349       DO 3 K=1,4
16350          VTXCAS(1,K) = WHKK(K,IDXCAS)
16351          VTXCAS(2,K) = VHKK(K,IDXCAS)
16352     3 CONTINUE
16353
16354       ICAS = 1
16355       I2   = 2
16356       IF (NCAS.EQ.-1) THEN
16357          ICAS = 2
16358          I2   = 1
16359       ENDIF
16360
16361       IF (PTOCAS(ICAS).LT.TINY10) THEN
16362          WRITE(LOUT,1000) PTOCAS
16363  1000    FORMAT(1X,'INUCAS:   warning! zero momentum of initial',
16364      &          '  hadron ',/,20X,2E12.4)
16365          GOTO 9999
16366       ENDIF
16367
16368 * reset spectator flags
16369       NSPE = 0
16370       IDXSPE(1) = 0
16371       IDXSPE(2) = 0
16372       IDSPE(1)  = 0
16373       IDSPE(2)  = 0
16374
16375 * formation length (in fm)
16376 C     IF (LCAS) THEN
16377 C        DEL0 = ZERO
16378 C     ELSE
16379          DEL0 = TAUFOR*BGCAS(ICAS)
16380          IF (ITAUVE.EQ.1) THEN
16381             AMT  = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2
16382             DEL0 = DEL0*PCAS(ICAS,5)**2/AMT
16383          ENDIF
16384 C     ENDIF
16385 *   sample from exp(-del/del0)
16386       DEL1   = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10))
16387 * save formation time
16388       TAUSA1 = DEL1/BGCAS(ICAS)
16389       REL1   = TAUSA1*BGCAS(I2)
16390
16391       DEL    = DEL1
16392       TAUSAM = DEL/BGCAS(ICAS)
16393       REL    = TAUSAM*BGCAS(I2)
16394
16395 * special treatment for negative particles unable to escape
16396 * nuclear potential (implemented for ap, pi-, K- only)
16397       LABSOR = .FALSE.
16398       IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN
16399 *   threshold energy = nuclear potential + Coulomb potential
16400 *   (nuclear potential for hadron-nucleus interactions only)
16401          ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS)
16402          IF (PCAS(ICAS,4).LT.ETHR) THEN
16403             DO 4 K=1,5
16404                PCAS1(K) = PCAS(ICAS,K)
16405     4       CONTINUE
16406 *   "absorb" negative particle in nucleus
16407             CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1)
16408             IF (IREJ1.NE.0) GOTO 9999
16409             IF (NSPE.GE.1) LABSOR = .TRUE.
16410          ENDIF
16411       ENDIF
16412
16413 * if the initial particle has not been absorbed proceed with
16414 * "normal" cascade
16415       IF (.NOT.LABSOR) THEN
16416
16417 *   calculate coordinates of hadron at the end of the formation zone
16418 *   transport-time and -step in the rest system where this step is
16419 *   treated
16420          DSTEP  = DEL*FM2MM
16421          DTIME  = DSTEP/BECAS(ICAS)
16422          RSTEP  = REL*FM2MM
16423          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16424             RTIME = RSTEP/BECAS(I2)
16425          ELSE
16426             RTIME = ZERO
16427          ENDIF
16428 *   save step whithout considering the overlapping region
16429          DSTEP1 = DEL1*FM2MM
16430          DTIME1 = DSTEP1/BECAS(ICAS)
16431          RSTEP1 = REL1*FM2MM
16432          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16433             RTIME1 = RSTEP1/BECAS(I2)
16434          ELSE
16435             RTIME1 = ZERO
16436          ENDIF
16437 *   transport to the end of the formation zone in this system
16438          DO 5 K=1,3
16439             VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K)
16440             VTXCA1(I2,K)   = VTXCAS(I2,K)  +RSTEP1*COSCAS(I2,K)
16441             VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K)
16442             VTXCAS(I2,K)   = VTXCAS(I2,K)  +RSTEP*COSCAS(I2,K)
16443     5    CONTINUE
16444          VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1
16445          VTXCA1(I2,4)   = VTXCAS(I2,4)  +RTIME1
16446          VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME
16447          VTXCAS(I2,4)   = VTXCAS(I2,4)  +RTIME
16448
16449          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16450             XCAS   = VTXCAS(ICAS,1)
16451             YCAS   = VTXCAS(ICAS,2)
16452             XNCLTA = BIMPAC*FM2MM
16453             RNCLPR = (RPROJ+RNUCLE)*FM2MM
16454             RNCLTA = (RTARG+RNUCLE)*FM2MM
16455 C           RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
16456 C           RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
16457 C           RNCLPR = (RPROJ)*FM2MM
16458 C           RNCLTA = (RTARG)*FM2MM
16459             RCASPR = SQRT( XCAS**2        +YCAS**2)
16460             RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2)
16461             IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN
16462                IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3
16463             ENDIF
16464          ENDIF
16465
16466 *   check if particle is already outside of the corresp. nucleus
16467          RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+
16468      &                VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2)
16469          IF (RDIST.GE.RNUC(ICAS)) THEN
16470 *   here: IDCH is the generation of the final state part. starting
16471 *   with zero for hadronization products
16472 *   flag particles of generation 0 being outside the nuclei after
16473 *   formation time (to be used for excitation energy calculation)
16474             IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3))
16475      &         NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS
16476             GOTO 9997
16477          ENDIF
16478          DIST   = DLARGE
16479          DISTP  = DLARGE
16480          DISTN  = DLARGE
16481          IDXP   = 0
16482          IDXN   = 0
16483
16484 *   already here: skip particles being outside HADRIN "energy-window"
16485 *   to avoid wasting of time
16486          NINCHR(ICAS,1) = NINCHR(ICAS,1)+1
16487          IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN
16488             NINCHR(ICAS,2) = NINCHR(ICAS,2)+1
16489 C           WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
16490 C1002       FORMAT(1X,'INUCAS:   warning! momentum of particle with ',
16491 C    &             'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
16492 C    &             E12.4,', above or below HADRIN-thresholds',I6)
16493             NSPE = 0
16494             GOTO 9997
16495          ENDIF
16496
16497          DO 7 IDXHKK=1,NOINC
16498             I = IDXINC(IDXHKK)
16499 *   scan DTEVT1 for unwounded or excited nucleons
16500             IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
16501                DO 8 K=1,3
16502                   IF (ICAS.EQ.1) THEN
16503                      VTXDST(K) = WHKK(K,I)-VTXCAS(1,K)
16504                   ELSEIF (ICAS.EQ.2) THEN
16505                      VTXDST(K) = VHKK(K,I)-VTXCAS(2,K)
16506                   ENDIF
16507     8          CONTINUE
16508                POSNUC = VTXDST(1)*COSCAS(ICAS,1)+
16509      &                  VTXDST(2)*COSCAS(ICAS,2)+
16510      &                  VTXDST(3)*COSCAS(ICAS,3)
16511 *   check if nucleon is situated in forward direction
16512                IF (POSNUC.GT.ZERO) THEN
16513 *   distance between hadron and this nucleon
16514                   DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16515      &                          VTXDST(3)**2)
16516 *   impact parameter
16517                   BIMNU2 = DISTNU**2-POSNUC**2
16518                   IF (BIMNU2.LT.ZERO) THEN
16519                      WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2
16520  1001                FORMAT(1X,'INUCAS:   warning! inconsistent impact',
16521      &                      '  parameter ',/,20X,3E12.4)
16522                      GOTO 7
16523                   ENDIF
16524                   BIMNU  = SQRT(BIMNU2)
16525 *   maximum impact parameter to have interaction
16526                   IDNUC  = IDT_ICIHAD(IDHKK(I))
16527                   IDNUC1 = IDT_MCHAD(IDNUC)
16528                   IDCAS1 = IDT_MCHAD(IDCAS)
16529                   DO 19 K=1,5
16530                      PCAS1(K) = PCAS(ICAS,K)
16531                      PNUC(K)  = PHKK(K,I)
16532    19             CONTINUE
16533 * Lorentz-parameter for trafo into rest-system of target
16534                   DO 18 K=1,4
16535                      BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
16536    18             CONTINUE
16537 * transformation of projectile into rest-system of target
16538                   CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
16539      &                        PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4),
16540      &                        PPTOT,PX,PY,PZ,PE)
16541 **
16542 C                 CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
16543 C                 CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
16544                   DUMZER = ZERO
16545                   CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL)
16546                   CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB)
16547                   IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND.
16548      &                (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0
16549                   SIGIN = SIGTOT-SIGEL-SIGAB
16550 C                 SIGTOT = SIGIN+SIGEL+SIGAB
16551 **
16552                   BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM
16553 *   check if interaction is possible
16554                   IF (BIMNU.LE.BIMMAX) THEN
16555 *   get nucleon with smallest distance and kind of interaction
16556 *   (elastic/inelastic)
16557                      IF (DISTNU.LT.DIST) THEN
16558                         DIST      = DISTNU
16559                         BINT      = BIMNU
16560                         IF (IDNUC.NE.IDSPE(1)) THEN
16561                            IDSPE(2)  = IDSPE(1)
16562                            IDXSPE(2) = IDXSPE(1)
16563                            IDSPE(1)  = IDNUC
16564                         ENDIF
16565                         IDXSPE(1) = I
16566                         NSPE      = 1
16567 **sr
16568                         SELA = SIGEL
16569                         SABS = SIGAB
16570                         STOT = SIGTOT
16571 C                       IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
16572 C                          SELA = SIGEL
16573 C                          STOT = SIGIN+SIGEL
16574 C                       ELSE
16575 C                          SELA = SIGEL+0.75D0*SIGIN
16576 C                          STOT = 0.25D0*SIGIN+SELA
16577 C                       ENDIF
16578 **
16579                      ENDIF
16580                   ENDIf
16581                ENDIF
16582                DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16583      &                       VTXDST(3)**2)
16584                IDNUC  = IDT_ICIHAD(IDHKK(I))
16585                IF (IDNUC.EQ.1) THEN
16586                   IF (DISTNU.LT.DISTP) THEN
16587                      DISTP = DISTNU
16588                      IDXP  = I
16589                      POSP  = POSNUC
16590                   ENDIF
16591                ELSEIF (IDNUC.EQ.8) THEN
16592                   IF (DISTNU.LT.DISTN) THEN
16593                      DISTN = DISTNU
16594                      IDXN  = I
16595                      POSN  = POSNUC
16596                   ENDIF
16597                ENDIF
16598             ENDIF
16599     7    CONTINUE
16600
16601 * there is no nucleon for a secondary interaction
16602          IF (NSPE.EQ.0) GOTO 9997
16603
16604 C        IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
16605 C    &      WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
16606          IF (IDXSPE(2).EQ.0) THEN
16607             IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
16608 C              DO 80 K=1,3
16609 C                 IF (ICAS.EQ.1) THEN
16610 C                    VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
16611 C                 ELSEIF (ICAS.EQ.2) THEN
16612 C                    VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
16613 C                 ENDIF
16614 C  80          CONTINUE
16615 C              DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16616 C    &                       VTXDST(3)**2)
16617 C              IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
16618                   IDXSPE(2) = IDXN
16619                   IDSPE(2)  = 8
16620 C              ELSE
16621 C                 STOT = STOT-SABS
16622 C                 SABS = ZERO
16623 C              ENDIF
16624             ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
16625 C              DO 81 K=1,3
16626 C                 IF (ICAS.EQ.1) THEN
16627 C                    VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
16628 C                 ELSEIF (ICAS.EQ.2) THEN
16629 C                    VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
16630 C                 ENDIF
16631 C  81          CONTINUE
16632 C              DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
16633 C    &                       VTXDST(3)**2)
16634 C              IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
16635                   IDXSPE(2) = IDXP
16636                   IDSPE(2)  = 1
16637 C              ELSE
16638 C                 STOT = STOT-SABS
16639 C                 SABS = ZERO
16640 C              ENDIF
16641             ELSE
16642                STOT = STOT-SABS
16643                SABS = ZERO
16644             ENDIF
16645          ENDIF
16646          RR = DT_RNDM(DIST)
16647          IF (RR.LT.SELA/STOT) THEN
16648             IPROC = 2
16649          ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
16650             IPROC = 3
16651          ELSE
16652             IPROC = 1
16653          ENDIF
16654
16655          DO 9 K=1,5
16656             PCAS1(K) = PCAS(ICAS,K)
16657             PNUC(K)  = PHKK(K,IDXSPE(1))
16658     9    CONTINUE
16659          IF (IPROC.EQ.3) THEN
16660 * 2-nucleon absorption of pion
16661             NSPE = 2
16662             CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1)
16663             IF (IREJ1.NE.0) GOTO 9999
16664             IF (NSPE.GE.1) LABSOR = .TRUE.
16665          ELSE
16666 * sample secondary interaction
16667             IDNUC = IDBAM(IDXSPE(1))
16668             CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1)
16669             IF (IREJ1.EQ.1) GOTO 9999
16670             IF (IREJ1.GT.1) GOTO 9998
16671          ENDIF
16672       ENDIF
16673
16674 * update arrays to include Pauli-principle
16675       DO 10 I=1,NSPE
16676          IF (NWOUND(ICAS).LE.299) THEN
16677             NWOUND(ICAS) = NWOUND(ICAS)+1
16678             EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
16679          ENDIF
16680    10 CONTINUE
16681
16682 * dump initial hadron for energy-momentum conservation check
16683       IF (LEMCCK)
16684      &   CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
16685      &               PCAS(ICAS,4),1,IDUM,IDUM)
16686
16687 * dump final state particles into DTEVT1
16688
16689 *   check if Pauli-principle is fulfilled
16690       NPAULI = 0
16691       NWTMP(1) = NWOUND(1)
16692       NWTMP(2) = NWOUND(2)
16693       DO 111 I=1,NFSP
16694          NPAULI = 0
16695          J1 = 2
16696          IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16697      &       ((NCAS.EQ.-1).AND.(IP.LE.1)))    J1 = 1
16698          DO 117 J=1,J1
16699             IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
16700             IF (J.EQ.1) THEN
16701                IDX = ICAS
16702                PE  = PFSP(4,I)
16703             ELSE
16704                IDX  = I2
16705                MODE = 1
16706                IF (IDX.EQ.1) MODE = -1
16707                CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
16708             ENDIF
16709 * first check if cascade step is forbidden due to Pauli-principle
16710 * (in case of absorpion this step is forced)
16711             IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16712      &          (IDFSP(I).EQ.8))) THEN
16713 *   get nuclear potential barrier
16714                POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16715                IF (IDFSP(I).EQ.1) THEN
16716                   POTLOW = POT-EBINDP(IDX)
16717                ELSE
16718                   POTLOW = POT-EBINDN(IDX)
16719                ENDIF
16720 *   final state particle not able to escape nucleus
16721                IF (PE.LE.POTLOW) THEN
16722 *     check if there are wounded nucleons
16723                   IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16724      &                 EWOUND(IDX,NWOUND(IDX)))) THEN
16725                      NPAULI      = NPAULI+1
16726                      NWOUND(IDX) = NWOUND(IDX)-1
16727                   ELSE
16728 *     interaction prohibited by Pauli-principle
16729                      NWOUND(1) = NWTMP(1)
16730                      NWOUND(2) = NWTMP(2)
16731                      GOTO 9997
16732                   ENDIF
16733                ENDIF
16734             ENDIF
16735   117    CONTINUE
16736   111 CONTINUE
16737
16738       NPAULI = 0
16739       NWOUND(1) = NWTMP(1)
16740       NWOUND(2) = NWTMP(2)
16741
16742       DO 11 I=1,NFSP
16743
16744          IST = ISTHKK(IDXCAS)
16745
16746          NPAULI = 0
16747          J1 = 2
16748          IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
16749      &       ((NCAS.EQ.-1).AND.(IP.LE.1)))    J1 = 1
16750          DO 17 J=1,J1
16751             IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
16752             IDX = ICAS
16753             PE  = PFSP(4,I)
16754             IF (J.EQ.2) THEN
16755                IDX = I2
16756                CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
16757             ENDIF
16758 * first check if cascade step is forbidden due to Pauli-principle
16759 * (in case of absorpion this step is forced)
16760             IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
16761      &          (IDFSP(I).EQ.8))) THEN
16762 *   get nuclear potential barrier
16763                POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
16764                IF (IDFSP(I).EQ.1) THEN
16765                   POTLOW = POT-EBINDP(IDX)
16766                ELSE
16767                   POTLOW = POT-EBINDN(IDX)
16768                ENDIF
16769 *   final state particle not able to escape nucleus
16770                IF (PE.LE.POTLOW) THEN
16771 *     check if there are wounded nucleons
16772                   IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
16773      &                 EWOUND(IDX,NWOUND(IDX)))) THEN
16774                      NWOUND(IDX) = NWOUND(IDX)-1
16775                      NPAULI = NPAULI+1
16776                      IST    = 14+IDX
16777                   ELSE
16778 *     interaction prohibited by Pauli-principle
16779                      NWOUND(1) = NWTMP(1)
16780                      NWOUND(2) = NWTMP(2)
16781                      GOTO 9997
16782                   ENDIF
16783 **sr
16784 c               ELSEIF (PE.LE.POT) THEN
16785 cC              ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
16786 cC                 NWOUND(IDX) = NWOUND(IDX)-1
16787 c**
16788 c                  NPAULI = NPAULI+1
16789 c                  IST    = 14+IDX
16790                ENDIF
16791             ENDIF
16792    17    CONTINUE
16793
16794 * dump final state particles for energy-momentum conservation check
16795          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I),
16796      &                           -PFSP(4,I),2,IDUM,IDUM)
16797
16798          PX = PFSP(1,I)
16799          PY = PFSP(2,I)
16800          PZ = PFSP(3,I)
16801          PE = PFSP(4,I)
16802          IF (ABS(IST).EQ.1) THEN
16803 * transform particles back into n-n cms
16804 * LEPTO: leave final state particles in target rest frame
16805 C           IF (MCGENE.EQ.3) THEN
16806 C              PFSP(1,I) = PX
16807 C              PFSP(2,I) = PY
16808 C              PFSP(3,I) = PZ
16809 C              PFSP(4,I) = PE
16810 C           ELSE
16811                IMODE = ICAS+1
16812                CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16813      &                     PFSP(4,I),IDFSP(I),IMODE)
16814 C           ENDIF
16815          ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN
16816 * target cascade but fsp got stuck in proj. --> transform it into
16817 * proj. rest system
16818             CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16819      &                  PFSP(4,I),IDFSP(I),-1)
16820          ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN
16821 * proj. cascade but fsp got stuck in target --> transform it into
16822 * target rest system
16823             CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
16824      &                  PFSP(4,I),IDFSP(I),1)
16825          ENDIF
16826
16827 * dump final state particles into DTEVT1
16828          IGEN = IDCH(IDXCAS)+1
16829          ID   = IDT_IPDGHA(IDFSP(I))
16830          IXR  = 0
16831          IF (LABSOR) IXR = 99
16832          CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I),
16833      &               PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN)
16834
16835 * update the counter for particles which got stuck inside the nucleus
16836          IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
16837             NOINC = NOINC+1
16838             IDXINC(NOINC) = NHKK
16839          ENDIF
16840          IF (LABSOR) THEN
16841 *   in case of absorption the spatial treatment is an approximate
16842 *   solution anyway (the positions of the nucleons which "absorb" the
16843 *   cascade particle are not taken into consideration) therefore the
16844 *   particles are produced at the position of the cascade particle
16845             DO 12 K=1,4
16846                WHKK(K,NHKK) = WHKK(K,IDXCAS)
16847                VHKK(K,NHKK) = VHKK(K,IDXCAS)
16848    12       CONTINUE
16849          ELSE
16850 *   DDISTL - distance the cascade particle moves to the intera. point
16851 *   (the position where impact-parameter = distance to the interacting
16852 *   nucleon), DIST - distance to the interacting nucleon at the time of
16853 *   formation of the cascade particle, BINT - impact-parameter of this
16854 *   cascade-interaction
16855             DDISTL = SQRT(DIST**2-BINT**2)
16856             DTIME  = DDISTL/BECAS(ICAS)
16857             DTIMEL = DDISTL/BGCAS(ICAS)
16858             RDISTL = DTIMEL*BGCAS(I2)
16859             IF ((IP.GT.1).AND.(IT.GT.1)) THEN
16860                RTIME = RDISTL/BECAS(I2)
16861             ELSE
16862                RTIME = ZERO
16863             ENDIF
16864 *   RDISTL, RTIME are this step and time in the rest system of the other
16865 *   nucleus
16866             DO 13 K=1,3
16867                VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
16868                VTXCA1(I2,K)   = VTXCAS(I2,K)  +COSCAS(I2,K)  *RDISTL
16869    13       CONTINUE
16870             VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME
16871             VTXCA1(I2,4)   = VTXCAS(I2,4)  +RTIME
16872 *   position of particle production is half the impact-parameter to
16873 *   the interacting nucleon
16874             DO 14 K=1,3
16875                WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
16876                VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
16877    14       CONTINUE
16878 *   time of production of secondary = time of interaction
16879             WHKK(4,NHKK) = VTXCA1(1,4)
16880             VHKK(4,NHKK) = VTXCA1(2,4)
16881          ENDIF
16882
16883    11 CONTINUE
16884
16885 * modify status and position of cascade particle (the latter for
16886 * statistics reasons only)
16887       ISTHKK(IDXCAS) = 2
16888       IF (LABSOR) ISTHKK(IDXCAS) = 19
16889       IF (.NOT.LABSOR) THEN
16890          DO 15 K=1,4
16891             WHKK(K,IDXCAS) = VTXCA1(1,K)
16892             VHKK(K,IDXCAS) = VTXCA1(2,K)
16893    15    CONTINUE
16894       ENDIF
16895
16896       DO 16 I=1,NSPE
16897          IS = IDXSPE(I)
16898 * dump interacting nucleons for energy-momentum conservation check
16899          IF (LEMCCK)
16900      &      CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
16901      &                                                  2,IDUM,IDUM)
16902 * modify entry for interacting nucleons
16903          IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS
16904          IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2
16905          IF (I.GE.2) THEN
16906             JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
16907             JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
16908          ENDIF
16909    16 CONTINUE
16910
16911 * check energy-momentum conservation
16912       IF (LEMCCK) THEN
16913          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
16914          IF (IREJ1.NE.0) GOTO 9999
16915       ENDIF
16916
16917 * update counter
16918       IF (LABSOR) THEN
16919          NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
16920       ELSE
16921          IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
16922          IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
16923       ENDIF
16924
16925       RETURN
16926
16927  9997 CONTINUE
16928  9998 CONTINUE
16929 * transport-step but no cascade step due to configuration (i.e. there
16930 * is no nucleon for interaction etc.)
16931       IF (LCAS) THEN
16932          DO 100 K=1,4
16933 C           WHKK(K,IDXCAS) = VTXCAS(1,K)
16934 C           VHKK(K,IDXCAS) = VTXCAS(2,K)
16935             WHKK(K,IDXCAS) = VTXCA1(1,K)
16936             VHKK(K,IDXCAS) = VTXCA1(2,K)
16937   100    CONTINUE
16938       ENDIF
16939
16940 C9998 CONTINUE
16941 * no cascade-step because of configuration
16942 * (i.e. hadron outside nucleus etc.)
16943       LCAS = .TRUE.
16944       RETURN
16945
16946  9999 CONTINUE
16947 * rejection
16948       IREJ = 1
16949       RETURN
16950       END
16951
16952 *$ CREATE DT_ABSORP.FOR
16953 *COPY DT_ABSORP
16954 *
16955 *===absorp=============================================================*
16956 *
16957       SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
16958
16959 ************************************************************************
16960 * Two-nucleon absorption of antiprotons, pi-, and K-.                  *
16961 * Antiproton absorption is handled by HADRIN.                          *
16962 * The following channels for meson-absorption are considered:          *
16963 *          pi- + p + p ---> n + p                                      *
16964 *          pi- + p + n ---> n + n                                      *
16965 *          K-  + p + p ---> sigma+ + n / Lam + p / sigma0 + p          *
16966 *          K-  + p + n ---> sigma- + n / Lam + n / sigma0 + n          *
16967 *          K-  + p + p ---> sigma- + n                                 *
16968 *      IDCAS, PCAS   identity, momentum of particle to be absorbed     *
16969 *      NCAS =  1     intranuclear cascade in projectile                *
16970 *           = -1     intranuclear cascade in target                    *
16971 *      NSPE          number of spectator nucleons involved             *
16972 *      IDXSPE(2)     DTEVT1-indices of spectator nucleons involved     *
16973 * Revised version of the original STOPIK written by HJM and J. Ranft.  *
16974 * This version dated 24.02.95 is written by S. Roesler                 *
16975 ************************************************************************
16976
16977       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16978       SAVE
16979       PARAMETER ( LINP = 10 ,
16980      &            LOUT = 6 ,
16981      &            LDAT = 9 )
16982       PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0,
16983      &           ONETHI=0.3333D0,TWOTHI=0.6666D0)
16984
16985 * event history
16986       PARAMETER (NMXHKK=200000)
16987       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16988      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16989      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16990 * extended event history
16991       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16992      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16993      &                IHIST(2,NMXHKK)
16994 * flags for input different options
16995       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16996       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16997      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16998 * final state after inc step
16999       PARAMETER (MAXFSP=10)
17000       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17001 * particle properties (BAMJET index convention)
17002       CHARACTER*8  ANAME
17003       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17004      &                IICH(210),IIBAR(210),K1(210),K2(210)
17005
17006       DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5),
17007      &          PTOT3P(4),BG3P(4),
17008      &          ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2)
17009
17010       IREJ = 0
17011       NFSP = 0
17012
17013 * skip particles others than ap, pi-, K- for mode=0
17014       IF ((MODE.EQ.0).AND.
17015      &    (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN
17016 * skip particles others than pions for mode=1
17017 * (2-nucleon absorption in intranuclear cascade)
17018       IF ((MODE.EQ.1).AND.
17019      &    (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN
17020
17021       NUCAS = NCAS
17022       IF (NUCAS.EQ.-1) NUCAS = 2
17023
17024       IF (MODE.EQ.0) THEN
17025 * scan spectator nucleons for nucleons being able to "absorb"
17026          NSPE      = 0
17027          IDXSPE(1) = 0
17028          IDXSPE(2) = 0
17029          DO 1 I=1,NHKK
17030             IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
17031                NSPE         = NSPE+1
17032                IDXSPE(NSPE) = I
17033                IDSPE(NSPE)  = IDBAM(I)
17034                IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2
17035                IF (NSPE.EQ.2) THEN
17036                   IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND.
17037      &                                  (IDSPE(2).EQ.8)) THEN
17038 *    there is no pi-+n+n channel
17039                      NSPE = 1
17040                      GOTO 1
17041                   ELSE
17042                      GOTO 2
17043                   ENDIF
17044                ENDIF
17045             ENDIF
17046     1    CONTINUE
17047
17048     2    CONTINUE
17049       ENDIF
17050 * transform excited projectile nucleons (status=15) into proj. rest s.
17051       DO 3 I=1,NSPE
17052          DO 4 K=1,5
17053             PSPE(I,K) = PHKK(K,IDXSPE(I))
17054     4    CONTINUE
17055     3 CONTINUE
17056
17057 * antiproton absorption
17058       IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
17059          DO 5 K=1,5
17060             PSPE1(K) = PSPE(1,K)
17061     5    CONTINUE
17062          CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
17063          IF (IREJ1.NE.0) GOTO 9999
17064
17065 * meson absorption
17066       ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23)
17067      &                      .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN
17068          IF (IDCAS.EQ.14) THEN
17069 *   pi- absorption
17070             IDFSP(1) = 8
17071             IDFSP(2) = 8
17072             IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
17073          ELSEIF (IDCAS.EQ.13) THEN
17074 *   pi+ absorption
17075             IDFSP(1) = 1
17076             IDFSP(2) = 1
17077             IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
17078          ELSEIF (IDCAS.EQ.23) THEN
17079 *   pi0 absorption
17080             IDFSP(1) = IDSPE(1)
17081             IDFSP(2) = IDSPE(2)
17082          ELSEIF (IDCAS.EQ.16) THEN
17083 *   K- absorption
17084             R = DT_RNDM(PCAS)
17085             IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
17086                IF (R.LT.ONETHI) THEN
17087                   IDFSP(1) = 21
17088                   IDFSP(2) = 8
17089                ELSEIF (R.LT.TWOTHI) THEN
17090                   IDFSP(1) = 17
17091                   IDFSP(2) = 1
17092                ELSE
17093                   IDFSP(1) = 22
17094                   IDFSP(2) = 1
17095                ENDIF
17096             ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
17097                IDFSP(1) = 20
17098                IDFSP(2) = 8
17099             ELSE
17100                IF (R.LT.ONETHI) THEN
17101                   IDFSP(1) = 20
17102                   IDFSP(2) = 1
17103                ELSEIF (R.LT.TWOTHI) THEN
17104                   IDFSP(1) = 17
17105                   IDFSP(2) = 8
17106                ELSE
17107                   IDFSP(1) = 22
17108                   IDFSP(2) = 8
17109                ENDIF
17110             ENDIF
17111          ENDIF
17112 *   dump initial particles for energy-momentum cons. check
17113          IF (LEMCCK) THEN
17114             CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM)
17115             CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2,
17116      &                                                    IDUM,IDUM)
17117             CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
17118      &                                                    IDUM,IDUM)
17119          ENDIF
17120 *   get Lorentz-parameter of 3 particle initial state
17121          DO 6 K=1,4
17122             PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
17123     6    CONTINUE
17124          P3P  = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
17125          AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
17126          DO 7 K=1,4
17127             BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
17128     7    CONTINUE
17129 *   2-particle decay of the 3-particle compound system
17130          CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2),
17131      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
17132      &               AAM(IDFSP(1)),AAM(IDFSP(2)))
17133          DO 8 I=1,2
17134             SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I)))
17135             PX  = PCMF(I)*COFF(I)*SDF
17136             PY  = PCMF(I)*SIFF(I)*SDF
17137             PZ  = PCMF(I)*CODF(I)
17138             CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ,
17139      &                  ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17140      &                  PFSP(4,I))
17141             PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) )
17142 *   check consistency of kinematics
17143             IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN
17144                WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I)
17145  1001          FORMAT(1X,'ABSORP:   warning! inconsistent',
17146      &                ' tree-particle kinematics',/,20X,'id: ',I3,
17147      &                ' AAM = ',E10.4,' MFSP = ',E10.4)
17148             ENDIF
17149 *   dump final state particles for energy-momentum cons. check
17150             IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17151      &                              -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17152     8    CONTINUE
17153          NFSP = 2
17154          IF (LEMCCK) THEN
17155             CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1)
17156             IF (IREJ1.NE.0) THEN
17157                WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)),
17158      &                      AM3P
17159                GOTO 9999
17160             ENDIF
17161          ENDIF
17162       ELSE
17163          IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
17164  1000    FORMAT(1X,'ABSORP:   warning! absorption for particle ',I3,
17165      &          ' impossible',/,20X,'too few spectators (',I2,')')
17166          NSPE = 0
17167       ENDIF
17168
17169       RETURN
17170
17171  9999 CONTINUE
17172       IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
17173       IREJ = 1
17174       RETURN
17175       END
17176
17177 *$ CREATE DT_HADRIN.FOR
17178 *COPY DT_HADRIN
17179 *
17180 *===hadrin=============================================================*
17181 *
17182       SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
17183
17184 ************************************************************************
17185 * Interface to the HADRIN-routines for inelastic and elastic           *
17186 * scattering.                                                          *
17187 *      IDPR,PPR(5)   identity, momentum of projectile                  *
17188 *      IDTA,PTA(5)   identity, momentum of target                      *
17189 *      MODE  = 1     inelastic interaction                             *
17190 *            = 2     elastic   interaction                             *
17191 * Revised version of the original FHAD.                                *
17192 * This version dated 27.10.95 is written by S. Roesler                 *
17193 ************************************************************************
17194
17195       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17196       SAVE
17197       PARAMETER ( LINP = 10 ,
17198      &            LOUT = 6 ,
17199      &            LDAT = 9 )
17200       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,
17201      &           TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0)
17202
17203       LOGICAL LCORR,LMSSG
17204
17205 * flags for input different options
17206       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17207       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17208      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17209 * final state after inc step
17210       PARAMETER (MAXFSP=10)
17211       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17212 * particle properties (BAMJET index convention)
17213       CHARACTER*8  ANAME
17214       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17215      &                IICH(210),IIBAR(210),K1(210),K2(210)
17216 * output-common for DHADRI/ELHAIN
17217 * final state from HADRIN interaction
17218       PARAMETER (MAXFIN=10)
17219       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
17220      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
17221
17222       DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
17223      &          P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
17224
17225       DATA LMSSG /.TRUE./
17226
17227       IREJ  = 0
17228       NFSP  = 0
17229       KCORR = 0
17230       IMCORR(1) = 0
17231       IMCORR(2) = 0
17232       LCORR = .FALSE.
17233
17234 *   dump initial particles for energy-momentum cons. check
17235       IF (LEMCCK) THEN
17236          CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM)
17237          CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM)
17238       ENDIF
17239
17240       AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2
17241       AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2
17242       IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR.
17243      &    (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR.
17244      &    (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN
17245          IF (LMSSG.AND.(IOULEV(3).GT.0))
17246      &   WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2
17247  1000    FORMAT(1X,'HADRIN:   warning! inconsistent projectile/target',
17248      &          ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ',
17249      &          E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4)
17250          LMSSG = .FALSE.
17251          LCORR = .TRUE.
17252       ENDIF
17253
17254 * convert initial state particles into particles which can be
17255 * handled by HADRIN
17256       IDHPR = IDPR
17257       IDHTA = IDTA
17258       IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
17259          IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
17260          DO 1 K=1,4
17261             P1IN(K) = PPR(K)
17262             P2IN(K) = PTA(K)
17263     1    CONTINUE
17264          XM1 = AAM(IDHPR)
17265          XM2 = AAM(IDHTA)
17266          CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17267          IF (IREJ1.GT.0) THEN
17268             WRITE(LOUT,'(1X,A)') 'HADRIN:   inconsistent mass trsf.'
17269             GOTO 9999
17270          ENDIF
17271          DO 2 K=1,4
17272             PPR(K) = P1OUT(K)
17273             PTA(K) = P2OUT(K)
17274     2    CONTINUE
17275          PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2)
17276          PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2)
17277       ENDIF
17278
17279 * Lorentz-parameter for trafo into rest-system of target
17280       DO 3 K=1,4
17281          BGTA(K) = PTA(K)/PTA(5)
17282     3 CONTINUE
17283 * transformation of projectile into rest-system of target
17284       CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2),
17285      &            PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3),
17286      &            PPR1(4))
17287
17288 * direction cosines of projectile in target rest system
17289       CX = PPR1(1)/PPRTO1
17290       CY = PPR1(2)/PPRTO1
17291       CZ = PPR1(3)/PPRTO1
17292
17293 * sample inelastic interaction
17294       IF (MODE.EQ.1) THEN
17295          CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA)
17296          IF (IRH.EQ.1) GOTO 9998
17297 * sample elastic interaction
17298       ELSEIF (MODE.EQ.2) THEN
17299          CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1)
17300          IF (IREJ1.NE.0) THEN
17301             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN'
17302             GOTO 9999
17303          ENDIF
17304          IF (IRH.EQ.1) GOTO 9998
17305       ELSE
17306          WRITE(LOUT,1001) MODE,INTHAD
17307  1001    FORMAT(1X,'HADRIN:   warning! inconsistent interaction mode',
17308      &          I4,' (INTHAD =',I4,')')
17309          GOTO 9999
17310       ENDIF
17311
17312 * transform final state particles back into Lab.
17313       DO 4 I=1,IRH
17314          NFSP = NFSP+1
17315          PX   = CXRH(I)*PLRH(I)
17316          PY   = CYRH(I)*PLRH(I)
17317          PZ   = CZRH(I)*PLRH(I)
17318          CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3),
17319      &               PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP),
17320      &               PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP))
17321          IDFSP(NFSP) = ITRH(I)
17322          AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2-
17323      &                                            PFSP(3,NFSP)**2
17324          IF (AMFSP2.LT.-TINY3) THEN
17325             WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP),
17326      &                       PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2
17327  1002       FORMAT(1X,'HADRIN:   warning! final state particle (id = ',
17328      &             I2,') with negative mass^2',/,1X,5E12.4)
17329             GOTO 9999
17330          ELSE
17331             PFSP(5,NFSP) = SQRT(ABS(AMFSP2))
17332             IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN
17333                WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
17334      &                          PFSP(5,NFSP)
17335  1003          FORMAT(1X,'HADRIN:   warning! final state particle',
17336      &                ' (id = ',I2,') with inconsistent mass',/,1X,
17337      &                2E12.4)
17338                KCORR         = KCORR+1
17339                IF (KCORR.GT.2) GOTO 9999
17340                IMCORR(KCORR) = NFSP
17341             ENDIF
17342          ENDIF
17343 *   dump final state particles for energy-momentum cons. check
17344          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
17345      &                           -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
17346     4 CONTINUE
17347
17348 * transform momenta on mass shell in case of inconsistencies in
17349 * HADRIN
17350       IF (KCORR.GT.0) THEN
17351          IF (KCORR.EQ.2) THEN
17352             I1 = IMCORR(1)
17353             I2 = IMCORR(2)
17354          ELSE
17355             IF (IMCORR(1).EQ.1) THEN
17356                I1 = 1
17357                I2 = 2
17358             ELSE
17359                I1 = 1
17360                I2 = IMCORR(1)
17361             ENDIF
17362          ENDIF
17363          IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1),
17364      &                           PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM)
17365          IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2),
17366      &                           PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM)
17367          DO 5 K=1,4
17368             P1IN(K) = PFSP(K,I1)
17369             P2IN(K) = PFSP(K,I2)
17370     5    CONTINUE
17371          XM1 = AAM(IDFSP(I1))
17372          XM2 = AAM(IDFSP(I2))
17373          CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
17374          IF (IREJ1.GT.0) THEN
17375             WRITE(LOUT,'(1X,A)') 'HADRIN:   inconsistent mass trsf.'
17376 C           GOTO 9999
17377          ENDIF
17378          DO 6 K=1,4
17379             PFSP(K,I1) = P1OUT(K)
17380             PFSP(K,I2) = P2OUT(K)
17381     6    CONTINUE
17382          PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2
17383      &                    -PFSP(2,I1)**2-PFSP(3,I1)**2)
17384          PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2
17385      &                    -PFSP(2,I2)**2-PFSP(3,I2)**2)
17386 *   dump final state particles for energy-momentum cons. check
17387          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1),
17388      &                           -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM)
17389          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2),
17390      &                           -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM)
17391       ENDIF
17392
17393 * check energy-momentum conservation
17394       IF (LEMCCK) THEN
17395          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
17396          IF (IREJ1.NE.0) GOTO 9999
17397       ENDIF
17398
17399       RETURN
17400
17401  9998 CONTINUE
17402       IREJ = 2
17403       RETURN
17404
17405  9999 CONTINUE
17406       IREJ = 1
17407       RETURN
17408       END
17409
17410 *$ CREATE DT_HADCOL.FOR
17411 *COPY DT_HADCOL
17412 *
17413 *===hadcol=============================================================*
17414 *
17415       SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
17416
17417 ************************************************************************
17418 * Interface to the HADRIN-routines for inelastic and elastic           *
17419 * scattering. This subroutine samples hadron-nucleus interactions      *
17420 * below DPM-threshold.                                                 *
17421 *      IDPROJ        BAMJET-index of projectile hadron                 *
17422 *      PPN           projectile momentum in target rest frame          *
17423 *      IDXTAR        DTEVT1-index of target nucleon undergoing         *
17424 *                    interaction with projectile hadron                *
17425 * This subroutine replaces HADHAD.                                     *
17426 * This version dated 5.5.95 is written by S. Roesler                   *
17427 ************************************************************************
17428
17429       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17430       SAVE
17431       PARAMETER ( LINP = 10 ,
17432      &            LOUT = 6 ,
17433      &            LDAT = 9 )
17434       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0)
17435
17436       LOGICAL LSTART
17437
17438 * event history
17439       PARAMETER (NMXHKK=200000)
17440       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17441      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17442      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17443 * extended event history
17444       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17445      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17446      &                IHIST(2,NMXHKK)
17447 * nuclear potential
17448       LOGICAL LFERMI
17449       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17450      &                EBINDP(2),EBINDN(2),EPOT(2,210),
17451      &                ETACOU(2),ICOUL,LFERMI
17452 * interface HADRIN-DPM
17453       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
17454 * parameter for intranuclear cascade
17455       LOGICAL LPAULI
17456       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
17457 * final state after inc step
17458       PARAMETER (MAXFSP=10)
17459       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17460 * particle properties (BAMJET index convention)
17461       CHARACTER*8  ANAME
17462       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17463      &                IICH(210),IIBAR(210),K1(210),K2(210)
17464
17465       DIMENSION PPROJ(5),PNUC(5)
17466
17467       DATA LSTART /.TRUE./
17468
17469       IREJ   = 0
17470
17471       NPOINT(1) = NHKK+1
17472
17473       TAUSAV = TAUFOR
17474 **sr 6/9/01 commented
17475 C     TAUFOR = TAUFOR/2.0D0
17476 **
17477       IF (LSTART) THEN
17478          WRITE(LOUT,1000)
17479  1000    FORMAT(/,1X,'HADCOL:  Scattering handled by HADRIN')
17480          WRITE(LOUT,1001) TAUFOR
17481  1001    FORMAT(/,1X,'HADCOL:  Formation zone parameter set to ',
17482      &          F5.1,' fm/c')
17483          LSTART = .FALSE.
17484       ENDIF
17485
17486       IDNUC  = IDBAM(IDXTAR)
17487       IDNUC1 = IDT_MCHAD(IDNUC)
17488       IDPRO1 = IDT_MCHAD(IDPROJ)
17489
17490       IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
17491          IPROC = INTHAD
17492       ELSE
17493 **
17494 C        CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
17495 C        CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
17496          DUMZER = ZERO
17497          CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
17498          SIGIN = SIGTOT-SIGEL
17499 C        SIGTOT = SIGIN+SIGEL
17500 **
17501          IPROC  = 1
17502          IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
17503       ENDIF
17504
17505       PPROJ(1) = ZERO
17506       PPROJ(2) = ZERO
17507       PPROJ(3) = PPN
17508       PPROJ(5) = AAM(IDPROJ)
17509       PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
17510       DO 1 K=1,5
17511          PNUC(K)  = PHKK(K,IDXTAR)
17512     1 CONTINUE
17513
17514       ILOOP = 0
17515     2 CONTINUE
17516       ILOOP = ILOOP+1
17517       IF (ILOOP.GT.100) GOTO 9999
17518
17519       CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
17520       IF (IREJ1.EQ.1) GOTO 9999
17521
17522       IF (IREJ1.GT.1) THEN
17523 * no interaction possible
17524 *   require Pauli blocking
17525          IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2
17526          IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2
17527          IF ((IIBAR(IDPROJ).NE.1).AND.
17528      &       (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5)))              GOTO 2
17529 *   store incoming particle as final state particle
17530          CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3)
17531          CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0)
17532          NPOINT(4) = NHKK
17533       ELSE
17534 * require Pauli blocking for final state nucleons
17535          DO 4 I=1,NFSP
17536             IF ((IDFSP(I).EQ.1).AND.
17537      &          (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I))))       GOTO 2
17538             IF ((IDFSP(I).EQ.8).AND.
17539      &          (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I))))       GOTO 2
17540             IF ((IIBAR(IDFSP(I)).NE.1).AND.
17541      &          (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2
17542     4    CONTINUE
17543 * store final state particles
17544          DO 5 I=1,NFSP
17545             IST = 1
17546             IF ((IIBAR(IDFSP(I)).EQ.1).AND.
17547      &          (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16
17548             IDHAD = IDT_IPDGHA(IDFSP(I))
17549             CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3)
17550             CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I),
17551      &                                        PCMS,ECMS,0,0,0)
17552             IF (I.EQ.1) NPOINT(4) = NHKK
17553             VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR))
17554             VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR))
17555             VHKK(3,NHKK) = VHKK(3,IDXTAR)
17556             VHKK(4,NHKK) = VHKK(4,IDXTAR)
17557             WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR))
17558             WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR))
17559             WHKK(3,NHKK) = WHKK(3,1)
17560             WHKK(4,NHKK) = WHKK(4,1)
17561     5    CONTINUE
17562       ENDIF
17563       TAUFOR = TAUSAV
17564       RETURN
17565
17566  9999 CONTINUE
17567       IREJ = 1
17568       TAUFOR = TAUSAV
17569       RETURN
17570       END
17571
17572 *$ CREATE DT_GETEMU.FOR
17573 *COPY DT_GETEMU
17574 *
17575 *===getemu=============================================================*
17576 *
17577       SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
17578
17579 ************************************************************************
17580 * Sampling of emulsion component to be considered as target-nucleus.   *
17581 * This version dated 6.5.95   is written by S. Roesler.                *
17582 ************************************************************************
17583
17584       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17585       SAVE
17586       PARAMETER ( LINP = 10 ,
17587      &            LOUT = 6 ,
17588      &            LDAT = 9 )
17589       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
17590
17591       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
17592 * emulsion treatment
17593       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
17594      &                NCOMPO,IEMUL
17595 * Glauber formalism: flags and parameters for statistics
17596       LOGICAL LPROD
17597       CHARACTER*8 CGLB
17598       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
17599
17600       IF (MODE.EQ.0) THEN
17601          SUMFRA = ZERO
17602          RR = DT_RNDM(SUMFRA)
17603          IT  = 0
17604          ITZ = 0
17605          DO 1 ICOMP=1,NCOMPO
17606             SUMFRA = SUMFRA+EMUFRA(ICOMP)
17607             IF (SUMFRA.GT.RR) THEN
17608                IT    = IEMUMA(ICOMP)
17609                ITZ   = IEMUCH(ICOMP)
17610                KKMAT = ICOMP
17611                GOTO 2
17612             ENDIF
17613     1    CONTINUE
17614     2    CONTINUE
17615          IF (IT.LE.0) THEN
17616             WRITE(LOUT,'(1X,A,E12.3)')
17617      &       'Warning!  norm. failure within emulsion fractions',
17618      &       SUMFRA
17619             STOP
17620          ENDIF
17621       ELSEIF (MODE.EQ.1) THEN
17622          NDIFF = 10000
17623          DO 3 I=1,NCOMPO
17624             IDIFF = ABS(IT-IEMUMA(I))
17625             IF (IDIFF.LT.NDIFF) THEN
17626                KKMAT = I
17627                NDIFF = IDIFF
17628             ENDIF
17629     3    CONTINUE
17630       ELSE
17631          STOP 'DT_GETEMU'
17632       ENDIF
17633
17634 * bypass for variable projectile/target/energy runs: the correct
17635 * Glauber data will be always loaded on kkmat=1
17636       IF (IOGLB.EQ.100) THEN
17637          KKMAT = 1
17638       ENDIF
17639
17640       RETURN
17641       END
17642
17643 *$ CREATE DT_NCLPOT.FOR
17644 *COPY DT_NCLPOT
17645 *
17646 *===nclpot=============================================================*
17647 *
17648       SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
17649
17650 ************************************************************************
17651 * Calculation of Coulomb and nuclear potential for a given configurat. *
17652 *               IPZ, IP       charge/mass number of proj.              *
17653 *               ITZ, IT       charge/mass number of targ.              *
17654 *               AFERP,AFERT   factors modifying proj./target pot.      *
17655 *                             if =0, FERMOD is used                    *
17656 *               MODE = 0      calculation of binding energy            *
17657 *                    = 1      pre-calculated binding energy is used    *
17658 * This version dated 16.11.95  is written by S. Roesler.               *
17659 *                                                                      *
17660 * Last change 28.12.2006 by S. Roesler.                                *
17661 ************************************************************************
17662
17663       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17664       SAVE
17665       PARAMETER ( LINP = 10 ,
17666      &            LOUT = 6 ,
17667      &            LDAT = 9 )
17668       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
17669      &           TINY10=1.0D-10)
17670
17671       LOGICAL LSTART
17672
17673 * particle properties (BAMJET index convention)
17674       CHARACTER*8  ANAME
17675       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17676      &                IICH(210),IIBAR(210),K1(210),K2(210)
17677 * nuclear potential
17678       LOGICAL LFERMI
17679       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17680      &                EBINDP(2),EBINDN(2),EPOT(2,210),
17681      &                ETACOU(2),ICOUL,LFERMI
17682
17683       DIMENSION IDXPOT(14)
17684 *                   ap   an  lam  alam sig- sig+ sig0 tet0 tet- asig-
17685       DATA IDXPOT /   2,   9,  17,  18,  20,  21,  22,  97,  98,  99,
17686 *                 asig0 asig+ atet0 atet+
17687      &              100, 101, 102, 103/
17688
17689       DATA AN     /0.4D0/
17690       DATA LSTART /.TRUE./
17691
17692       IF (MODE.EQ.0) THEN
17693          EBINDP(1) = ZERO
17694          EBINDN(1) = ZERO
17695          EBINDP(2) = ZERO
17696          EBINDN(2) = ZERO
17697       ENDIF
17698       AIP  = DBLE(IP)
17699       AIPZ = DBLE(IPZ)
17700       AIT  = DBLE(IT)
17701       AITZ = DBLE(ITZ)
17702
17703       FERMIP = AFERP
17704       IF (AFERP.LE.ZERO) FERMIP = FERMOD
17705       FERMIT = AFERT
17706       IF (AFERT.LE.ZERO) FERMIT = FERMOD
17707
17708 * Fermi momenta and binding energy for projectile
17709       IF ((IP.GT.1).AND.LFERMI) THEN
17710          IF (MODE.EQ.0) THEN
17711 C           EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
17712 C           EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
17713             BIP  = AIP -ONE
17714             BIPZ = AIPZ-ONE
17715             EBINDP(1) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIP,BIPZ)
17716      &                                            -DT_ENERGY(AIP,AIPZ))
17717             IF (AIP.LE.AIPZ) THEN
17718                EBINDN(1) = EBINDP(1)
17719                WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
17720             ELSE
17721                EBINDN(1) = 1.0D-3*(DT_ENERGY(ONE,ZERO)
17722      &                     +DT_ENERGY(BIP,AIPZ)-DT_ENERGY(AIP,AIPZ))
17723             ENDIF
17724          ENDIF
17725          PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
17726          PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
17727       ELSE
17728          PFERMP(1) = ZERO
17729          PFERMN(1) = ZERO
17730       ENDIF
17731 * effective nuclear potential for projectile
17732 C     EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
17733 C     EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
17734       EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1)
17735       EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1)
17736
17737 * Fermi momenta and binding energy for target
17738       IF ((IT.GT.1).AND.LFERMI) THEN
17739          IF (MODE.EQ.0) THEN
17740 C           EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
17741 C           EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
17742             BIT  = AIT -ONE
17743             BITZ = AITZ-ONE
17744
17745             EBINDP(2) = 1.0D-3*(DT_ENERGY(ONE,ONE)+DT_ENERGY(BIT,BITZ)
17746      &                                            -DT_ENERGY(AIT,AITZ))
17747
17748             IF (AIT.LE.AITZ) THEN
17749                EBINDN(2) = EBINDP(2)
17750                WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
17751             ELSE
17752
17753                EBINDN(2) = 1.0D-3*(DT_ENERGY(ONE,ZERO)
17754      &                     +DT_ENERGY(BIT,AITZ)-DT_ENERGY(AIT,AITZ))
17755
17756             ENDIF
17757          ENDIF
17758          PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
17759          PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
17760       ELSE
17761          PFERMP(2) = ZERO
17762          PFERMN(2) = ZERO
17763       ENDIF
17764 * effective nuclear potential for target
17765 C     EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
17766 C     EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
17767       EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2)
17768       EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2)
17769
17770       DO 2 I=1,14
17771          EPOT(1,IDXPOT(I)) = EPOT(1,8)
17772          EPOT(2,IDXPOT(I)) = EPOT(2,8)
17773     2 CONTINUE
17774
17775 * Coulomb energy
17776       ETACOU(1) = ZERO
17777       ETACOU(2) = ZERO
17778       IF (ICOUL.EQ.1) THEN
17779          IF (IP.GT.1)
17780      &   ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
17781          IF (IT.GT.1)
17782      &   ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
17783       ENDIF
17784
17785       IF (LSTART) THEN
17786          WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN,
17787      &                    EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2),
17788      &                    EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2),
17789      &                    FERMOD,ETACOU
17790  1000    FORMAT(/,/,1X,'NCLPOT:    quantities for inclusion of nuclear'
17791      &           ,' effects',/,12X,'---------------------------',
17792      &           '----------------',/,/,38X,'projectile',
17793      &           '      target',/,/,1X,'Mass number / charge',
17794      &           17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy  -',
17795      &           ' proton   (GeV) ',2E14.4,/,17X,'- neutron  (GeV)'
17796      &          ,1X,2E14.4,/,1X,'Fermi-potential - proton   (GeV)',
17797      &           1X,2E14.4,/,17X,'- neutron  (GeV) ',2E14.4,/,/,
17798      &           1X,'Scale factor for Fermi-momentum    ',F4.2,/,
17799      &           /,1X,'Coulomb-energy ',2(E14.4,' GeV  '),/,/)
17800          LSTART = .FALSE.
17801       ENDIF
17802
17803       RETURN
17804       END
17805
17806 *$ CREATE DT_RESNCL.FOR
17807 *COPY DT_RESNCL
17808 *
17809 *===resncl=============================================================*
17810 *
17811       SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
17812
17813 ************************************************************************
17814 * Treatment of residual nuclei and nuclear effects.                    *
17815 *         MODE = 1     initializations                                 *
17816 *              = 2     treatment of final state                        *
17817 * This version dated 16.11.95 is written by S. Roesler.                *
17818 *                                                                      *
17819 * Last change 05.01.2007 by S. Roesler.                                *
17820 ************************************************************************
17821
17822       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17823       SAVE
17824       PARAMETER ( LINP = 10 ,
17825      &            LOUT = 6 ,
17826      &            LDAT = 9 )
17827       PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
17828      &           TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10,
17829      &           ONETHI=ONE/THREE)
17830       PARAMETER (AMUAMU = 0.93149432D0,
17831      &           FM2MM  = 1.0D-12,
17832      &           RNUCLE = 1.12D0)
17833       PARAMETER ( EMVGEV = 1.0                D-03 )
17834       PARAMETER ( AMUGEV = 0.93149432         D+00 )
17835       PARAMETER ( AMPRTN = 0.93827231         D+00 )
17836       PARAMETER ( AMNTRN = 0.93956563         D+00 )
17837       PARAMETER ( AMELCT = 0.51099906         D-03 )
17838       PARAMETER ( HLFHLF = 0.5D+00 )
17839       PARAMETER ( FERTHO = 14.33       D-09 )
17840       PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
17841       PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
17842       PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
17843
17844 * event history
17845       PARAMETER (NMXHKK=200000)
17846       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17847      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17848      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17849 * extended event history
17850       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17851      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17852      &                IHIST(2,NMXHKK)
17853 * particle properties (BAMJET index convention)
17854       CHARACTER*8  ANAME
17855       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17856      &                IICH(210),IIBAR(210),K1(210),K2(210)
17857 * flags for input different options
17858       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17859       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17860      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17861 * nuclear potential
17862       LOGICAL LFERMI
17863       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17864      &                EBINDP(2),EBINDN(2),EPOT(2,210),
17865      &                ETACOU(2),ICOUL,LFERMI
17866 * properties of interacting particles
17867       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
17868 * properties of photon/lepton projectiles
17869       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
17870 * Lorentz-parameters of the current interaction
17871       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
17872      &                UMO,PPCM,EPROJ,PPROJ
17873 * treatment of residual nuclei: wounded nucleons
17874       COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
17875 * treatment of residual nuclei: 4-momenta
17876       LOGICAL LRCLPR,LRCLTA
17877       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
17878      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
17879
17880       DIMENSION PFSP(4),PSEC(4),PSEC0(4)
17881       DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
17882      &          IDXCOR(15000),IDXOTH(NMXHKK)
17883
17884       GOTO (1,2) MODE
17885
17886 *------- initializations
17887     1 CONTINUE
17888
17889 * initialize arrays for residual nuclei
17890       DO 10 K=1,5
17891          IF (K.LE.4) THEN
17892             PFSP(K)     = ZERO
17893          ENDIF
17894          PINIPR(K) = ZERO
17895          PINITA(K) = ZERO
17896          PRCLPR(K) = ZERO
17897          PRCLTA(K) = ZERO
17898          TRCLPR(K) = ZERO
17899          TRCLTA(K) = ZERO
17900    10 CONTINUE
17901       SCPOT = ONE
17902       NLOOP = 0
17903
17904 * correction of projectile 4-momentum for effective target pot.
17905 * and Coulomb-energy (in case of hadron-nucleus interaction only)
17906       IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
17907          EPNI = EPN
17908 *   Coulomb-energy:
17909 *     positively charged hadron - check energy for Coloumb pot.
17910          IF (IICH(IJPROJ).EQ.1) THEN
17911             THRESH = ETACOU(2)+AAM(IJPROJ)
17912             IF (EPNI.LE.THRESH) THEN
17913                WRITE(LOUT,1000)
17914  1000          FORMAT(/,1X,'KKINC:  WARNING!  projectile energy',
17915      &                ' below Coulomb threshold - event rejected',/)
17916                ISTHKK(1) = 1
17917                RETURN
17918             ENDIF
17919 *     negatively charged hadron - increase energy by Coulomb energy
17920          ELSEIF (IICH(IJPROJ).EQ.-1) THEN
17921             EPNI = EPNI+ETACOU(2)
17922          ENDIF
17923          IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN
17924 *   Effective target potential
17925 *sr 6.6. binding energy only (to avoid negative exc. energies)
17926 C           EPNI = EPNI+EPOT(2,IJPROJ)
17927             EBIPOT = EBINDP(2)
17928             IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3))
17929      &         EBIPOT = EBINDN(2)
17930             EPNI = EPNI+ABS(EBIPOT)
17931 * re-initialization of DTLTRA
17932             DUM1 = ZERO
17933             DUM2 = ZERO
17934             CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
17935          ENDIF
17936       ENDIF
17937
17938 * projectile in n-n cms
17939       IF ((IP.LE.1).AND.(IT.GT.1)) THEN
17940          PMASS1 = AAM(IJPROJ)
17941 C* VDM assumption
17942 C         IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
17943          IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
17944          PMASS2 = AAM(1)
17945          PM1 = SIGN(PMASS1**2,PMASS1)
17946          PM2 = SIGN(PMASS2**2,PMASS2)
17947          PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
17948          PINIPR(5) = PMASS1
17949          IF (PMASS1.GT.ZERO) THEN
17950             PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
17951      &                      *(PINIPR(4)+PINIPR(5)))
17952          ELSE
17953             PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
17954          ENDIF
17955          AIT  = DBLE(IT)
17956          AITZ = DBLE(ITZ)
17957          PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ)
17958          CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
17959       ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
17960          PMASS1 = AAM(1)
17961          PMASS2 = AAM(IJTARG)
17962          PM1 = SIGN(PMASS1**2,PMASS1)
17963          PM2 = SIGN(PMASS2**2,PMASS2)
17964          PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO)
17965          PINITA(5) = PMASS2
17966          PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
17967      &                    *(PINITA(4)+PINITA(5)))
17968          AIP  = DBLE(IP)
17969          AIPZ = DBLE(IPZ)
17970          PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ)
17971          CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
17972       ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
17973          AIP  = DBLE(IP)
17974          AIPZ = DBLE(IPZ)
17975          PINIPR(5) = AIP*AMUAMU+1.0D-3*DT_ENERGY(AIP,AIPZ)
17976          CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
17977          AIT  = DBLE(IT)
17978          AITZ = DBLE(ITZ)
17979          PINITA(5) = AIT*AMUAMU+1.0D-3*DT_ENERGY(AIT,AITZ)
17980          CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
17981       ENDIF
17982
17983       RETURN
17984
17985 *------- treatment of final state
17986     2 CONTINUE
17987
17988       NLOOP = NLOOP+1
17989       IF (NLOOP.GT.1) SCPOT = 0.10D0
17990 C     WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
17991
17992       JPW  = NPW
17993       JPCW = NPCW
17994       JTW  = NTW
17995       JTCW = NTCW
17996       DO 40 K=1,4
17997          PFSP(K)   = ZERO
17998    40 CONTINUE
17999
18000       NOB = 0
18001       NOM = 0
18002       DO 900 I=NPOINT(4),NHKK
18003          IDXOTH(I) = -1
18004          IF (ISTHKK(I).EQ.1) THEN
18005             IF (IDBAM(I).EQ.7) GOTO 900
18006             IPOT = 0
18007             IOTHER = 0
18008 * particle moving into forward direction
18009             IF (PHKK(3,I).GE.ZERO) THEN
18010 *   most likely to be effected by projectile potential
18011                IPOT = 1
18012 *     there is no projectile nucleus, try target
18013                IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
18014                   IPOT   = 2
18015                   IF (IP.GT.1) IOTHER = 1
18016 *       there is no target nucleus --> skip
18017                   IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900
18018                ENDIF
18019 * particle moving into backward direction
18020             ELSE
18021 *   most likely to be effected by target potential
18022                IPOT = 2
18023 *     there is no target nucleus, try projectile
18024                IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
18025                   IPOT   = 1
18026                   IF (IT.GT.1) IOTHER = 1
18027 *       there is no projectile nucleus --> skip
18028                   IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900
18029                ENDIF
18030             ENDIF
18031             IFLG = -IPOT
18032 * nobam=3: particle is in overlap-region or neither inside proj. nor target
18033 *      =1: particle is not in overlap-region AND is inside target (2)
18034 *      =2: particle is not in overlap-region AND is inside projectile (1)
18035 * flag particles which are inside the nucleus ipot but not in its
18036 * overlap region
18037             IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT
18038             IF (IDBAM(I).NE.0) THEN
18039 * baryons: keep all nucleons and all others where flag is set
18040                IF (IIBAR(IDBAM(I)).NE.0) THEN
18041                   IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0))
18042      &                                                              THEN
18043                      NOB = NOB+1
18044                      PMOMB(NOB) = PHKK(3,I)
18045                      IDXB(NOB)  = SIGN(10000000*IABS(IFLG)
18046      &                           +1000000*IOTHER+I,IFLG)
18047                   ENDIF
18048 * mesons: keep only those mesons where flag is set
18049                ELSE
18050                   IF (IFLG.GT.0) THEN
18051                      NOM = NOM+1
18052                      PMOMM(NOM) = PHKK(3,I)
18053                      IDXM(NOM)  = 10000000*IFLG+1000000*IOTHER+I
18054                   ENDIF
18055                ENDIF
18056             ENDIF
18057          ENDIF
18058   900 CONTINUE
18059 *
18060 * sort particles in the arrays according to increasing long. momentum
18061       CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1)
18062       CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1)
18063 *
18064 * shuffle indices into one and the same array according to the later
18065 * sequence of correction
18066       NCOR = 0
18067       IF (IT.GT.1) THEN
18068          DO 910 I=1,NOB
18069             IF (PMOMB(I).GT.ZERO) GOTO 911
18070             NCOR = NCOR+1
18071             IDXCOR(NCOR) = IDXB(I)
18072   910    CONTINUE
18073   911    CONTINUE
18074          IF (IP.GT.1) THEN
18075             DO 912 J=1,NOB
18076                I = NOB+1-J
18077                IF (PMOMB(I).LT.ZERO) GOTO 913
18078                NCOR = NCOR+1
18079                IDXCOR(NCOR) = IDXB(I)
18080   912       CONTINUE
18081   913       CONTINUE
18082          ELSE
18083             DO 914 I=1,NOB
18084                IF (PMOMB(I).GT.ZERO) THEN
18085                   NCOR = NCOR+1
18086                   IDXCOR(NCOR) = IDXB(I)
18087                ENDIF
18088   914       CONTINUE
18089          ENDIF
18090       ELSE
18091          DO 915 J=1,NOB
18092             I = NOB+1-J
18093             NCOR = NCOR+1
18094             IDXCOR(NCOR) = IDXB(I)
18095   915    CONTINUE
18096       ENDIF
18097       DO 925 I=1,NOM
18098          IF (PMOMM(I).GT.ZERO) GOTO 926
18099          NCOR = NCOR+1
18100          IDXCOR(NCOR) = IDXM(I)
18101   925 CONTINUE
18102   926 CONTINUE
18103       DO 927 J=1,NOM
18104          I = NOM+1-J
18105          IF (PMOMM(I).LT.ZERO) GOTO 928
18106          NCOR = NCOR+1
18107          IDXCOR(NCOR) = IDXM(I)
18108   927 CONTINUE
18109   928 CONTINUE
18110 *
18111 C      IF (NEVHKK.EQ.484) THEN
18112 C         WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
18113 C 9000    FORMAT(1X,'wounded nucleons (proj.-p,n  targ.-p,n)',/,4I10)
18114 C         WRITE(LOUT,9001) NOB,NOM,NCOR
18115 C 9001    FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
18116 C         WRITE(LOUT,'(/,A)') ' baryons '
18117 C         DO 950 I=1,NOB
18118 CC           J     = IABS(IDXB(I))
18119 CC           INDEX = J-IABS(J/10000000)*10000000
18120 C            IPOT   = IABS(IDXB(I))/10000000
18121 C            IOTHER = IABS(IDXB(I))/1000000-IPOT*10
18122 C            INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000
18123 C            WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
18124 C  950    CONTINUE
18125 C         WRITE(LOUT,'(/,A)') ' mesons '
18126 C         DO 951 I=1,NOM
18127 CC           INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000
18128 C            IPOT   = IABS(IDXM(I))/10000000
18129 C            IOTHER = IABS(IDXM(I))/1000000-IPOT*10
18130 C            INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000
18131 C            WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
18132 C  951    CONTINUE
18133 C 9002    FORMAT(1X,4I14,E14.5)
18134 C         WRITE(LOUT,'(/,A)') ' all '
18135 C         DO 952 I=1,NCOR
18136 CC           J     = IABS(IDXCOR(I))
18137 CC           INDEX = J-IABS(J/10000000)*10000000
18138 CC            IPOT   = IABS(IDXCOR(I))/10000000
18139 C            IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10
18140 C            INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000
18141 C            WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
18142 C  952    CONTINUE
18143 C 9003    FORMAT(1X,4I14)
18144 C      ENDIF
18145 *
18146       DO 20 ICOR=1,NCOR
18147          IPOT   = IABS(IDXCOR(ICOR))/10000000
18148          IOTHER = IABS(IDXCOR(ICOR))/1000000-IPOT*10
18149          I = IABS(IDXCOR(ICOR))-IPOT*10000000-IOTHER*1000000
18150          IDXOTH(I) = 1
18151
18152          IDSEC  = IDBAM(I)
18153
18154 * reduction of particle momentum by corresponding nuclear potential
18155 * (this applies only if Fermi-momenta are requested)
18156
18157          IF (LFERMI) THEN
18158
18159 *   Lorentz-transformation into the rest system of the selected nucleus
18160             IMODE = -IPOT-1
18161             CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18162      &                  PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE)
18163             PSECO  = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2)
18164             AMSEC  = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO)))
18165             JPMOD  = 0
18166
18167             CHKLEV = TINY3
18168             IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1
18169             IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0
18170             IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN
18171                IF (IOULEV(3).GT.0)
18172      &            WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
18173  2000          FORMAT(1X,'RESNCL: inconsistent mass of particle',
18174      &                ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
18175      &                I4,'   AMSEC: ',E12.3,'  AAM(IDSEC): ',E12.3,/)
18176                GOTO 23
18177             ENDIF
18178
18179             DO 21 K=1,4
18180                PSEC0(K) = PSEC(K)
18181    21       CONTINUE
18182
18183 *   the correction for nuclear potential effects is applied to as many
18184 *   p/n as many nucleons were wounded; the momenta of other final state
18185 *   particles are corrected only if they materialize inside the corresp.
18186 *   nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
18187 *   = 3 part. outside proj. and targ., >=10 in overlapping region)
18188             IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN
18189                IF (IPOT.EQ.1) THEN
18190                   IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN
18191 *      this is most likely a wounded nucleon
18192 **test
18193 C                    RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
18194 C    &                           +(VHKK(2,IPW(JPW))/FM2MM)**2
18195 C    &                           +(VHKK(3,IPW(JPW))/FM2MM)**2)
18196 C                    RAD   = RNUCLE*DBLE(IP)**ONETHI
18197 C                    FDEN  = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
18198 C                    PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18199 **
18200                      PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18201                      JPW = JPW-1
18202                      JPMOD = 1
18203                   ELSE
18204 *      correct only if part. was materialized inside nucleus
18205 *      and if it is ouside the overlapping region
18206                      IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN
18207                         PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18208                         JPMOD = 1
18209                      ENDIF
18210                   ENDIF
18211                ELSEIF (IPOT.EQ.2) THEN
18212                   IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
18213 *      this is most likely a wounded nucleon
18214 **test
18215 C                    RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
18216 C    &                           +(VHKK(2,ITW(JTW))/FM2MM)**2
18217 C    &                           +(VHKK(3,ITW(JTW))/FM2MM)**2)
18218 C                    RAD   = RNUCLE*DBLE(IT)**ONETHI
18219 C                    FDEN  = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
18220 C                    PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
18221 **
18222                      PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18223                      JTW = JTW-1
18224                      JPMOD = 1
18225                   ELSE
18226 *      correct only if part. was materialized inside nucleus
18227                      IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN
18228                         PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18229                         JPMOD = 1
18230                      ENDIF
18231                   ENDIF
18232                ENDIF
18233             ELSE
18234                IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
18235                   PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
18236                   JPMOD = 1
18237                ENDIF
18238             ENDIF
18239
18240             IF (NLOOP.EQ.1) THEN
18241 * Coulomb energy correction:
18242 * the treatment of Coulomb potential correction is similar to the
18243 * one for nuclear potential
18244                IF (IDSEC.EQ.1) THEN
18245                   IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN
18246                      JPCW = JPCW-1
18247                   ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
18248                      JTCW = JTCW-1
18249                   ELSE
18250                      IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18251                   ENDIF
18252                ELSE
18253                   IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
18254                ENDIF
18255                IF (IICH(IDSEC).EQ.1) THEN
18256 *    pos. particles: check if they are able to escape Coulomb potential
18257                   IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN
18258                      ISTHKK(I) = 14+IPOT
18259                      IF (ISTHKK(I).EQ.15) THEN
18260                         DO 26 K=1,4
18261                            PHKK(K,I) = PSEC0(K)
18262                            TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18263    26                CONTINUE
18264                         IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18265                         IF (IDSEC.EQ.1) NPCW = NPCW-1
18266                      ELSEIF (ISTHKK(I).EQ.16) THEN
18267                         DO 27 K=1,4
18268                            PHKK(K,I) = PSEC0(K)
18269                            TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18270    27                   CONTINUE
18271                         IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18272                         IF (IDSEC.EQ.1) NTCW = NTCW-1
18273                      ENDIF
18274                      GOTO 20
18275                   ENDIF
18276                ELSEIF (IICH(IDSEC).EQ.-1) THEN
18277 *    neg. particles: decrease energy by Coulomb-potential
18278                   PSEC(4) = PSEC(4)-ETACOU(IPOT)
18279                   JPMOD = 1
18280                ENDIF
18281             ENDIF
18282
18283    25       CONTINUE
18284
18285             IF (PSEC(4).LT.AMSEC) THEN
18286                IF (IOULEV(6).GT.0)
18287      &            WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
18288  2001          FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5,
18289      &                ' is not allowed to escape nucleus',/,
18290      &                8X,'id : ',I3,'   reduced energy: ',E15.4,
18291      &                '   mass: ',E12.3)
18292                ISTHKK(I) = 14+IPOT
18293                IF (ISTHKK(I).EQ.15) THEN
18294                   DO 28 K=1,4
18295                      PHKK(K,I) = PSEC0(K)
18296                      TRCLPR(K) = TRCLPR(K)+PSEC0(K)
18297    28             CONTINUE
18298                   IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
18299                   IF (IDSEC.EQ.1) NPCW = NPCW-1
18300                ELSEIF (ISTHKK(I).EQ.16) THEN
18301                   DO 29 K=1,4
18302                      PHKK(K,I) = PSEC0(K)
18303                      TRCLTA(K) = TRCLTA(K)+PSEC0(K)
18304    29             CONTINUE
18305                   IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
18306                   IF (IDSEC.EQ.1) NTCW = NTCW-1
18307                ENDIF
18308                GOTO 20
18309             ENDIF
18310
18311             IF (JPMOD.EQ.1) THEN
18312                PSECN  = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
18313 * 4-momentum after correction for nuclear potential
18314                DO 22 K=1,3
18315                   PSEC(K) = PSEC(K)*PSECN/PSECO
18316    22          CONTINUE
18317
18318 * store recoil momentum from particles escaping the nuclear potentials
18319                DO 30 K=1,4
18320                   IF (IPOT.EQ.1) THEN
18321                      TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K)
18322                   ELSEIF (IPOT.EQ.2) THEN
18323                      TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K)
18324                   ENDIF
18325    30          CONTINUE
18326
18327 * transform momentum back into n-n cms
18328                IMODE = IPOT+1
18329                CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4),
18330      &                     PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
18331      &                     IDSEC,IMODE)
18332             ENDIF
18333
18334          ENDIF
18335
18336    23    CONTINUE
18337          DO 31 K=1,4
18338             PFSP(K) = PFSP(K)+PHKK(K,I)
18339    31    CONTINUE
18340
18341    20 CONTINUE
18342
18343       DO 33 I=NPOINT(4),NHKK
18344          IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN
18345             PFSP(1) = PFSP(1)+PHKK(1,I)
18346             PFSP(2) = PFSP(2)+PHKK(2,I)
18347             PFSP(3) = PFSP(3)+PHKK(3,I)
18348             PFSP(4) = PFSP(4)+PHKK(4,I)
18349          ENDIF
18350    33 CONTINUE
18351
18352       DO 34 K=1,5
18353          PRCLPR(K) = TRCLPR(K)
18354          PRCLTA(K) = TRCLTA(K)
18355    34 CONTINUE
18356
18357       IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18358 * hadron-nucleus interactions: get residual momentum from energy-
18359 * momentum conservation
18360          DO 32 K=1,4
18361             PRCLPR(K) = ZERO
18362             PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
18363    32    CONTINUE
18364       ELSE
18365 * nucleus-hadron, nucleus-nucleus: get residual momentum from
18366 * accumulated recoil momenta of particles leaving the spectators
18367 *   transform accumulated recoil momenta of residual nuclei into
18368 *   n-n cms
18369          PZI = PRCLPR(3)
18370          PEI = PRCLPR(4)
18371          CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
18372          PZI = PRCLTA(3)
18373          PEI = PRCLTA(4)
18374          CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
18375 C        IF (IP.GT.1) THEN
18376             PRCLPR(3) = PRCLPR(3)+PINIPR(3)
18377             PRCLPR(4) = PRCLPR(4)+PINIPR(4)
18378 C        ENDIF
18379          IF (IT.GT.1) THEN
18380             PRCLTA(3) = PRCLTA(3)+PINITA(3)
18381             PRCLTA(4) = PRCLTA(4)+PINITA(4)
18382          ENDIF
18383       ENDIF
18384
18385 * check momenta of residual nuclei
18386       IF (LEMCCK) THEN
18387          CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
18388      &               1,IDUM,IDUM)
18389          CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
18390      &               2,IDUM,IDUM)
18391          CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
18392      &               2,IDUM,IDUM)
18393          CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
18394      &               2,IDUM,IDUM)
18395          CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM)
18396 **sr 19.12. changed to avoid output when used with phojet
18397 C        CHKLEV = TINY3
18398          CHKLEV = TINY1
18399          CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
18400 C        IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
18401 C    &      CALL DT_EVTOUT(4)
18402          IF (IREJ1.GT.0) RETURN
18403       ENDIF
18404
18405       RETURN
18406       END
18407
18408 *$ CREATE DT_SCN4BA.FOR
18409 *COPY DT_SCN4BA
18410 *
18411 *===scn4ba=============================================================*
18412 *
18413       SUBROUTINE DT_SCN4BA
18414
18415 ************************************************************************
18416 * SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot.    *
18417 * This version dated 12.12.95 is written by S. Roesler.                *
18418 ************************************************************************
18419
18420       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18421       SAVE
18422       PARAMETER ( LINP = 10 ,
18423      &            LOUT = 6 ,
18424      &            LDAT = 9 )
18425       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
18426      &           TINY10=1.0D-10)
18427
18428 * event history
18429       PARAMETER (NMXHKK=200000)
18430       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18431      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18432      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18433 * extended event history
18434       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18435      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18436      &                IHIST(2,NMXHKK)
18437 * particle properties (BAMJET index convention)
18438       CHARACTER*8  ANAME
18439       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18440      &                IICH(210),IIBAR(210),K1(210),K2(210)
18441 * properties of interacting particles
18442       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18443 * nuclear potential
18444       LOGICAL LFERMI
18445       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18446      &                EBINDP(2),EBINDN(2),EPOT(2,210),
18447      &                ETACOU(2),ICOUL,LFERMI
18448 * treatment of residual nuclei: wounded nucleons
18449       COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18450 * treatment of residual nuclei: 4-momenta
18451       LOGICAL LRCLPR,LRCLTA
18452       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18453      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18454
18455       DIMENSION PLAB(2,5),PCMS(4)
18456
18457       IREJ = 0
18458
18459 * get number of wounded nucleons
18460       NPW    = 0
18461       NPW0   = 0
18462       NPCW   = 0
18463       NPSTCK = 0
18464       NTW    = 0
18465       NTW0   = 0
18466       NTCW   = 0
18467       NTSTCK = 0
18468
18469       ISGLPR = 0
18470       ISGLTA = 0
18471       LRCLPR = .FALSE.
18472       LRCLTA = .FALSE.
18473
18474 C     DO 2 I=1,NHKK
18475       DO 2 I=1,NPOINT(1)
18476 * projectile nucleons wounded in primary interaction and in fzc
18477          IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
18478             NPW      = NPW+1
18479             IPW(NPW) = I
18480             NPSTCK   = NPSTCK+1
18481             IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
18482             IF (ISTHKK(I).EQ.11)  NPW0 = NPW0+1
18483 C           IF (IP.GT.1) THEN
18484                DO 5 K=1,4
18485                   TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
18486     5          CONTINUE
18487 C           ENDIF
18488 * target nucleons wounded in primary interaction and in fzc
18489          ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
18490             NTW      = NTW+1
18491             ITW(NTW) = I
18492             NTSTCK   = NTSTCK+1
18493             IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
18494             IF (ISTHKK(I).EQ.12)  NTW0 = NTW0+1
18495             IF (IT.GT.1) THEN
18496                DO 6 K=1,4
18497                   TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
18498     6          CONTINUE
18499             ENDIF
18500          ELSEIF (ISTHKK(I).EQ.13) THEN
18501             ISGLPR = I
18502          ELSEIF (ISTHKK(I).EQ.14) THEN
18503             ISGLTA = I
18504          ENDIF
18505     2 CONTINUE
18506
18507       DO 11 I=NPOINT(4),NHKK
18508 * baryons which are unable to escape the nuclear potential of proj.
18509          IF (ISTHKK(I).EQ.15) THEN
18510             ISGLPR = I
18511             NPSTCK = NPSTCK-1
18512             IF (IIBAR(IDBAM(I)).NE.0) THEN
18513                NPW    = NPW-1
18514                IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
18515             ENDIF
18516             DO 7 K=1,4
18517                TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18518     7       CONTINUE
18519 * baryons which are unable to escape the nuclear potential of targ.
18520          ELSEIF (ISTHKK(I).EQ.16) THEN
18521             ISGLTA = I
18522             NTSTCK = NTSTCK-1
18523             IF (IIBAR(IDBAM(I)).NE.0) THEN
18524                NTW    = NTW-1
18525                IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
18526             ENDIF
18527             DO 8 K=1,4
18528                TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18529     8       CONTINUE
18530          ENDIF
18531    11 CONTINUE
18532
18533 * residual nuclei so far
18534       IRESP = IP-NPSTCK
18535       IREST = IT-NTSTCK
18536
18537 * ckeck for "residual nuclei" consisting of one nucleon only
18538 * treat it as final state particle
18539       IF (IRESP.EQ.1) THEN
18540          ID  = IDBAM(ISGLPR)
18541          IST = ISTHKK(ISGLPR)
18542          CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR),
18543      &               PHKK(3,ISGLPR),PHKK(4,ISGLPR),
18544      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2)
18545          IF (IST.EQ.13) THEN
18546             ISTHKK(ISGLPR) = 11
18547          ELSE
18548             ISTHKK(ISGLPR) = 2
18549          ENDIF
18550          CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0,
18551      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18552      &               IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR))
18553          NOBAM(NHKK)      = NOBAM(ISGLPR)
18554          JDAHKK(1,ISGLPR) = NHKK
18555          DO 21 K=1,4
18556             TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
18557    21    CONTINUE
18558       ENDIF
18559       IF (IREST.EQ.1) THEN
18560          ID  = IDBAM(ISGLTA)
18561          IST = ISTHKK(ISGLTA)
18562          CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA),
18563      &               PHKK(3,ISGLTA),PHKK(4,ISGLTA),
18564      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3)
18565          IF (IST.EQ.14) THEN
18566             ISTHKK(ISGLTA) = 12
18567          ELSE
18568             ISTHKK(ISGLTA) = 2
18569          ENDIF
18570          CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0,
18571      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),
18572      &               IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA))
18573          NOBAM(NHKK)      = NOBAM(ISGLTA)
18574          JDAHKK(1,ISGLTA) = NHKK
18575          DO 22 K=1,4
18576             TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
18577    22    CONTINUE
18578       ENDIF
18579
18580 * get nuclear potential corresp. to the residual nucleus
18581       IPRCL  = IP -NPW
18582       IPZRCL = IPZ-NPCW
18583       ITRCL  = IT -NTW
18584       ITZRCL = ITZ-NTCW
18585       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
18586
18587 * baryons unable to escape the nuclear potential are treated as
18588 * excited nucleons (ISTHKK=15,16)
18589       DO 3 I=NPOINT(4),NHKK
18590          IF (ISTHKK(I).EQ.1) THEN
18591             ID  = IDBAM(I)
18592             IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN
18593 *   final state n and p not being outside of both nuclei are considered
18594                NPOTP = 1
18595                NPOTT = 1
18596                IF ( (IP.GT.1)      .AND.(IRESP.GT.1).AND.
18597      &              (NOBAM(I).NE.1).AND.(NPW.GT.0)        ) THEN
18598 *     Lorentz-trsf. into proj. rest sys. for those being inside proj.
18599                   CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18600      &                        PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3),
18601      &                        PLAB(1,4),ID,-2)
18602                   PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2)
18603                   PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)*
18604      &                                  (PLAB(1,4)+PLABT) ))
18605                   EKIN = PLAB(1,4)-PLAB(1,5)
18606                   IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15
18607                   IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1
18608                ENDIF
18609                IF ( (IT.GT.1)      .AND.(IREST.GT.1).AND.
18610      &              (NOBAM(I).NE.2).AND.(NTW.GT.0)        ) THEN
18611 *     Lorentz-trsf. into targ. rest sys. for those being inside targ.
18612                   CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
18613      &                        PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3),
18614      &                        PLAB(2,4),ID,-3)
18615                   PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2)
18616                   PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)*
18617      &                                  (PLAB(2,4)+PLABT) ))
18618                   EKIN = PLAB(2,4)-PLAB(2,5)
18619                   IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16
18620                   IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1
18621                ENDIF
18622                IF (PHKK(3,I).GE.ZERO) THEN
18623                   ISTHKK(I) = NPOTT
18624                   IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
18625                ELSE
18626                   ISTHKK(I) = NPOTP
18627                   IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
18628                ENDIF
18629                IF (ISTHKK(I).NE.1) THEN
18630                   J = ISTHKK(I)-14
18631                   DO 4 K=1,5
18632                      PHKK(K,I) = PLAB(J,K)
18633     4             CONTINUE
18634                   IF (ISTHKK(I).EQ.15) THEN
18635                      NPW = NPW-1
18636                      IF (ID.EQ.1) NPCW = NPCW-1
18637                      DO 9 K=1,4
18638                         TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
18639     9                CONTINUE
18640                   ELSEIF (ISTHKK(I).EQ.16) THEN
18641                      NTW = NTW-1
18642                      IF (ID.EQ.1) NTCW = NTCW-1
18643                      DO 10 K=1,4
18644                         TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
18645    10                CONTINUE
18646                   ENDIF
18647                ENDIF
18648             ENDIF
18649          ENDIF
18650     3 CONTINUE
18651
18652 * again: get nuclear potential corresp. to the residual nucleus
18653       IPRCL  = IP -NPW
18654       IPZRCL = IPZ-NPCW
18655       ITRCL  = IT -NTW
18656       ITZRCL = ITZ-NTCW
18657 c      AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
18658 cC     AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
18659 c     &             *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
18660 C     AFERP = 0.0D0
18661 c      AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
18662 cC     AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
18663 c     &             *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
18664 C     AFERT = 0.0D0
18665 C     IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
18666 C     IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
18667 C     IF (AFERP.GT.0.85D0) AFERP = 0.85D0
18668 C     IF (AFERT.GT.0.85D0) AFERT = 0.85D0
18669       AFERP = FERMOD+0.1D0
18670       AFERT = FERMOD+0.1D0
18671
18672       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
18673
18674       RETURN
18675       END
18676
18677 *$ CREATE DT_FICONF.FOR
18678 *COPY DT_FICONF
18679 *
18680 *===ficonf=============================================================*
18681 *
18682       SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
18683
18684 ************************************************************************
18685 * Treatment of FInal CONFiguration including evaporation, fission and  *
18686 * Fermi-break-up (for light nuclei only).                              *
18687 * Adopted from the original routine FINALE and extended to residual    *
18688 * projectile nuclei.                                                   *
18689 * This version dated 12.12.95 is written by S. Roesler.                *
18690 *                                                                      *
18691 * Last change 27.12.2006 by S. Roesler.                                *
18692 ************************************************************************
18693
18694       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18695       SAVE
18696       PARAMETER ( LINP = 10 ,
18697      &            LOUT = 6 ,
18698      &            LDAT = 9 )
18699       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
18700       PARAMETER (ANGLGB=5.0D-16)
18701       PARAMETER (AMUAMU=0.93149432D0,AMELEC=0.51099906D-3)
18702
18703 * event history
18704       PARAMETER (NMXHKK=200000)
18705       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18706      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18707      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18708 * extended event history
18709       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18710      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18711      &                IHIST(2,NMXHKK)
18712 * rejection counter
18713       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
18714      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
18715      &                IREXCI(3),IRDIFF(2),IRINC
18716 * central particle production, impact parameter biasing
18717       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
18718 * particle properties (BAMJET index convention)
18719       CHARACTER*8  ANAME
18720       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18721      &                IICH(210),IIBAR(210),K1(210),K2(210)
18722 * treatment of residual nuclei: 4-momenta
18723       LOGICAL LRCLPR,LRCLTA
18724       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18725      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18726 * treatment of residual nuclei: properties of residual nuclei
18727       COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
18728      &                NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
18729      &                NTOTFI(2),NPROFI(2)
18730 * statistics: residual nuclei
18731       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
18732      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
18733      &                NINCST(2,4),NINCEV(2),
18734      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
18735      &                NRESPB(2),NRESCH(2),NRESEV(4),
18736      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
18737      &                NEVAFI(2,2)
18738 * flags for input different options
18739       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18740       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18741      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18742 * (original name: FINUC)
18743       PARAMETER (MXP=999)
18744       COMMON /FKFINU/ CXR    (MXP), CYR    (MXP), CZR    (MXP),
18745      &                CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
18746      &                TKI    (MXP), PLR    (MXP), WEI    (MXP),
18747      &                TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
18748      &                KPART  (MXP)
18749 * (original name: RESNUC)
18750       LOGICAL LRNFSS, LFRAGM
18751       COMMON /FKRESN/  AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
18752      &                   ANOW,   ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
18753      &                   ERES,  EKRES, AMNRES, AMMRES,  PTRES,  PXRES,
18754      &                  PYRES,  PZRES, PTRES2,  KTARP,  KTARN, IGREYP,
18755      &                 IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
18756      &                  ICRES,  IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
18757      &                 IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
18758      &                  IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
18759      &                 LFRAGM
18760       COMMON /FKNDAT/ AV0WEL,     APFRMX,     AEFRMX,     AEFRMA,
18761      &                RDSNUC,     V0WELL (2), PFRMMX (2), EFRMMX (2),
18762      &                EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
18763      &                VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
18764      &                PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
18765      &                EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
18766      &                ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV    ,
18767      &                AMRCSQ    , ATO1O3    , ZTO1O3    , ELBNDE (0:100)
18768 * (original name: PAREVT)
18769       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
18770      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
18771       PARAMETER ( NALLWP = 39   )
18772       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
18773      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
18774      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
18775      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
18776 * event flag
18777       COMMON /DTEVNO/ NEVENT,ICASCA
18778
18779       DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2),
18780      &          PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4),
18781      &          P1IN(4),P2IN(4),P1OUT(4),P2OUT(4)
18782
18783       DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260)
18784       LOGICAL LLCPOT
18785       DATA EXC,NEXC /520*ZERO,520*0/
18786       DATA EXPNUC /4.0D-3,4.0D-3/
18787
18788       IREJ   = 0
18789       LRCLPR = .FALSE.
18790       LRCLTA = .FALSE.
18791
18792 * skip residual nucleus treatment if not requested or in case
18793 * of central collisions
18794       IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN
18795
18796       DO 1 K=1,2
18797          IDPAR(K) = 0
18798          IDXPAR(K)= 0
18799          NTOT(K)  = 0
18800          NTOTFI(K)= 0
18801          NPRO(K)  = 0
18802          NPROFI(K)= 0
18803          NN(K)    = 0
18804          NH(K)    = 0
18805          NHPOS(K) = 0
18806          NQ(K)    = 0
18807          EEXC(K)  = ZERO
18808          MO1(K)   = 0
18809          MO2(K)   = 0
18810          DO 2 I=1,4
18811             VRCL(K,I) = ZERO
18812             WRCL(K,I) = ZERO
18813     2    CONTINUE
18814     1 CONTINUE
18815       NFSP = 0
18816       INUC(1) = IP
18817       INUC(2) = IT
18818
18819       DO 3 I=1,NHKK
18820
18821 * number of final state particles
18822          IF (ABS(ISTHKK(I)).EQ.1) THEN
18823             NFSP  = NFSP+1
18824             IDFSP = IDBAM(I)
18825          ENDIF
18826
18827 * properties of remaining nucleon configurations
18828          KF = 0
18829          IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1
18830          IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2
18831          IF (KF.GT.0) THEN
18832             IF (MO1(KF).EQ.0) MO1(KF) = I
18833             MO2(KF)  = I
18834 *   position of residual nucleus = average position of nucleons
18835             DO 4 K=1,4
18836                VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
18837                WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
18838     4       CONTINUE
18839 *   total number of particles contributing to each residual nucleus
18840             NTOT(KF)  = NTOT(KF)+1
18841             IDTMP     = IDBAM(I)
18842             IDXTMP    = I
18843 *   total charge of residual nuclei
18844             NQ(KF) = NQ(KF)+IICH(IDTMP)
18845 *   number of protons
18846             IF (IDHKK(I).EQ.2212) THEN
18847                NPRO(KF) = NPRO(KF)+1
18848 *   number of neutrons
18849             ELSEIF (IDHKK(I).EQ.2112) THEN
18850                NN(KF) = NN(KF)+1
18851             ELSE
18852 *   number of baryons other than n, p
18853                IF (IIBAR(IDTMP).EQ.1) THEN
18854                   NH(KF) = NH(KF)+1
18855                   IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
18856                ELSE
18857 *   any other mesons (status set to 1)
18858 C                 WRITE(LOUT,1002) KF,IDTMP
18859 C1002             FORMAT(1X,'FICONF:   residual nucleus ',I2,
18860 C    &                   ' containing meson ',I4,', status set to 1')
18861                   ISTHKK(I) = 1
18862                   IDTMP     = IDPAR(KF)
18863                   IDXTMP    = IDXPAR(KF)
18864                   NTOT(KF)  = NTOT(KF)-1
18865                ENDIF
18866             ENDIF
18867             IDPAR(KF)  = IDTMP
18868             IDXPAR(KF) = IDXTMP
18869          ENDIF
18870     3 CONTINUE
18871
18872 * reject elastic events (def: one final state particle = projectile)
18873       IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN
18874          IREXCI(3) = IREXCI(3)+1
18875          GOTO 9999
18876 C        RETURN
18877       ENDIF
18878
18879 * check if one nucleus disappeared..
18880 C     IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
18881 C        DO 5 K=1,4
18882 C           PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
18883 C           PRCLPR(K) = ZERO
18884 C   5    CONTINUE
18885 C     ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
18886 C        DO 6 K=1,4
18887 C           PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
18888 C           PRCLTA(K) = ZERO
18889 C   6    CONTINUE
18890 C     ENDIF
18891
18892       ICOR   = 0
18893       INORCL = 0
18894       DO 7 I=1,2
18895          DO 8 K=1,4
18896 * get the average of the nucleon positions
18897             VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1)
18898             WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1)
18899             IF (I.EQ.1) PRCL(1,K) = PRCLPR(K)
18900             IF (I.EQ.2) PRCL(2,K) = PRCLTA(K)
18901     8    CONTINUE
18902 * mass number and charge of residual nuclei
18903          AIF(I)  = DBLE(NTOT(I))
18904          AIZF(I) = DBLE(NPRO(I)+NHPOS(I))
18905          IF (NTOT(I).GT.1) THEN
18906 * masses of residual nuclei in ground state
18907             AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*DT_ENERGY(AIF(I),AIZF(I))
18908 * masses of residual nuclei
18909             PTORCL   = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2)
18910             AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL)
18911             IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I))
18912 *
18913 *   M_res^2 < 0 : configuration not allowed
18914 *
18915 *      a) re-calculate E_exc with scaled nuclear potential
18916 *         (conditional jump to label 9998)
18917 *      b) or reject event if N_loop(max) is exceeded
18918 *         (conditional jump to label 9999)
18919 *
18920             IF (AMRCL(I).LE.ZERO) THEN
18921                IF (IOULEV(3).GT.0)
18922      &            WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3),
18923      &                             PRCL(I,4),NTOT
18924  1000          FORMAT(1X,'warning! negative excitation energy',/,
18925      &                I4,4E15.4,2I4)
18926                AMRCL(I) = ZERO
18927                EEXC(I)  = ZERO
18928                IF (NLOOP.LE.500) THEN
18929                   GOTO 9998
18930                ELSE
18931                   IREXCI(2) = IREXCI(2)+1
18932                   GOTO 9999
18933                ENDIF
18934 *
18935 *   0 < M_res < M_res0 : mass below ground-state mass
18936 *
18937 *      a) we had residual nuclei with mass N_tot and reasonable E_exc
18938 *         before- assign average E_exc of those configurations to this
18939 *         one ( Nexc(i,N_tot) > 0 )
18940 *      b) or (and this applies always if run in transport codes) go up
18941 *         one mass number and
18942 *           i) if mass now larger than proj/targ mass or if run in
18943 *              transport codes assign average E_exc per wounded nucleon
18944 *              x number of wounded nucleons (Inuc-Ntot)
18945 *          ii) or assign average E_exc of those configurations to this
18946 *              one ( Nexc(i,m) > 0 )
18947 *
18948             ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
18949      &                                                         THEN
18950                M = MIN(NTOT(I),260)
18951                IF (NEXC(I,M).GT.0) THEN
18952                   AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
18953                ELSE
18954    70             CONTINUE
18955                   M = M+1
18956 **sr corrected 27.12.06
18957 *                 IF (M.GE.INUC(I)) THEN
18958 *                    AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
18959                   IF ((M.GE.INUC(I)).OR.(ICASCA.GT.0)) THEN
18960                      IF ( INUC (I) .GT. NTOT (I) ) THEN
18961                         AMRCL(I) = AMRCL0(I)
18962      &                         + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0))
18963                      ELSE
18964                         AMRCL(I) = AMRCL0(I) + 0.5D+00 * EXPNUC(I)
18965                      END IF
18966 **
18967                   ELSE
18968                      IF (NEXC(I,M).GT.0) THEN
18969                         AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
18970                      ELSE
18971                         GOTO 70
18972                      ENDIF
18973                   ENDIF
18974                ENDIF
18975                EEXC(I)  = AMRCL(I)-AMRCL0(I)
18976                ICOR     = ICOR+I
18977 *
18978 *   M_res > 2.5 x M_res0 : unreasonably(?) high E_exc
18979 *
18980 *      a) re-calculate E_exc with scaled nuclear potential
18981 *         (conditional jump to label 9998)
18982 *      b) or reject event if N_loop(max) is exceeded
18983 *         (conditional jump to label 9999)
18984 *
18985 *
18986             ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN
18987                IF (IOULEV(3).GT.0)
18988      &            WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK
18989  1004          FORMAT(1X,'warning! too high excitation energy',/,
18990      &                I4,1P,2E15.4,3I5)
18991                AMRCL(I) = ZERO
18992                EEXC(I)  = ZERO
18993                IF (NLOOP.LE.500) THEN
18994                   GOTO 9998
18995                ELSE
18996                   IREXCI(2) = IREXCI(2)+1
18997                   GOTO 9999
18998                ENDIF
18999 *
19000 *   Otherwise (reasonable E_exc) :
19001 *      E_exc = M_res - M_res0
19002 *      in addition: calculate and save E_exc per wounded nucleon as
19003 *                   well as E_exc in <E_exc> counter
19004 *
19005             ELSE
19006 * excitation energies of residual nuclei
19007                EEXC(I)   = AMRCL(I)-AMRCL0(I)
19008 **sr 27.12.06 new excitation energy correction by A.F.
19009 *
19010 * all parts with Ilcopt<3 commented since not used
19011 *
19012 * still to be done/decided:
19013 *   Increase Icor and put back both residual nuclei on mass shell
19014 *   with the exciting correction further below.
19015 *   For the moment the modification in the excitation energy is simply
19016 *   corrected by scaling the energy of the residual nucleus.
19017 *
19018                LLCPOT = .TRUE.
19019                ILCOPT = 3
19020                IF ( LLCPOT ) THEN
19021                   NNCHIT = MAX ( INUC (I) - NTOT (I), 0 )
19022                   IF ( ILCOPT .LE. 2 ) THEN
19023 C* Patch for Fermi momentum reduction correlated with impact parameter:
19024 C                     FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE )
19025 C                     DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I)))
19026 C                     AKPRHO = ONE - DLKPRH
19027 C* f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen
19028 C                     FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO  - ONE,
19029 C     &                              0.05D+00 )
19030 C*                    REDORI = 0.75D+00
19031 C*                    REDORI = ONE
19032 C                     REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
19033                   ELSE
19034                      DLKPRH = ZERO
19035                      RDCORE = 1.14D+00 * DBLE(INUC(I))**(ONE/3.D+00)
19036 *  Take out roughly one/half of the skin:
19037                      RDCORE = RDCORE - 0.5D+00
19038                      FRCFLL = RDCORE**3
19039                      PRSKIN = (RDCORE+2.4D+00)**3 - FRCFLL
19040                      PRSKIN = 0.5D+00 * PRSKIN / ( PRSKIN + FRCFLL )
19041                      FRCFLL = ONE - PRSKIN
19042                      FRMRDC = FRCFLL + 0.5D+00 * PRSKIN
19043                      REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
19044                   END IF
19045                   IF ( NNCHIT .GT. 0 ) THEN
19046 C                     IF ( ILCOPT .EQ. 1 ) THEN
19047 C                        SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE)
19048 C                        DO 1220 NCH = 1, 10
19049 C                           ETAETA = ( ONE - SKINRH**INUC(I)
19050 C     &                            - DBLE(INUC(I))* ( ONE - FRCFLL )
19051 C     &                            * ( ONE - SKINRH ) )
19052 C     &                            / ( SKINRH**INUC(I) - DBLE (INUC(I))
19053 C     &                            * ( ONE - FRCFLL) * SKINRH )
19054 C                           SKINRH = SKINRH * ( ONE + ETAETA )
19055 C 1220                   CONTINUE
19056 C                        PRSKIN = SKINRH**(NNCHIT-1)
19057 C                     ELSE IF ( ILCOPT .EQ. 2 ) THEN
19058 C                        PRSKIN = ONE - FRCFLL
19059 C                     END IF
19060                      REDCTN = ZERO
19061                      DO 1230 NCH = 1, NNCHIT
19062                         IF (DT_RNDM(PRFRMI) .LT. PRSKIN) THEN
19063                            PRFRMI = (( ONE - 2.D+00 * DLKPRH )
19064      &                            * DT_RNDM(PRFRMI))**0.333333333333D+00
19065                         ELSE
19066                            PRFRMI = ( ONE - 2.D+00 * DLKPRH
19067      &                            * DT_RNDM(PRFRMI))**0.333333333333D+00
19068                         END IF
19069                         REDCTN = REDCTN + PRFRMI**2
19070  1230                CONTINUE
19071                      REDCTN = REDCTN / DBLE (NNCHIT)
19072                   ELSE
19073                      REDCTN = 0.5D+00
19074                   END IF
19075                   EEXC  (I) = EEXC   (I) * REDCTN / REDORI
19076                   AMRCL (I) = AMRCL0 (I) + EEXC (I)
19077                   PRCL(I,4) = SQRT ( PTORCL**2 + AMRCL(I)**2 )
19078                END IF
19079 **
19080                IF (ICASCA.EQ.0) THEN
19081                   EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I))
19082                   M = MIN(NTOT(I),260)
19083                   EXC(I,M)  = EXC(I,M)+EEXC(I)
19084                   NEXC(I,M) = NEXC(I,M)+1
19085                ENDIF
19086             ENDIF
19087          ELSEIF (NTOT(I).EQ.1) THEN
19088             WRITE(LOUT,1003) I
19089  1003       FORMAT(1X,'FICONF:   warning! NTOT(I)=1? (I=',I3,')')
19090             GOTO 9999
19091          ELSE
19092             AMRCL0(I) = ZERO
19093             AMRCL(I)  = ZERO
19094             EEXC(I)   = ZERO
19095             INORCL    = INORCL+I
19096          ENDIF
19097     7 CONTINUE
19098
19099       PRCLPR(5) = AMRCL(1)
19100       PRCLTA(5) = AMRCL(2)
19101
19102       IF (ICOR.GT.0) THEN
19103          IF (INORCL.EQ.0) THEN
19104 * one or both residual nuclei consist of one nucleon only, transform
19105 * this nucleon on mass shell
19106             DO 9 K=1,4
19107                P1IN(K) = PRCL(1,K)
19108                P2IN(K) = PRCL(2,K)
19109     9       CONTINUE
19110             XM1 = AMRCL(1)
19111             XM2 = AMRCL(2)
19112             CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
19113             IF (IREJ1.GT.0) THEN
19114                WRITE(LOUT,*) 'ficonf-mashel rejection'
19115                GOTO 9999
19116             ENDIF
19117             DO 10 K=1,4
19118                PRCL(1,K) = P1OUT(K)
19119                PRCL(2,K) = P2OUT(K)
19120                PRCLPR(K) = P1OUT(K)
19121                PRCLTA(K) = P2OUT(K)
19122    10       CONTINUE
19123             PRCLPR(5) = AMRCL(1)
19124             PRCLTA(5) = AMRCL(2)
19125          ELSE
19126             IF (IOULEV(3).GT.0)
19127      &      WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)),
19128      &                       INT(AIF(2)),INT(AIZF(2)),AMRCL0(1),
19129      &                       AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2),
19130      &                       AMRCL(2),AMRCL(2)-AMRCL0(2)
19131  1001       FORMAT(1X,'FICONF:   warning! no residual nucleus for',
19132      &             ' correction',/,11X,'at event',I8,
19133      &             ',  nucleon config. 1:',2I4,' 2:',2I4,
19134      &             2(/,11X,3E12.3))
19135             IF (NLOOP.LE.500) THEN
19136                GOTO 9998
19137             ELSE
19138                IREXCI(1) = IREXCI(1)+1
19139             ENDIF
19140          ENDIF
19141       ENDIF
19142
19143 * update counter
19144 C     IF (NRESEV(1).NE.NEVHKK) THEN
19145 C        NRESEV(1) = NEVHKK
19146 C        NRESEV(2) = NRESEV(2)+1
19147 C     ENDIF
19148       NRESEV(2) = NRESEV(2)+1
19149       DO 15 I=1,2
19150          EXCDPM(I)   = EXCDPM(I)+EEXC(I)
19151          EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1))
19152          NRESTO(I) = NRESTO(I)+NTOT(I)
19153          NRESPR(I) = NRESPR(I)+NPRO(I)
19154          NRESNU(I) = NRESNU(I)+NN(I)
19155          NRESBA(I) = NRESBA(I)+NH(I)
19156          NRESPB(I) = NRESPB(I)+NHPOS(I)
19157          NRESCH(I) = NRESCH(I)+NQ(I)
19158    15 CONTINUE
19159
19160 * evaporation
19161       IF (LEVPRT) THEN
19162          DO 13 I=1,2
19163 * initialize evaporation counter
19164             EEXCFI(I) = ZERO
19165             IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
19166      &          (EEXC(I).GT.ZERO)) THEN
19167 * put residual nuclei into DTEVT1
19168                IDRCL = 80000
19169                JMASS = INT( AIF(I))
19170                JCHAR = INT(AIZF(I))
19171 *  the following patch is required to transmit the correct excitation
19172 *   energy to Eventd
19173                IF (ITRSPT.EQ.1) THEN
19174                   IF ((ABS(AMRCL(I)-AMRCL0(I)-EEXC(I)).GT.1.D-04).AND.
19175      &                (IOULEV(3).GT.0))
19176      &               WRITE(LOUT,*)
19177      &                  ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)',
19178      &                              AMRCL(I),AMRCL0(I),EEXC(I)
19179                   PRCL0 = PRCL(I,4)
19180                   PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
19181      &                                                    +PRCL(I,3)**2)
19182                   IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
19183                      WRITE(LOUT,*)
19184      &                  ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
19185                   ENDIF
19186                ENDIF
19187                CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1),
19188      &              PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0)
19189 **sr 22.6.97
19190                NOBAM(NHKK) = I
19191 **
19192                DO 14 J=1,4
19193                   VHKK(J,NHKK) = VRCL(I,J)
19194                   WHKK(J,NHKK) = WRCL(I,J)
19195    14          CONTINUE
19196 *  interface to evaporation module - fill final residual nucleus into
19197 *  common FKRESN
19198 *   fill resnuc only if code is not used as event generator in Fluka
19199                IF (ITRSPT.NE.1) THEN
19200                   PXRES  = PRCL(I,1)
19201                   PYRES  = PRCL(I,2)
19202                   PZRES  = PRCL(I,3)
19203                   IBRES  = NPRO(I)+NN(I)+NH(I)
19204                   ICRES  = NPRO(I)+NHPOS(I)
19205                   ANOW   = DBLE(IBRES)
19206                   ZNOW   = DBLE(ICRES)
19207                   PTRES  = SQRT(PXRES**2+PYRES**2+PZRES**2)
19208 *   ground state mass of the residual nucleus (should be equal to AM0T)
19209                   AMMRES = AMRCL0(I)
19210                   AMNRES = AMMRES-ZNOW*AMELEC+ELBNDE(ICRES)
19211 *  common FKFINU
19212                   TV = ZERO
19213 *   kinetic energy of residual nucleus
19214                   TVRECL = PRCL(I,4)-AMRCL(I)
19215 *   excitation energy of residual nucleus
19216                   TVCMS  = EEXC(I)
19217                   PTOLD  = PTRES
19218                   PTRES  = SQRT(ABS(TVRECL*(TVRECL+
19219      &                          2.0D0*(AMMRES+TVCMS))))
19220                   IF (PTOLD.LT.ANGLGB) THEN
19221                      CALL DT_RACO(PXRES,PYRES,PZRES)
19222                      PTOLD = ONE
19223                   ENDIF
19224                   PXRES = PXRES*PTRES/PTOLD
19225                   PYRES = PYRES*PTRES/PTOLD
19226                   PZRES = PZRES*PTRES/PTOLD
19227 * zero counter of secondaries from evaporation
19228                   NP = 0
19229 * evaporation
19230                   WE = ONE
19231                   CALL DT_EVEVAP(WE)
19232 * put evaporated particles and residual nuclei to DTEVT1
19233                   MO = NHKK
19234                   CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
19235                ENDIF
19236                EEXCFI(I) = EXCITF
19237                EXCEVA(I) = EXCEVA(I)+EXCITF
19238             ENDIF
19239    13    CONTINUE
19240       ENDIF
19241
19242       RETURN
19243
19244 C9998 IREXCI(1) = IREXCI(1)+1
19245  9998 IREJ   = IREJ+1
19246  9999 CONTINUE
19247       LRCLPR = .TRUE.
19248       LRCLTA = .TRUE.
19249       IREJ   = IREJ+1
19250       RETURN
19251       END
19252
19253 *$ CREATE DT_EVA2HE.FOR
19254 *COPY DT_EVA2HE
19255 *                                                                      *
19256 *====eva2he============================================================*
19257 *                                                                      *
19258       SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
19259
19260 ************************************************************************
19261 * Interface between common's of evaporation module (FKFINU,FKFHVY)     *
19262 * and DTEVT1.                                                          *
19263 *    MO    DTEVT1-index of "mother" (residual) nucleus before evap.    *
19264 *    EEXCF exitation energy of residual nucleus after evaporation      *
19265 *    IRCL  = 1 projectile residual nucleus                             *
19266 *          = 2 target     residual nucleus                             *
19267 * This version dated 19.04.95 is written by S. Roesler.                *
19268 *                                                                      *
19269 * Last change 27.12.2006 by S. Roesler.                                *
19270 ************************************************************************
19271
19272       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19273       SAVE
19274       PARAMETER ( LINP = 10 ,
19275      &            LOUT = 6 ,
19276      &            LDAT = 9 )
19277       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3)
19278
19279 * event history
19280       PARAMETER (NMXHKK=200000)
19281       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19282      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19283      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19284 * Note: DTEVT2 - special use for heavy fragments !
19285 *       (IDRES(I) = mass number, IDXRES(I) = charge)
19286 * extended event history
19287       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19288      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19289      &                IHIST(2,NMXHKK)
19290 * particle properties (BAMJET index convention)
19291       CHARACTER*8  ANAME
19292       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19293      &                IICH(210),IIBAR(210),K1(210),K2(210)
19294 * flags for input different options
19295       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
19296       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
19297      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
19298 * statistics: residual nuclei
19299       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
19300      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
19301      &                NINCST(2,4),NINCEV(2),
19302      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
19303      &                NRESPB(2),NRESCH(2),NRESEV(4),
19304      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
19305      &                NEVAFI(2,2)
19306 * treatment of residual nuclei: properties of residual nuclei
19307       COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
19308      &                NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
19309      &                NTOTFI(2),NPROFI(2)
19310 * (original name: FINUC)
19311       PARAMETER (MXP=999)
19312       COMMON /FKFINU/ CXR    (MXP), CYR    (MXP), CZR    (MXP),
19313      &                CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
19314      &                TKI    (MXP), PLR    (MXP), WEI    (MXP),
19315      &                TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
19316      &                KPART  (MXP)
19317 * (original name: FHEAVY,FHEAVC)
19318       PARAMETER ( MXHEAV = 100 )
19319       CHARACTER*8 ANHEAV
19320       COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
19321      &                CZHEAV (MXHEAV), TKHEAV (MXHEAV),
19322      &                PHEAVY (MXHEAV), WHEAVY (MXHEAV),
19323      &                AMHEAV  ( 12 ) , AMNHEA  ( 12 ) ,
19324      &                KHEAVY (MXHEAV), ICHEAV  ( 12 ) ,
19325      &                IBHEAV  ( 12 ) , NPHEAV
19326       COMMON /FKFHVC/ ANHEAV  ( 12 )
19327 * (original name: RESNUC)
19328       LOGICAL LRNFSS, LFRAGM
19329       COMMON /FKRESN/  AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
19330      &                   ANOW,   ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
19331      &                   ERES,  EKRES, AMNRES, AMMRES,  PTRES,  PXRES,
19332      &                  PYRES,  PZRES, PTRES2,  KTARP,  KTARN, IGREYP,
19333      &                 IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
19334      &                  ICRES,  IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
19335      &                 IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
19336      &                  IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
19337      &                 LFRAGM
19338
19339       DIMENSION IPTOKP(39)
19340       DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
19341      & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
19342      & 100, 101, 97, 102, 98, 103, 109, 115 /
19343
19344       IREJ = 0
19345
19346 * skip if evaporation package is not included
19347       IF (.NOT.LEVAPO) RETURN
19348
19349 * update counter
19350       IF (NRESEV(3).NE.NEVHKK) THEN
19351          NRESEV(3) = NEVHKK
19352          NRESEV(4) = NRESEV(4)+1
19353       ENDIF
19354
19355       IF (LEMCCK)
19356      &   CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
19357      &                                                   IDUM,IDUM)
19358 * mass number/charge of residual nucleus before evaporation
19359       IBTOT = IDRES(MO)
19360       IZTOT = IDXRES(MO)
19361
19362 * protons/neutrons/gammas
19363       DO 1 I=1,NP
19364          PX    = CXR(I)*PLR(I)
19365          PY    = CYR(I)*PLR(I)
19366          PZ    = CZR(I)*PLR(I)
19367          ID    = IPTOKP(KPART(I))
19368          IDPDG = IDT_IPDGHA(ID)
19369          AM    = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/
19370      &           (2.0D0*MAX(TKI(I),TINY10))
19371          IF (ABS(AM-AAM(ID)).GT.TINY3) THEN
19372             WRITE(LOUT,1000) ID,AM,AAM(ID)
19373  1000       FORMAT(1X,'EVA2HE:  inconsistent mass of evap. ',
19374      &             'particle',I3,2E10.3)
19375          ENDIF
19376          PE = TKI(I)+AM
19377          CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
19378          NOBAM(NHKK) = IRCL
19379          IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19380          IBTOT = IBTOT-IIBAR(ID)
19381          IZTOT = IZTOT-IICH(ID)
19382     1 CONTINUE
19383
19384 * heavy fragments
19385       DO 2 I=1,NPHEAV
19386          PX     = CXHEAV(I)*PHEAVY(I)
19387          PY     = CYHEAV(I)*PHEAVY(I)
19388          PZ     = CZHEAV(I)*PHEAVY(I)
19389          IDHEAV = 80000
19390          AM     = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
19391      &            (2.0D0*MAX(TKHEAV(I),TINY10))
19392          PE     = TKHEAV(I)+AM
19393          CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
19394      &                  IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
19395          NOBAM(NHKK) = IRCL
19396          IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
19397          IBTOT = IBTOT-IBHEAV(KHEAVY(I))
19398          IZTOT = IZTOT-ICHEAV(KHEAVY(I))
19399     2 CONTINUE
19400
19401       IF (IBRES.GT.0) THEN
19402 * residual nucleus after evaporation
19403          IDNUC = 80000
19404          CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
19405      &                                        IBRES,ICRES,0)
19406          NOBAM(NHKK) = IRCL
19407       ENDIF
19408       EEXCF = TVCMS
19409       NTOTFI(IRCL) = IBRES
19410       NPROFI(IRCL) = ICRES
19411       IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM)
19412       IBTOT = IBTOT-IBRES
19413       IZTOT = IZTOT-ICRES
19414
19415 * count events with fission
19416       NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
19417       IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
19418
19419 * energy-momentum conservation check
19420       IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
19421 C     IF (IREJ.GT.0) THEN
19422 C        CALL DT_EVTOUT(4)
19423 C        WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
19424 C     ENDIF
19425 * baryon-number/charge conservation check
19426       IF (IBTOT+IZTOT.NE.0) THEN
19427          WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT
19428  1001    FORMAT(1X,'EVA2HE:   baryon-number/charge conservation ',
19429      &          'failure at event ',I8,' :  IBTOT,IZTOT = ',2I3)
19430       ENDIF
19431
19432       RETURN
19433       END
19434
19435 *$ CREATE DT_EBIND.FOR
19436 *COPY DT_EBIND
19437 *
19438 *===ebind==============================================================*
19439 *
19440       DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
19441
19442 ************************************************************************
19443 * Binding energy for nuclei.                                           *
19444 * (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972)                  *
19445 *                 IA        mass number                                *
19446 *                 IZ        atomic number                              *
19447 * This version dated 5.5.95   is updated by S. Roesler.                *
19448 ************************************************************************
19449
19450       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19451       SAVE
19452       PARAMETER ( LINP = 10 ,
19453      &            LOUT = 6 ,
19454      &            LDAT = 9 )
19455       PARAMETER (ZERO=0.0D0)
19456
19457       DATA       A1,       A2,        A3,        A4,      A5
19458      &     / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
19459
19460       IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN
19461          WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0.  ',IA,IZ
19462          DT_EBIND = ZERO
19463          RETURN
19464       ENDIF
19465       AA = IA
19466       DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0)
19467      &        -A4*(IA-2*IZ)**2/AA
19468       IF (MOD(IA,2).EQ.1) THEN
19469          IA5 = 0
19470       ELSEIF (MOD(IZ,2).EQ.1) THEN
19471          IA5 = 1
19472       ELSE
19473          IA5 = -1
19474       ENDIF
19475       DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
19476
19477       RETURN
19478       END
19479
19480 **sr 30.6. routine replaced completely
19481 *$ CREATE DT_ENERGY.FOR
19482 *COPY DT_ENERGY
19483 *                                                                      *
19484 *=== energy ===========================================================*
19485 *                                                                      *
19486       DOUBLE PRECISION FUNCTION DT_ENERGY( A, Z )
19487
19488 C     INCLUDE '(DBLPRC)'
19489 * DBLPRC.ADD
19490       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19491       SAVE
19492 * (original name: GLOBAL)
19493       PARAMETER ( KALGNM = 2 )
19494       PARAMETER ( ANGLGB = 5.0D-16 )
19495       PARAMETER ( ANGLSQ = 2.5D-31 )
19496       PARAMETER ( AXCSSV = 0.2D+16 )
19497       PARAMETER ( ANDRFL = 1.0D-38 )
19498       PARAMETER ( AVRFLW = 1.0D+38 )
19499       PARAMETER ( AINFNT = 1.0D+30 )
19500       PARAMETER ( AZRZRZ = 1.0D-30 )
19501       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
19502       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
19503       PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
19504       PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
19505       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
19506       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
19507       PARAMETER ( CSNNRM = 2.0D-15 )
19508       PARAMETER ( DMXTRN = 1.0D+08 )
19509       PARAMETER ( ZERZER = 0.D+00 )
19510       PARAMETER ( ONEONE = 1.D+00 )
19511       PARAMETER ( TWOTWO = 2.D+00 )
19512       PARAMETER ( THRTHR = 3.D+00 )
19513       PARAMETER ( FOUFOU = 4.D+00 )
19514       PARAMETER ( FIVFIV = 5.D+00 )
19515       PARAMETER ( SIXSIX = 6.D+00 )
19516       PARAMETER ( SEVSEV = 7.D+00 )
19517       PARAMETER ( EIGEIG = 8.D+00 )
19518       PARAMETER ( ANINEN = 9.D+00 )
19519       PARAMETER ( TENTEN = 10.D+00 )
19520       PARAMETER ( HLFHLF = 0.5D+00 )
19521       PARAMETER ( ONETHI = ONEONE / THRTHR )
19522       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
19523       PARAMETER ( ONEFOU = ONEONE / FOUFOU )
19524       PARAMETER ( THRTWO = THRTHR / TWOTWO )
19525       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
19526       PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
19527       PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
19528       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
19529       PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
19530       PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
19531       PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
19532       PARAMETER ( EULERO = 0.577215664901532860606512      D+00 )
19533       PARAMETER ( EULEXP = 1.781072417990197985236504      D+00 )
19534       PARAMETER ( EULLOG =-0.5495393129816448223376619     D+00 )
19535       PARAMETER ( E1M2EU = 0.8569023337737540831433017     D+00 )
19536       PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
19537       PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
19538       PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
19539       PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
19540       PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
19541       PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
19542       PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
19543       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
19544       PARAMETER ( CLIGHT = 2.99792458         D+10 )
19545       PARAMETER ( AVOGAD = 6.0221367          D+23 )
19546       PARAMETER ( BOLTZM = 1.380658           D-23 )
19547       PARAMETER ( AMELGR = 9.1093897          D-28 )
19548       PARAMETER ( PLCKBR = 1.05457266         D-27 )
19549       PARAMETER ( ELCCGS = 4.8032068          D-10 )
19550       PARAMETER ( ELCMKS = 1.60217733         D-19 )
19551       PARAMETER ( AMUGRM = 1.6605402          D-24 )
19552       PARAMETER ( AMMUMU = 0.113428913        D+00 )
19553       PARAMETER ( AMPRMU = 1.007276470        D+00 )
19554       PARAMETER ( AMNEMU = 1.008664904        D+00 )
19555       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
19556       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
19557       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
19558       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
19559       PARAMETER ( PLABRC = 0.197327053        D+00 )
19560       PARAMETER ( AMELCT = 0.51099906         D-03 )
19561       PARAMETER ( AMUGEV = 0.93149432         D+00 )
19562       PARAMETER ( AMMUON = 0.105658389        D+00 )
19563       PARAMETER ( AMPRTN = 0.93827231         D+00 )
19564       PARAMETER ( AMNTRN = 0.93956563         D+00 )
19565       PARAMETER ( AMDEUT = 1.87561339         D+00 )
19566       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
19567      &                   * 1.D-09 )
19568       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
19569       PARAMETER ( BLTZMN = 8.617385           D-14 )
19570       PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
19571       PARAMETER ( GFOHB3 = 1.16639            D-05 )
19572       PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
19573       PARAMETER ( SIN2TW = 0.2319             D+00 )
19574       PARAMETER ( GEVMEV = 1.0                D+03 )
19575       PARAMETER ( EMVGEV = 1.0                D-03 )
19576       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
19577       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
19578       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
19579       LOGICAL LGBIAS, LGBANA
19580       COMMON /FKGLOB/ LGBIAS, LGBANA
19581 C     INCLUDE '(DIMPAR)'
19582 * DIMPAR.ADD
19583       PARAMETER ( MXXRGN = 5000 )
19584       PARAMETER ( MXXMDF = 82   )
19585       PARAMETER ( MXXMDE = 54   )
19586       PARAMETER ( MFSTCK = 1000 )
19587       PARAMETER ( MESTCK = 100  )
19588       PARAMETER ( NALLWP = 39   )
19589       PARAMETER ( NELEMX = 80   )
19590       PARAMETER ( MPDPDX = 8    )
19591       PARAMETER ( ICOMAX = 180  )
19592       PARAMETER ( NSTBIS = 304  )
19593       PARAMETER ( IDMAXP = 220  )
19594       PARAMETER ( IDMXDC = 640  )
19595       PARAMETER ( MKBMX1 = 1    )
19596       PARAMETER ( MKBMX2 = 1    )
19597 C     INCLUDE '(IOUNIT)'
19598 * IOUNIT.ADD
19599       PARAMETER ( LUNIN  =  5 )
19600       PARAMETER ( LUNOUT =  6 )
19601 **sr 19.5. set error output-unit from 15 to 6
19602       PARAMETER ( LUNERR = 6  )
19603       PARAMETER ( LUNBER = 14 )
19604       PARAMETER ( LUNECH =  8 )
19605       PARAMETER ( LUNFLU = 13 )
19606       PARAMETER ( LUNGEO = 16 )
19607       PARAMETER ( LUNPMF = 12 )
19608       PARAMETER ( LUNRAN =  2 )
19609       PARAMETER ( LUNXSC =  9 )
19610       PARAMETER ( LUNDET = 17 )
19611       PARAMETER ( LUNRAY = 10 )
19612       PARAMETER ( LUNRDB =  1 )
19613       PARAMETER ( LUNPGO =  7 )
19614       PARAMETER ( LUNPGS =  4 )
19615       PARAMETER ( LUNSCR =  3 )
19616 *
19617 *----------------------------------------------------------------------*
19618 *                                                                      *
19619 *     Revised version of the original routine from EVAP:               *
19620 *                                                                      *
19621 *     Created on   15 may 1990     by    Alfredo Ferrari & Paola Sala  *
19622 *                                                   Infn - Milan       *
19623 *                                                                      *
19624 *     Last change on 19-sep-95     by    Alfredo Ferrari               *
19625 *                                                                      *
19626 *     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!     *
19627 *     !!!  It is supposed to be used with the updated atomic   !!!     *
19628 *     !!!                    mass data file                    !!!     *
19629 *     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!     *
19630 *                                                                      *
19631 *----------------------------------------------------------------------*
19632 *
19633 *  Mass number below which "unknown" isotopes out of the Z-interval
19634 *  reported in the mass tabulations are completely unstable and made
19635 *  up by Z proton masses + N neutron masses:
19636       PARAMETER ( KAFREE =  4 )
19637 *  Mass number below which "unknown" isotopes out of the Z-interval
19638 *  reported in the mass tabulations are supposed to be particle unstable
19639       PARAMETER ( KAPUNS = 12 )
19640 *  Minimum energy required for particle unstable isotopes
19641       PARAMETER ( DEPUNS = 0.5D+00 )
19642 *
19643 * (original name: EVA0)
19644       COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
19645      *                FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
19646      *                CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
19647      *                T (4,7), RMASS (297), ALPH (297), BET (297),
19648      *                APRIME (250), IA (6), IZ (6)
19649 * (original name: ISOTOP)
19650       PARAMETER ( NAMSMX = 270 )
19651       PARAMETER ( NZGVAX =  15 )
19652       PARAMETER ( NISMMX = 574 )
19653       COMMON /FKISOT/ WAPS   (NAMSMX,NZGVAX),  T12NUC (NAMSMX,NZGVAX),
19654      &                WAPISM (NISMMX), T12ISM (NISMMX),
19655      &                ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
19656      &                AMSSST (100)  , ISOMNM (NSTBIS), ISONDX (2,100),
19657      &                JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
19658      &                INWAPS (NAMSMX), JSPISM (NISMMX),
19659      &                JPTISM (NISMMX), IZWISM (NISMMX),
19660      &                INWISM (0:NAMSMX)
19661 *
19662 CPH      SAVE KA0, KZ0, IZ0
19663       DATA KA0, KZ0, IZ0 / -1, -1, -1 /
19664 *
19665       IFLAG = 1
19666       GO TO 10
19667 *======================================================================*
19668 *                                                                      *
19669 *     Entry ENergy - KNOWn                                             *
19670 *                                                                      *
19671 *======================================================================*
19672       ENTRY DT_ENKNOW ( A, Z, IZZ0 )
19673       IZZ0  =-1
19674       IFLAG = 2
19675    10 CONTINUE
19676 *
19677       KA0 = NINT ( A )
19678       KZ0 = NINT ( Z )
19679       N   = KA0 - KZ0
19680 *  +-------------------------------------------------------------------*
19681 *  |  Null residual nucleus:
19682       IF ( KA0 .EQ. 0 .AND. KZ0 .LE. 0 ) THEN
19683          IF ( IFLAG .EQ. 1 ) THEN
19684             DT_ENERGY = ZERZER
19685          ELSE
19686             DT_ENKNOW = ZERZER
19687             IZZ0   = -1
19688          END IF
19689          RETURN
19690 *  |
19691 *  +-------------------------------------------------------------------*
19692 *  |  Only protons:
19693       ELSE IF ( N .LE. 0 ) THEN
19694          IF ( N .LT. 0 ) THEN
19695             WRITE ( LUNOUT, * )
19696      &     ' DPMJET stopped in energy: mass number =< atomic number !!',
19697      &       KA0, KZ0
19698             WRITE ( LUNOUT, * )
19699      &     ' DPMJET stopped in energy: mass number =< atomic number !!',
19700      &       KA0, KZ0
19701                WRITE ( 77, * )
19702      &  ' ^^^DPMJET stopped in energy: mass number =< atomic number !!',
19703      &       KA0, KZ0
19704             STOP 'DT_ENERGY:KA0-KZ0'
19705          END IF
19706          IZ0    = -1
19707          IF ( IFLAG .EQ. 1 ) THEN
19708             DT_ENERGY = Z * WAPS ( 1, 2 )
19709          ELSE
19710             DT_ENKNOW = Z * WAPS ( 1, 2 )
19711             IZZ0   = -1
19712          END IF
19713          RETURN
19714 *  |
19715 *  +-------------------------------------------------------------------*
19716 *  |  Only neutrons:
19717       ELSE IF ( KZ0 .LE. 0 ) THEN
19718          IF ( KZ0 .LT. 0 ) THEN
19719             WRITE ( LUNOUT, * )
19720      &   ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19721             WRITE ( LUNOUT, * )
19722      &   ' DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19723             WRITE ( 77, * )
19724      &' ^^^DPMJET stopped in energy: negative atomic number !!',KA0,KZ0
19725             STOP 'DT_ENERGY:KZ0<0'
19726          END IF
19727          IZ0    = -1
19728          IF ( IFLAG .EQ. 1 ) THEN
19729             DT_ENERGY = A * WAPS ( 1, 1 )
19730          ELSE
19731             DT_ENKNOW = A * WAPS ( 1, 1 )
19732             IZZ0   = -1
19733          END IF
19734          RETURN
19735       END IF
19736 *  |
19737 *  +-------------------------------------------------------------------*
19738 *  +-------------------------------------------------------------------*
19739 *  |  No actual nucleus
19740 *  |
19741 *  +-------------------------------------------------------------------*
19742 *  +-------------------------------------------------------------------*
19743 *  |  A larger than maximum allowed:
19744       IF ( KA0 .GT. NAMSMX ) THEN
19745          IZ0    = -1
19746          IF ( IFLAG .EQ. 1 ) THEN
19747             DT_ENERGY = DT_ENRG( A, Z )
19748          ELSE
19749             DT_ENKNOW = DT_ENRG( A, Z )
19750             IZZ0   = -1
19751          END IF
19752          RETURN
19753       END IF
19754 *  |
19755 *  +-------------------------------------------------------------------*
19756       IZZ = INWAPS ( KA0 )
19757 *  +-------------------------------------------------------------------*
19758 *  |  Too much neutron rich with respect to the stability line:
19759       IF ( KZ0 .LT. IZZ ) THEN
19760 *  |  +----------------------------------------------------------------*
19761 *  |  |  Up to A=Kafree all "bound" masses are known, set it unbound:
19762          IF ( KA0 .LE. KAFREE ) THEN
19763             DT_ENERGY = AINFNT
19764 *  |  |
19765 *  |  +----------------------------------------------------------------*
19766 *  |  |  Up to Kapuns: be sure it is particle unstable
19767          ELSE IF ( KA0 .LE. KAPUNS ) THEN
19768 *  |  |  Exp. excess mass for A,IZZ
19769             ENEEXP = WAPS ( KA0, 1 )
19770 *  |  |  Cameron excess mass for A, IZZ
19771             ENECA1 = DT_ENRG( A, DBLE (IZZ) )
19772 *  |  |  Cameron excess mass for A, Z
19773             DT_ENERGY = DT_ENRG( A, Z )
19774 *  |  |  Use just the difference according to Cameron!!!
19775             DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19776             JZZ    = INWAPS ( KA0 - 1 )
19777             LZZ    = INWAPS ( KA0 - 2 )
19778 *  |  |  +-------------------------------------------------------------*
19779 *  |  |  |  Residual mass for n-decay known:
19780             IF ( KZ0 .GE. JZZ .AND. KZ0 .LE. JZZ + NZGVAX - 1 ) THEN
19781                IZ0    = KZ0 - JZZ + 1
19782                DT_ENERGY = MAX(DT_ENERGY,WAPS (KA0-1,IZ0) + WAPS (1,1)
19783      &                      + DEPUNS )
19784 *  |  |  |
19785 *  |  |  +-------------------------------------------------------------*
19786 *  |  |  |  Residual mass for 2n-decay known:
19787             ELSE IF ( KZ0 .GE. LZZ .AND. KZ0 .LE. LZZ + NZGVAX - 1 )THEN
19788                IZ0    = KZ0 - LZZ + 1
19789                DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO *
19790      &                      ( WAPS (1,1) + DEPUNS ) )
19791 *  |  |  |
19792 *  |  |  +-------------------------------------------------------------*
19793 *  |  |  |  Set it unbound:
19794             ELSE
19795                DT_ENERGY = AINFNT
19796             END IF
19797 *  |  |  |
19798 *  |  |  +-------------------------------------------------------------*
19799 *  |  |
19800 *  |  +----------------------------------------------------------------*
19801 *  |  |  Proceed as usual:
19802          ELSE
19803 *  |  |  Exp. excess mass for A,IZZ
19804             ENEEXP = WAPS ( KA0, 1 )
19805 *  |  |  Cameron excess mass for A, IZZ
19806             ENECA1 = DT_ENRG( A, DBLE (IZZ) )
19807 *  |  |  Cameron excess mass for A, Z
19808             DT_ENERGY = DT_ENRG( A, Z )
19809 *  |  |  Use just the difference according to Cameron!!!
19810             DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19811          END IF
19812 *  |  |
19813 *  |  +----------------------------------------------------------------*
19814 *  |  Be sure not to have a positive energy state:
19815          DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) )
19816          IZ0    = -1
19817          IF ( IFLAG .EQ. 2 ) THEN
19818             DT_ENKNOW = DT_ENERGY
19819             IZZ0   = -1
19820          END IF
19821          RETURN
19822 *  |
19823 *  +-------------------------------------------------------------------*
19824 *  |  Too much proton rich with respect to the stability line:
19825       ELSE IF ( KZ0 .GT. IZZ + NZGVAX - 1 ) THEN
19826 *  |  +----------------------------------------------------------------*
19827 *  |  |  Up to A=Kafree all "bound" masses are known, set it unbound:
19828          IF ( KA0 .LE. KAFREE ) THEN
19829             DT_ENERGY = AINFNT
19830 *  |  |
19831 *  |  +----------------------------------------------------------------*
19832 *  |  |  Up to Kapuns: be sure it is particle unstable
19833          ELSE IF ( KA0 .LE. KAPUNS ) THEN
19834 *  |  |  Exp. excess mass for A,IZZ+NZGVAX-1
19835             ENEEXP = WAPS ( KA0, NZGVAX )
19836 *  |  |  Cameron excess mass for A, IZZ+NZGVAX-1
19837             ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) )
19838 *  |  |  Cameron excess mass for A, Z
19839             DT_ENERGY = DT_ENRG( A, Z )
19840 *  |  |  Use just the difference according to Cameron!!!
19841             DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19842             JZZ    = INWAPS ( KA0 - 1 )
19843             LZZ    = INWAPS ( KA0 - 2 )
19844 *  |  |  +-------------------------------------------------------------*
19845 *  |  |  |  Residual mass for p-decay known:
19846             IF ( KZ0-1 .GE. JZZ .AND. KZ0-1 .LE. JZZ + NZGVAX - 1 ) THEN
19847                IZ0    = KZ0 - 1 - JZZ + 1
19848                DT_ENERGY = MAX (DT_ENERGY, WAPS (KA0-1,IZ0) + WAPS (1,2)
19849      &                      + DEPUNS )
19850 *  |  |  |
19851 *  |  |  +-------------------------------------------------------------*
19852 *  |  |  |  Residual mass for 2p-decay known:
19853             ELSE IF ( KZ0-2 .GE. LZZ .AND. KZ0-2 .LE. LZZ + NZGVAX - 1 )
19854      &         THEN
19855                IZ0    = KZ0 - 2 - LZZ + 1
19856                DT_ENERGY = MAX ( DT_ENERGY, WAPS (KA0-2,IZ0) + TWOTWO *
19857      &                      ( WAPS (1,2) + DEPUNS ) )
19858 *  |  |  |
19859 *  |  |  +-------------------------------------------------------------*
19860 *  |  |  |  Set it unbound:
19861             ELSE
19862                DT_ENERGY = AINFNT
19863             END IF
19864 *  |  |  |
19865 *  |  |  +-------------------------------------------------------------*
19866 *  |  |
19867 *  |  +----------------------------------------------------------------*
19868 *  |  |  Proceed as usual:
19869          ELSE
19870 *  |  |  Exp. excess mass for A,IZZ+NZGVAX-1
19871             ENEEXP = WAPS ( KA0, NZGVAX )
19872 *  |  |  Cameron excess mass for A, IZZ+NZGVAX-1
19873             ENECA1 = DT_ENRG( A, DBLE (IZZ+NZGVAX-1) )
19874 *  |  |  Cameron excess mass for A, Z
19875             DT_ENERGY = DT_ENRG( A, Z )
19876 *  |  |  Use just the difference according to Cameron!!!
19877             DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19878          END IF
19879 *  |  |
19880 *  |  +----------------------------------------------------------------*
19881 *  |  Be sure not to have a positive energy state:
19882          DT_ENERGY = MIN(DT_ENERGY,(A-Z) * WAPS (1,1) + Z * WAPS (1,2) )
19883          IZ0    = -1
19884          IF ( IFLAG .EQ. 2 ) THEN
19885             DT_ENKNOW = DT_ENERGY
19886             IZZ0   = -1
19887          END IF
19888          RETURN
19889 *  |
19890 *  +-------------------------------------------------------------------*
19891 *  |  Known isotope or anyway isotope "inside" the stability zone
19892       ELSE
19893          IZ0    = KZ0 - IZZ + 1
19894          DT_ENERGY = WAPS ( KA0, IZ0 )
19895          IF ( IFLAG .EQ. 2 ) IZZ0 = IZ0
19896 *  |  +----------------------------------------------------------------*
19897 *  |  |  Mass not known
19898          IF ( ABS (DT_ENERGY) .LT. ANGLGB .AND. (KA0 .NE. 12 .OR. KZ0
19899      &        .NE. 6) ) THEN
19900             IF ( IFLAG .EQ. 2 ) IZZ0 = -1
19901 *  |  |  +-------------------------------------------------------------*
19902 *  |  |  |  Set it unbound:
19903             IF ( KA0 .LE. KAFREE ) THEN
19904                DT_ENERGY = AINFNT
19905 *  |  |  |
19906 *  |  |  +-------------------------------------------------------------*
19907 *  |  |  |  Try to get a reasonable excess mass:
19908             ELSE
19909                JZ0 = -100
19910 *  |  |  |  +----------------------------------------------------------*
19911 *  |  |  |  |  Check the closest one known:
19912                DO 500 JZZ = 1, NZGVAX
19913                   IF ( ABS ( WAPS (KA0,JZZ) ) .GT. ANGLGB .AND.
19914      &                 ABS (JZZ-IZ0) .LT. ABS (JZ0-IZ0) ) JZ0 = JZZ
19915                   IF ( ABS (JZ0-IZ0) .EQ. 1 ) GO TO 550
19916   500          CONTINUE
19917 *  |  |  |  |
19918 *  |  |  |  +----------------------------------------------------------*
19919   550          CONTINUE
19920 *  |  |  |  Exp. excess mass for A,IZZ+JZ0-1
19921                ENEEXP = WAPS ( KA0, JZ0 )
19922 *  |  |  |  Cameron excess mass for A, IZZ+JZ0-1
19923                ENECA1 = DT_ENRG( A, DBLE (IZZ+JZ0-1) )
19924 *  |  |  |  Cameron excess mass for A, Z
19925                DT_ENERGY = DT_ENRG( A, Z )
19926 *  |  |  |  Use just the difference according to Cameron!!!
19927                DT_ENERGY = ENEEXP + DT_ENERGY - ENECA1
19928                IZ0    = -1
19929             END IF
19930 *  |  |  |
19931 *  |  |  +-------------------------------------------------------------*
19932 *  |  |  Be sure not to have a positive energy state:
19933             DT_ENERGY = MIN(DT_ENERGY,(A-Z)*WAPS(1,1)+Z*WAPS (1,2) )
19934          END IF
19935 *  |  |
19936 *  |  +----------------------------------------------------------------*
19937          IF ( IFLAG .EQ. 2 ) DT_ENKNOW = DT_ENERGY
19938          RETURN
19939       END IF
19940 *  |
19941 *  +-------------------------------------------------------------------*
19942 *=== End of Function Energy ===========================================*
19943 *     RETURN
19944       END
19945 **
19946
19947 *$ CREATE DT_ENRG.FOR
19948 *COPY DT_ENRG
19949 *                                                                      *
19950 *=== enrg =============================================================*
19951 *                                                                      *
19952       DOUBLE PRECISION FUNCTION DT_ENRG(A,Z)
19953
19954       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19955       SAVE
19956
19957       PARAMETER ( ZERZER = 0.D+00 )
19958       PARAMETER ( ONEONE = 1.D+00 )
19959       PARAMETER ( LUNIN  = 5  )
19960       PARAMETER ( LUNOUT = 6  )
19961 *
19962 *----------------------------------------------------------------------*
19963 *                                                                      *
19964 *     Revised version of the original routine from EVAP:               *
19965 *                                                                      *
19966 *     Created on   15 may 1990     by    Alfredo Ferrari & Paola Sala  *
19967 *                                                   Infn - Milan       *
19968 *                                                                      *
19969 *     Last change on 01-oct-94     by    Alfredo Ferrari               *
19970 *                                                                      *
19971 *     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!     *
19972 *     !!!  It is supposed to be used with the updated atomic   !!!     *
19973 *     !!!                    mass data file                    !!!     *
19974 *     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!     *
19975 *                                                                      *
19976 *----------------------------------------------------------------------*
19977 *
19978       PARAMETER ( O16OLD = 931.145  D+00 )
19979       PARAMETER ( O16NEW = 931.19826D+00 )
19980       PARAMETER ( O16RAT = O16NEW / O16OLD )
19981       PARAMETER ( C12NEW = 931.49432D+00 )
19982       PARAMETER ( ADJUST = -8.322737768178909D-02 )
19983       PARAMETER ( AINFNT = 1.0D+30 )
19984 * (original name: EVA0)
19985       COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
19986      *                FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
19987      *                CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
19988      *                T (4,7), RMASS (297), ALPH (297), BET (297),
19989      *                APRIME (250), IA (6), IZ (6)
19990       LOGICAL LFIRST
19991 CPH      SAVE LFIRST, EXHYDR, EXNEUT
19992       DATA LFIRST / .TRUE. /
19993 *
19994       IF ( LFIRST ) THEN
19995          LFIRST = .FALSE.
19996 **sr 30.6.
19997 C        EXHYDR = DT_ENERGY( ONEONE, ONEONE )
19998 C        EXNEUT = DT_ENERGY( ONEONE, ZERZER )
19999          EXHYDR = A
20000          EXNEUT = Z
20001          DT_ENRG   = -AINFNT
20002          RETURN
20003 **
20004       END IF
20005       IZ0 = NINT (Z)
20006       IF ( IZ0 .LE. 0 ) THEN
20007          DT_ENRG = A * EXNEUT
20008          RETURN
20009       END IF
20010       N   = NINT (A-Z)
20011       IF ( N .LE. 0 ) THEN
20012          DT_ENRG = Z * EXHYDR
20013          RETURN
20014       END IF
20015       AM2ZOA= (A-Z-Z)/A
20016       AM2ZOA=AM2ZOA*AM2ZOA
20017       A13 = RMASS(NINT(A))
20018 *     A13 = A**.3333333333333333D+00
20019       AM13 = 1.D+00/A13
20020       EV=-17.0354D+00*(1.D+00 -1.84619 D+00*AM2ZOA)*A
20021       ES= 25.8357D+00*(1.D+00 -1.712185D+00*AM2ZOA)*
20022      &    (1.D+00 -0.62025D+00*AM13*AM13)*
20023      &    (A13*A13 -.62025D+00)
20024       EC= 0.799D+00*Z*(Z-1.D+00)*AM13*(((1.5772D+00*AM13 +1.2273D+00)*
20025      &    AM13-1.5849D+00)*
20026      &    AM13*AM13 +1.D+00)
20027       EEX= -0.4323D+00*AM13*Z**1.3333333D+00*
20028      &   (((0.49597D+00*AM13 -0.14518D+00)*AM13 -0.57811D+00) * AM13
20029      &   + 1.D+00)
20030       DT_ENRG=8.367D+00*A-0.783D+00*Z +EV +ES +EC +EEX+CAM2(IZ0)+CAM3(N)
20031       DT_ENRG=(DT_ENRG + A * O16OLD ) * O16RAT - A * ( C12NEW - ADJUST )
20032       DT_ENRG  = MIN ( DT_ENRG, Z * EXHYDR + ( A - Z ) * EXNEUT )
20033       RETURN
20034 *=== End of function Enrg =============================================*
20035       END
20036
20037 *$ CREATE DT_INCINI.FOR
20038 *COPY DT_INCINI
20039 *                                                                      *
20040 *=== incini ===========================================================*
20041 *                                                                      *
20042       SUBROUTINE DT_INCINI
20043
20044       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20045       SAVE
20046
20047       PARAMETER ( ZERZER = 0.D+00 )
20048       PARAMETER ( ONEONE = 1.D+00 )
20049       PARAMETER ( TWOTWO = 2.D+00 )
20050       PARAMETER ( THRTHR = 3.D+00 )
20051       PARAMETER ( FOUFOU = 4.D+00 )
20052       PARAMETER ( EIGEIG = 8.D+00 )
20053       PARAMETER ( ANINEN = 9.D+00 )
20054       PARAMETER ( HLFHLF = 0.5D+00 )
20055       PARAMETER ( ONETHI = ONEONE / THRTHR )
20056       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20057       PARAMETER ( PLABRC = 0.197327053        D+00 )
20058       PARAMETER ( AMELCT = 0.51099906         D-03 )
20059       PARAMETER ( AMUGEV = 0.93149432         D+00 )
20060       PARAMETER ( AMPRTN = 0.93827231         D+00 )
20061       PARAMETER ( AMNTRN = 0.93956563         D+00 )
20062       PARAMETER ( AMDEUT = 1.87561339         D+00 )
20063       PARAMETER ( EMVGEV = 1.0                D-03 )
20064
20065       PARAMETER ( LUNOUT = 6  )
20066 *
20067 *----------------------------------------------------------------------*
20068 *                                                                      *
20069 *     Created on  10  june  1990   by    Alfredo Ferrari & Paola Sala  *
20070 *                                                   Infn - Milan       *
20071 *                                                                      *
20072 *     Last change on 02-may-95     by    Alfredo Ferrari               *
20073 *                                                                      *
20074 *                                                                      *
20075 *----------------------------------------------------------------------*
20076 *
20077 * (original name: FHEAVY,FHEAVC)
20078       PARAMETER ( MXHEAV = 100 )
20079       CHARACTER*8 ANHEAV
20080       COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
20081      &                CZHEAV (MXHEAV), TKHEAV (MXHEAV),
20082      &                PHEAVY (MXHEAV), WHEAVY (MXHEAV),
20083      &                AMHEAV  ( 12 ) , AMNHEA  ( 12 ) ,
20084      &                KHEAVY (MXHEAV), ICHEAV  ( 12 ) ,
20085      &                IBHEAV  ( 12 ) , NPHEAV
20086       COMMON /FKFHVC/ ANHEAV  ( 12 )
20087 * (original name: INPFLG)
20088       COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
20089 * (original name: FRBKCM)
20090       PARAMETER ( MXFFBK =     6 )
20091       PARAMETER ( MXZFBK =     9 )
20092       PARAMETER ( MXNFBK =    10 )
20093       PARAMETER ( MXAFBK =    16 )
20094       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
20095       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
20096       PARAMETER ( NXAFBK = MXAFBK + 1 )
20097       PARAMETER ( MXPSST =   300 )
20098       PARAMETER ( MXPSFB = 41000 )
20099       LOGICAL LFRMBK, LNCMSS
20100       COMMON /FKFRBK/  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
20101      &          EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
20102      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
20103      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
20104      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
20105      &          IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
20106      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
20107      &          IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
20108      &          IFBFRB, NBUFBK, LFRMBK, LNCMSS
20109 * (original name: NUCDAT)
20110       PARAMETER ( AMUAMU = AMUGEV )
20111       PARAMETER ( AMPROT = AMPRTN )
20112       PARAMETER ( AMNEUT = AMNTRN )
20113       PARAMETER ( AMELEC = AMELCT )
20114       PARAMETER ( R0NUCL = 1.12        D+00 )
20115       PARAMETER ( RCCOUL = 1.7         D+00 )
20116       PARAMETER ( FERTHO = 14.33       D-09 )
20117       PARAMETER ( EXPEBN = 2.39        D+00 )
20118       PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
20119       PARAMETER ( AMUC12 = AMUGEV - HLFHLF * AMELCT + BEXC12 / 12.D+00 )
20120       PARAMETER ( AMHYDR = AMPRTN + AMELCT  )
20121       PARAMETER ( AMHTON = AMHYDR - AMNTRN  )
20122       PARAMETER ( AMNTOU = AMNTRN - AMUC12  )
20123       PARAMETER ( AMUCSQ = AMUC12 * AMUC12 )
20124       PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 )
20125       PARAMETER ( GAMMIN = 1.0D-06 )
20126       PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN )
20127       PARAMETER ( TVEPSI = GAMMIN / 100.D+00 )
20128       COMMON /FKNDAT/ AV0WEL,     APFRMX,     AEFRMX,     AEFRMA,
20129      &                RDSNUC,     V0WELL (2), PFRMMX (2), EFRMMX (2),
20130      &                EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
20131      &                VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
20132      &                PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
20133      &                EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
20134      &                ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV    ,
20135      &                AMRCSQ    , ATO1O3    , ZTO1O3    , ELBNDE (0:100)
20136 * (original name: PAREVT)
20137       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
20138      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
20139       PARAMETER ( NALLWP = 39   )
20140       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
20141      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
20142      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
20143      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
20144 * (original name: NUCOLD)
20145       COMMON /FKNOLD/ HELP (2), HHLP (2), FTVTH (2), FINCX (2),
20146      &                EKPOLD (2), BBOLD, ZZOLD, SQROLD, ASEASQ,
20147      &                FSPRED, FEX0RD
20148 *
20149       BBOLD  = - 1.D+10
20150       ZZOLD  = - 1.D+10
20151       SQROLD = - 1.D+10
20152       APFRMX = PLABRC * ( ANINEN * PIPIPI / EIGEIG )**ONETHI / R0NUCL
20153       AMNUCL (1) = AMPROT
20154       AMNUCL (2) = AMNEUT
20155       AMNUSQ (1) = AMPROT * AMPROT
20156       AMNUSQ (2) = AMNEUT * AMNEUT
20157       AMNHLP = HLFHLF * ( AMNUCL (1) + AMNUCL (2) )
20158       ASQHLP = AMNHLP**2
20159 *     ASQHLP = HLFHLF * ( AMNUSQ (1) + AMNUSQ (2) )
20160       AEFRMX = SQRT ( ASQHLP + APFRMX**2 ) - AMNHLP
20161       AEFRMA = 0.3D+00 * APFRMX**2 / AMNHLP * ( ONEONE - APFRMX**2 /
20162      &         ( 5.6D+00 * ASQHLP ) )
20163       AV0WEL = AEFRMX + EBNDAV
20164       EBNDNG (1) = EBNDAV
20165       EBNDNG (2) = EBNDAV
20166       AEXC12 = EMVGEV * DT_ENERGY( 12.D+00, 6.D+00 )
20167       CEXC12 = EMVGEV * DT_ENRG( 12.D+00, 6.D+00 )
20168       AMMC12 = 12.D+00 * AMUGEV + AEXC12
20169       AMNC12 = AMMC12 - 6.D+00 * AMELCT + FERTHO * 6.D+00**EXPEBN
20170       AEXO16 = EMVGEV * DT_ENERGY( 16.D+00, 8.D+00 )
20171       CEXO16 = EMVGEV * DT_ENRG( 16.D+00, 8.D+00 )
20172       AMMO16 = 16.D+00 * AMUGEV + AEXO16
20173       AMNO16 = AMMO16 - 8.D+00 * AMELCT + FERTHO * 8.D+00**EXPEBN
20174       AEXS28 = EMVGEV * DT_ENERGY( 28.D+00, 14.D+00 )
20175       CEXS28 = EMVGEV * DT_ENRG( 28.D+00, 14.D+00 )
20176       AMMS28 = 28.D+00 * AMUGEV + AEXS28
20177       AMNS28 = AMMS28 - 14.D+00 * AMELCT + FERTHO * 14.D+00**EXPEBN
20178       AEXC40 = EMVGEV * DT_ENERGY( 40.D+00, 20.D+00 )
20179       CEXC40 = EMVGEV * DT_ENRG( 40.D+00, 20.D+00 )
20180       AMMC40 = 40.D+00 * AMUGEV + AEXC40
20181       AMNC40 = AMMC40 - 20.D+00 * AMELCT + FERTHO * 20.D+00**EXPEBN
20182       AEXF56 = EMVGEV * DT_ENERGY( 56.D+00, 26.D+00 )
20183       CEXF56 = EMVGEV * DT_ENRG( 56.D+00, 26.D+00 )
20184       AMMF56 = 56.D+00 * AMUGEV + AEXF56
20185       AMNF56 = AMMF56 - 26.D+00 * AMELCT + FERTHO * 26.D+00**EXPEBN
20186       AEX107 = EMVGEV * DT_ENERGY( 107.D+00, 47.D+00 )
20187       CEX107 = EMVGEV * DT_ENRG( 107.D+00, 47.D+00 )
20188       AMM107 = 107.D+00 * AMUGEV + AEX107
20189       AMN107 = AMM107 - 47.D+00 * AMELCT + FERTHO * 47.D+00**EXPEBN
20190       AEX132 = EMVGEV * DT_ENERGY( 132.D+00, 54.D+00 )
20191       CEX132 = EMVGEV * DT_ENRG( 132.D+00, 54.D+00 )
20192       AMM132 = 132.D+00 * AMUGEV + AEX132
20193       AMN132 = AMM132 - 54.D+00 * AMELCT + FERTHO * 54.D+00**EXPEBN
20194       AEX181 = EMVGEV * DT_ENERGY( 181.D+00, 73.D+00 )
20195       CEX181 = EMVGEV * DT_ENRG( 181.D+00, 73.D+00 )
20196       AMM181 = 181.D+00 * AMUGEV + AEX181
20197       AMN181 = AMM181 - 73.D+00 * AMELCT + FERTHO * 73.D+00**EXPEBN
20198       AEX208 = EMVGEV * DT_ENERGY( 208.D+00, 82.D+00 )
20199       CEX208 = EMVGEV * DT_ENRG( 208.D+00, 82.D+00 )
20200       AMM208 = 208.D+00 * AMUGEV + AEX208
20201       AMN208 = AMM208 - 82.D+00 * AMELCT + FERTHO * 82.D+00**EXPEBN
20202       AEX238 = EMVGEV * DT_ENERGY( 238.D+00, 92.D+00 )
20203       CEX238 = EMVGEV * DT_ENRG( 238.D+00, 92.D+00 )
20204       AMM238 = 238.D+00 * AMUGEV + AEX238
20205       AMN238 = AMM238 - 92.D+00 * AMELCT + FERTHO * 92.D+00**EXPEBN
20206
20207       AMHEAV (1) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ZERZER )
20208       AMHEAV (2) = AMUGEV + EMVGEV * DT_ENERGY( ONEONE, ONEONE )
20209       AMHEAV (3) = TWOTWO * AMUGEV
20210      &             + EMVGEV * DT_ENERGY( TWOTWO, ONEONE )
20211       AMHEAV (4) = THRTHR * AMUGEV
20212      &             + EMVGEV * DT_ENERGY( THRTHR, ONEONE )
20213       AMHEAV (5) = THRTHR * AMUGEV
20214      &             + EMVGEV * DT_ENERGY( THRTHR, TWOTWO )
20215       AMHEAV (6) = FOUFOU * AMUGEV
20216      &             + EMVGEV * DT_ENERGY( FOUFOU, TWOTWO )
20217       ELBNDE (0) = ZERZER
20218       ELBNDE (1) = 13.6D-09
20219       DO 2000 IZ = 2, 100
20220          ELBNDE ( IZ ) = FERTHO * DBLE ( IZ )**EXPEBN
20221 2000  CONTINUE
20222       AMNHEA (1) = AMHEAV (1) + ELBNDE (0)
20223       AMNHEA (2) = AMHEAV (2) - AMELCT + ELBNDE (1)
20224       AMNHEA (3) = AMHEAV (3) - AMELCT + ELBNDE (1)
20225       AMNHEA (4) = AMHEAV (4) - AMELCT + ELBNDE (1)
20226       AMNHEA (5) = AMHEAV (5) - TWOTWO * AMELCT + ELBNDE (2)
20227       AMNHEA (6) = AMHEAV (6) - TWOTWO * AMELCT + ELBNDE (2)
20228       IF ( LEVPRT ) THEN
20229          WRITE ( LUNOUT, * )' **** Evaporation from residual nucleus',
20230      &                      ' activated **** '
20231          IF ( LDEEXG ) WRITE ( LUNOUT, * )' **** Deexcitation gamma',
20232      &                      ' production activated **** '
20233 **sr 18.5.95
20234 * commented, since obsolete
20235 C        IF ( LHEAVY ) WRITE ( LUNOUT, * )' **** Evaporated "heavies"',
20236 C    &                      ' transport activated **** '
20237          IF ( IFISS .GT. 0 )
20238      &                 WRITE ( LUNOUT, * )' **** High Energy fission ',
20239      &                      ' requested & activated **** '
20240          IF ( LFRMBK )
20241      &                 WRITE ( LUNOUT, * )' **** Fermi Break Up ',
20242      &                      ' requested & activated **** '
20243          IF ( LFRMBK ) CALL DT_FRBKIN(.FALSE.,.FALSE.)
20244       ELSE
20245          LDEEXG = .FALSE.
20246          LHEAVY = .FALSE.
20247          LFRMBK = .FALSE.
20248          IFISS  = 0
20249       END IF
20250       RETURN
20251 *=== End of subroutine incini =========================================*
20252       END
20253
20254 *$ CREATE DT_STALIN.FOR
20255 *COPY DT_STALIN
20256 *                                                                      *
20257 *=== stalin ===========================================================*
20258 *                                                                      *
20259       SUBROUTINE DT_STALIN
20260
20261       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20262       SAVE
20263       PARAMETER ( ANGLGB = 5.0D-16 )
20264       PARAMETER ( ZERZER = 0.D+00 )
20265       PARAMETER ( ONEONE = 1.D+00 )
20266       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20267       PARAMETER ( AMUGEV = 0.93149432         D+00 )
20268       PARAMETER ( EMVGEV = 1.0                D-03 )
20269       PARAMETER ( NSTBIS = 304  )
20270       PARAMETER ( LUNIN  = 5  )
20271       PARAMETER ( LUNOUT = 6  )
20272 *
20273 *----------------------------------------------------------------------*
20274 *                                                                      *
20275 *     STAbility LINe calculation:                                      *
20276 *                                                                      *
20277 *     Created on 04 december 1992  by    Alfredo Ferrari & Paola Sala  *
20278 *                                                   Infn - Milan       *
20279 *                                                                      *
20280 *     Last change on 04-dec-92     by    Alfredo Ferrari               *
20281 *                                                                      *
20282 *                                                                      *
20283 *----------------------------------------------------------------------*
20284 *
20285 * (original name: ISOTOP)
20286       PARAMETER ( NAMSMX = 270 )
20287       PARAMETER ( NZGVAX =  15 )
20288       PARAMETER ( NISMMX = 574 )
20289       COMMON /FKISOT/ WAPS   (NAMSMX,NZGVAX),  T12NUC (NAMSMX,NZGVAX),
20290      &                WAPISM (NISMMX), T12ISM (NISMMX),
20291      &                ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
20292      &                AMSSST (100)  , ISOMNM (NSTBIS), ISONDX (2,100),
20293      &                JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
20294      &                INWAPS (NAMSMX), JSPISM (NISMMX),
20295      &                JPTISM (NISMMX), IZWISM (NISMMX),
20296      &                INWISM (0:NAMSMX)
20297 *
20298       DIMENSION ZNORM (260)
20299 *  +-------------------------------------------------------------------*
20300 *  |
20301       DO 1000 IZ=1,100
20302          DO 500 J=1,2
20303             ASTLIN (J,IZ) = ZERZER
20304   500    CONTINUE
20305  1000 CONTINUE
20306 *  |
20307 *  +-------------------------------------------------------------------*
20308 *  +-------------------------------------------------------------------*
20309 *  |
20310       DO 2000 IA=1,260
20311          ZNORM (IA) = ZERZER
20312          DO 1500 J=1,2
20313             ZSTLIN (J,IA) = ZERZER
20314  1500    CONTINUE
20315  2000 CONTINUE
20316 *  |
20317 *  +-------------------------------------------------------------------*
20318 *  +-------------------------------------------------------------------*
20319 *  |  Loop on the Atomic Number
20320       DO 3000 IZ=1,100
20321          AMSSST (IZ) = ZERZER
20322          ANORM       = ONEONE
20323          ZTAR        = IZ
20324 *  |  +----------------------------------------------------------------*
20325 *  |  |    Loop on the stable isotopes
20326          DO 2500 IS = ISONDX (1,IZ), ISONDX (2,IZ)
20327             IA = ISOMNM (IS)
20328             ASTLIN (1,IZ) = ASTLIN (1,IZ) + ABUISO (IS) * IA
20329             ASTLIN (2,IZ) = ASTLIN (2,IZ) + ABUISO (IS) * IA**2
20330             ZNORM    (IA) = ZNORM (IA) + ABUISO (IS)
20331             ZSTLIN (1,IA) = ZSTLIN (1,IA) + ABUISO (IS) * IZ
20332             ZSTLIN (2,IA) = ZSTLIN (2,IA) + ABUISO (IS) * IZ**2
20333             AHELP  = IA
20334             IF ( AHELP .LE. 1.00001D+00 ) THEN
20335                ANORM = ONEONE / ( ONEONE - ABUISO (IS) )
20336                GO TO 2500
20337             END IF
20338             AMSSST (IZ) = ABUISO (IS) * ( AHELP * AMUGEV
20339      &                  + EMVGEV * DT_ENERGY(AHELP,ZTAR) ) + AMSSST (IZ)
20340  2500    CONTINUE
20341 *  |  |
20342 *  |  +----------------------------------------------------------------*
20343          AMSSST (IZ) = ANORM * AMSSST (IZ) / AMUGEV
20344 *  |  Normalize and print A_stab versus Z data:
20345          ASTLIN (2,IZ) = MAX ( SQRT (ASTLIN(2,IZ)-ASTLIN(1,IZ)**2),
20346      &                         0.5D+00 )
20347 *        WRITE (LUNOUT,*)'  Z:',IZ,' A_stab:',SNGL(ASTLIN(1,IZ)),
20348 *    &                   '  Sigma_st',SNGL(ASTLIN(2,IZ))
20349  3000 CONTINUE
20350 *  |
20351 *  +-------------------------------------------------------------------*
20352 *  +-------------------------------------------------------------------*
20353 *  |  Normalize and print Z_stab versus A data:
20354       DO 4000 IA=1,260
20355          ZSTLIN (1,IA) = ZSTLIN (1,IA) / MAX ( ZNORM (IA), 1.D-10 )
20356          ZSTLIN (2,IA) = ZSTLIN (2,IA) / MAX ( ZNORM (IA), 1.D-10 )
20357          ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ZSTLIN (1,IA)**2 )
20358          IF ( ZNORM (IA) .GT. ANGLGB )
20359 **sr 2.11. avoid underflows at Pentium
20360      &      ZSTLIN (2,IA) =
20361      &               MAX ( SQRT ( ABS(ZSTLIN(2,IA)-ZSTLIN(1,IA)**2) ),
20362 C    &      ZSTLIN (2,IA) = MAX ( SQRT (ZSTLIN(2,IA)-ZSTLIN(1,IA)**2),
20363      &                            0.3D+00 )
20364  4000 CONTINUE
20365 *  |
20366 *  +-------------------------------------------------------------------*
20367 *  +-------------------------------------------------------------------*
20368 *  |  Normalize and print Z_stab versus A data:
20369       DO 5000 IA=1,260
20370          IF ( ZNORM (IA) .LE. ANGLGB ) THEN
20371             DO 4200 JA = IA-1,1,-1
20372                IF ( ZNORM (JA) .GT. ANGLGB ) THEN
20373                   IA1 = JA
20374                   GO TO 4300
20375                END IF
20376  4200       CONTINUE
20377  4300       CONTINUE
20378             DO 4400 JA = IA+1,260
20379                IF ( ZNORM (JA) .GT. ANGLGB ) THEN
20380                   IA2 = JA
20381                   GO TO 4500
20382                END IF
20383  4400       CONTINUE
20384             IA2 = IA1
20385             IA1 = IA1 - 1
20386  4500       CONTINUE
20387             ZSTLIN (1,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1)
20388      &                    * ( ZSTLIN (1,IA2) - ZSTLIN (1,IA1) )
20389      &                    + ZSTLIN (1,IA1)
20390             ZSTLIN (2,IA) = DBLE (IA-IA1) / DBLE (IA2-IA1)
20391      &                    * ( ZSTLIN (2,IA2) - ZSTLIN (2,IA1) )
20392      &                    + ZSTLIN (2,IA1)
20393          END IF
20394          IZ = MIN ( 100, NINT (ZSTLIN(1,IA)) )
20395          ATOZ = IZ / ASTLIN (1,IZ)
20396          ZSTLIN (2,IA) = MAX ( ZSTLIN (2,IA), ATOZ * ASTLIN (2,IZ) )
20397 *        WRITE (LUNOUT,*)'  A:',IA,' Z_stab:',SNGL(ZSTLIN(1,IA)),
20398 *    &                   '  Sigma_st',SNGL(ZSTLIN(2,IA))
20399  5000 CONTINUE
20400 *  |
20401 *  +-------------------------------------------------------------------*
20402       RETURN
20403       END
20404
20405 *$ CREATE DT_BERTTP.FOR
20406 *COPY DT_BERTTP
20407 *
20408 *=== berttp ===========================================================*
20409 *                                                                      *
20410       SUBROUTINE DT_BERTTP
20411
20412       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20413       SAVE
20414
20415       PARAMETER ( CSNNRM = 2.0D-15 )
20416       PARAMETER ( ZERZER = 0.D+00 )
20417       PARAMETER ( ONEONE = 1.D+00 )
20418       PARAMETER ( THRTHR = 3.D+00 )
20419       PARAMETER ( SIXSIX = 6.D+00 )
20420       PARAMETER ( ONETHI = ONEONE / THRTHR )
20421       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
20422       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
20423       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
20424       PARAMETER ( EMVGEV = 1.0                D-03 )
20425
20426       PARAMETER ( NSTBIS = 304  )
20427
20428       PARAMETER ( LUNIN  = 5  )
20429       PARAMETER ( LUNOUT = 6  )
20430 **sr 19.5. set error output-unit from 15 to 6
20431       PARAMETER ( LUNERR = 6  )
20432 C---------------------------------------------------------------------
20433 C SUBNAME = DT_BERTTP --- READ BERTINI DATA
20434 C---------------------------------------------------------------------
20435 C     ---------------------------------- I-N-C DATA
20436 C     COMMON R8(2127),R4(64),CRSC(600,4),R8B(336),CS(29849)
20437 C     REAL*8 R8,R8B,CRSC,CS
20438 C     REAL*4 R4
20439 C     --------------------------------- EVAPORATION DATA
20440 * (original name: COOKCM)
20441       PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 )
20442       LOGICAL LDEFOZ, LDEFON
20443       PARAMETER ( INCOOK = 150, IZCOOK = 98 )
20444       COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN,
20445      &                SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK),
20446      &                PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK)
20447 * (original name: EVA0)
20448       COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
20449      *                FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
20450      *                CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
20451      *                T (4,7), RMASS (297), ALPH (297), BET (297),
20452      *                APRIME (250), IA (6), IZ (6)
20453 * (original name: FRBKCM)
20454       PARAMETER ( MXFFBK =     6 )
20455       PARAMETER ( MXZFBK =     9 )
20456       PARAMETER ( MXNFBK =    10 )
20457       PARAMETER ( MXAFBK =    16 )
20458       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
20459       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
20460       PARAMETER ( NXAFBK = MXAFBK + 1 )
20461       PARAMETER ( MXPSST =   300 )
20462       PARAMETER ( MXPSFB = 41000 )
20463       LOGICAL LFRMBK, LNCMSS
20464       COMMON /FKFRBK/  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
20465      &          EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
20466      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
20467      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
20468      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
20469      &          IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
20470      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
20471      &          IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
20472      &          IFBFRB, NBUFBK, LFRMBK, LNCMSS
20473 * (original name: HETTP)
20474       COMMON /FKHETP/  NHSTP,NBERTP,IOSUB,INSRS
20475 * (original name: INPFLG)
20476       COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
20477 * (original name: ISOTOP)
20478       PARAMETER ( NAMSMX = 270 )
20479       PARAMETER ( NZGVAX =  15 )
20480       PARAMETER ( NISMMX = 574 )
20481       COMMON /FKISOT/ WAPS   (NAMSMX,NZGVAX),  T12NUC (NAMSMX,NZGVAX),
20482      &                WAPISM (NISMMX), T12ISM (NISMMX),
20483      &                ABUISO (NSTBIS), ASTLIN (2,100), ZSTLIN (2,260),
20484      &                AMSSST (100)  , ISOMNM (NSTBIS), ISONDX (2,100),
20485      &                JSPNUC (NAMSMX,NZGVAX), JPTNUC (NAMSMX,NZGVAX),
20486      &                INWAPS (NAMSMX), JSPISM (NISMMX),
20487      &                JPTISM (NISMMX), IZWISM (NISMMX),
20488      &                INWISM (0:NAMSMX)
20489 * (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII)
20490       PARAMETER ( PI     = PIPIPI )
20491       PARAMETER ( PISQ   = PIPISQ )
20492       PARAMETER ( SKTOHL = 0.5456645846610345D+00 )
20493       PARAMETER ( RZNUCL = 1.12        D+00 )
20494       PARAMETER ( RMSPRO = 0.8         D+00 )
20495       PARAMETER ( R0PROT = RMSPRO / SQRT12  )
20496       PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT
20497      &          / R0PROT )
20498       PARAMETER ( RLLE04 = RZNUCL )
20499       PARAMETER ( RLLE16 = RZNUCL )
20500       PARAMETER ( RLGT16 = RZNUCL )
20501       PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 )
20502       PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 )
20503       PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 )
20504       PARAMETER ( SKLE04 = 1.4D+00 )
20505       PARAMETER ( SKLE16 = 1.9D+00 )
20506       PARAMETER ( SKGT16 = 2.4D+00 )
20507       PARAMETER ( HLLE04 = SKTOHL * SKLE04 )
20508       PARAMETER ( HLLE16 = SKTOHL * SKLE16 )
20509       PARAMETER ( HLGT16 = SKTOHL * SKGT16 )
20510       PARAMETER ( ALPHA0 = 0.1D+00 )
20511       PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 )
20512       PARAMETER ( GAMSK0 = 0.9D+00 )
20513       PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 )
20514       PARAMETER ( POTME0 = 0.6666666666666667D+00 )
20515       PARAMETER ( POTBA0 = 1.D+00 )
20516       PARAMETER ( PNFRAT = 1.533D+00 )
20517       PARAMETER ( RADPIM = 0.035D+00 )
20518       PARAMETER ( RDPMHL = 14.D+00   )
20519       PARAMETER ( APMRST = 4.D+00 / 44.D+00 )
20520       PARAMETER ( APMPRO = 1.D+00 / 6.D+00 )
20521       PARAMETER ( APPPRO = 5.D+00 / 6.D+00 )
20522       PARAMETER ( AP0PFS = 0.5D+00 )
20523       PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 )
20524       PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 )
20525       PARAMETER ( XPAUCO = 1.88495407241652 D+00 )
20526       PARAMETER ( MXSCIN = 50     )
20527       LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY,
20528      &        LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC
20529       COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260),
20530      &                RADTAB (2:260), SKITAB (2:260), HALTAB (2:260),
20531      &                SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260),
20532      &                CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260),
20533      &                PFRTAB (2:260)
20534       COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP,
20535      &                ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO,
20536      &                RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR,
20537      &                YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN,
20538      &                RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM,
20539      &                PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2,
20540      &                PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT,
20541      &                BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2,
20542      &                YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3,
20543      &                XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC,
20544      &                SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ,
20545      &                R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE,
20546      &                PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY,
20547      &                EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ,
20548      &                PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM,
20549      &                EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3,
20550      &                PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM,
20551      &                BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN
20552       COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2),
20553      &                RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN,
20554      &                EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF,
20555      &                BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC,
20556      &                WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES,
20557      &                POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND,
20558      &                BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4),
20559      &                SIGPAB (3), SIGNAB (3), HHLP   (2), FORTOT (2),
20560      &                FPNBLC, DPNBLC, FFTFLG, IFTFLG,
20561      &                IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2,
20562      &                KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3,
20563      &                NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM,
20564      &                IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ,
20565      &                LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC
20566       COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT
20567       COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN),
20568      &                YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN),
20569      &                AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX,
20570      &                NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN),
20571      &                NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN),
20572      &                ISCTYP (0:MXSCIN), NUSCIN, NEXPEM,
20573      &                LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH,
20574      &                LNCDCY, LNUSCT
20575       DIMENSION AWSTAB (2:260), SIGMAB (3)
20576       EQUIVALENCE ( DEFPRO, DEFNUC (1) )
20577       EQUIVALENCE ( DEFNEU, DEFNUC (2) )
20578       EQUIVALENCE ( RHOIPP, RHONCP (1) )
20579       EQUIVALENCE ( RHOINP, RHONCP (2) )
20580       EQUIVALENCE ( RHOIP2, RHONC2 (1) )
20581       EQUIVALENCE ( RHOIN2, RHONC2 (2) )
20582       EQUIVALENCE ( RHOIP3, RHONC3 (1) )
20583       EQUIVALENCE ( RHOIN3, RHONC3 (2) )
20584       EQUIVALENCE ( RHOIPT, RHONCT (1) )
20585       EQUIVALENCE ( RHOINT, RHONCT (2) )
20586       EQUIVALENCE ( OMALHL, SK3PAR )
20587       EQUIVALENCE ( ALPHAL, HABPAR )
20588       EQUIVALENCE ( ALPTAB (2), AWSTAB (2) )
20589       EQUIVALENCE ( SIGMPE, SIGMPR (1) )
20590       EQUIVALENCE ( SIGMPC, SIGMPR (2) )
20591       EQUIVALENCE ( SIGMPI, SIGMPR (3) )
20592       EQUIVALENCE ( SIGMPA, SIGMPR (4) )
20593       EQUIVALENCE ( SIGMNE, SIGMNU (1) )
20594       EQUIVALENCE ( SIGMNC, SIGMNU (2) )
20595       EQUIVALENCE ( SIGMNI, SIGMNU (3) )
20596       EQUIVALENCE ( SIGMNA, SIGMNU (4) )
20597       EQUIVALENCE ( SIGMA2, SIGPAB (1) )
20598       EQUIVALENCE ( SIGMA3, SIGPAB (2) )
20599       EQUIVALENCE ( SIGMAS, SIGPAB (3) )
20600       EQUIVALENCE ( SIGPAB (1), SIGMAB (1) )
20601 * (original name: NUCLEV)
20602       LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL
20603       COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2),
20604      &                DEFMAG (2), ENNCLV (160,2), RANCLV (160,2),
20605      &                CUMRAD (0:160,2), RUSNUC (2),
20606      &                ENPLVL (114), ENNLVL(164), JUSNUC (160,2),
20607      &                NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2),
20608      &                NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2),
20609      &                JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8),
20610      &                MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2),
20611      &                NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL,
20612      &                LFLVSL, LRLVSL, LEQSBL
20613       DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8),
20614      &          MGSSPR (19) , MGSSNE (25)
20615       EQUIVALENCE ( RUSNUC (1), RUSPRO )
20616       EQUIVALENCE ( RUSNUC (2), RUSNEU )
20617       EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) )
20618       EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) )
20619       EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) )
20620       EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) )
20621       EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) )
20622       EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) )
20623       EQUIVALENCE ( NTANUC (1), NTAPRO )
20624       EQUIVALENCE ( NTANUC (2), NTANEU )
20625       EQUIVALENCE ( NAVNUC (1), NAVPRO )
20626       EQUIVALENCE ( NAVNUC (2), NAVNEU )
20627       EQUIVALENCE ( NLSNUC (1), NLSPRO )
20628       EQUIVALENCE ( NLSNUC (2), NLSNEU )
20629       EQUIVALENCE ( NCONUC (1), NCOPRO )
20630       EQUIVALENCE ( NCONUC (2), NCONEU )
20631       EQUIVALENCE ( NSKNUC (1), NSKPRO )
20632       EQUIVALENCE ( NSKNUC (2), NSKNEU )
20633       EQUIVALENCE ( NHANUC (1), NHAPRO )
20634       EQUIVALENCE ( NHANUC (2), NHANEU )
20635       EQUIVALENCE ( NUSNUC (1), NUSPRO )
20636       EQUIVALENCE ( NUSNUC (2), NUSNEU )
20637       EQUIVALENCE ( NACNUC (1), NACPRO )
20638       EQUIVALENCE ( NACNUC (2), NACNEU )
20639       EQUIVALENCE ( JMXNUC (1), JMXPRO )
20640       EQUIVALENCE ( JMXNUC (2), JMXNEU )
20641       EQUIVALENCE ( MAGNUC (1), MAGPRO )
20642       EQUIVALENCE ( MAGNUC (2), MAGNEU )
20643 * (original name: PAREVT)
20644       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
20645      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
20646       PARAMETER ( NALLWP = 39   )
20647       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
20648      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
20649      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
20650      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
20651 * (original name: XSEPAR)
20652       COMMON /FKXSEP/ AANXSE (100), BBNXSE (100), CCNXSE (100),
20653      &                DDNXSE (100), EENXSE (100), ZZNXSE (100),
20654      &                EMNXSE (100), XMNXSE (100),
20655      &                AAPXSE (100), BBPXSE (100), CCPXSE (100),
20656      &                DDPXSE (100), EEPXSE (100), FFPXSE (100),
20657      &                ZZPXSE (100), EMPXSE (100), XMPXSE (100)
20658
20659 C---------------------------------------------------------------------
20660 **sr 17.5.95
20661 * modified for use in DPMJET
20662 C     WRITE( LUNOUT,'(A,I2)')
20663 C    & ' *** Reading evaporation and nuclear data from unit: ', NBERTP
20664 C     REWIND NBERTP
20665       IF (LEVPRT) WRITE(LUNOUT,1000)
20666  1000 FORMAT(/,1X,'BERTTP:',4X,'Initialization of evaporation module',
20667      &       /,12X,'------------------------------------',/)
20668       NBERNW = 23
20669 CPH      OPEN (UNIT=NBERNW,FILE='dpmjet.dat',STATUS='UNKNOWN')
20670
20671 **sr 17.5.
20672 *!!!! changed to be able to read the ASCII !!!!
20673 **
20674 C A. Ferrari: first of all read isotopic data
20675       READ (NBERNW,*) ISONDX
20676       READ (NBERNW,*) ISOMNM
20677       READ (NBERNW,*) ABUISO
20678 C     READ (NBERTP) ISONDX
20679 C     READ (NBERTP) ISOMNM
20680 C     READ (NBERTP) ABUISO
20681       DO 1 I=1,4
20682 C        READ  (NBERTP) (CRSC(J,I),J=1,600)
20683 C A. Ferrari: commented also the dummy read to save disk space
20684 C        READ  (NBERTP)
20685     1 CONTINUE
20686 C     READ  (NBERTP) CS
20687 C A. Ferrari: commented also the dummy read to save disk space
20688 C     READ  (NBERTP)
20689 C---------------------------------------------------------------------
20690       READ (NBERNW,*) (P0(I),P1(I),P2(I),I=1,1001)
20691       READ (NBERNW,*) IA,IZ
20692       DO 2 I=1,6
20693          FLA(I)=IA(I)
20694          FLZ(I)=IZ(I)
20695     2 CONTINUE
20696       READ (NBERNW,*) RHO,OMEGA
20697       READ (NBERNW,*) EXMASS
20698       READ (NBERNW,*) CAM2
20699       READ (NBERNW,*) CAM3
20700       READ (NBERNW,*) CAM4
20701       READ (NBERNW,*) CAM5
20702       READ (NBERNW,*) ((T(I,J),J=1,7),I=1,3)
20703       DO 3 I=1,7
20704          T(4,I) = ZERZER
20705     3 CONTINUE
20706       READ (NBERNW,*) RMASS
20707       READ (NBERNW,*) ALPH
20708       READ (NBERNW,*) BET
20709       READ (NBERNW,*) INWAPS
20710       READ (NBERNW,*) WAPS
20711       READ (NBERNW,*) T12NUC
20712       READ (NBERNW,*) JSPNUC
20713       READ (NBERNW,*) JPTNUC
20714       READ (NBERNW,*) INWISM
20715       READ (NBERNW,*) IZWISM
20716       READ (NBERNW,*) WAPISM
20717       READ (NBERNW,*) T12ISM
20718       READ (NBERNW,*) JSPISM
20719       READ (NBERNW,*) JPTISM
20720       READ (NBERNW,*) APRIME
20721       IF (LEVPRT)
20722      &WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***'
20723       READ (NBERNW,*) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP
20724       IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR.
20725      &     ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN
20726          WRITE (LUNOUT,*)
20727      &         ' *** Inconsistent Nuclear Geometry data on file ***'
20728          STOP
20729       END IF
20730       READ (NBERNW,*) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB,
20731      &              EKATAB, PFATAB, PFRTAB
20732       READ (NBERNW,*) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE,
20733      &              EMNXSE, XMNXSE
20734       READ (NBERNW,*) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE,
20735      &              ZZPXSE, EMPXSE, XMPXSE
20736 *  Data about Fermi-breakup:
20737       READ (NBERNW,*) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF
20738       IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE.
20739      &     MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN
20740          WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data',
20741      &                   ' in the Nuclear Data file ***'
20742          STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA'
20743       END IF
20744       READ (NBERNW,*) IFRBKN
20745       READ (NBERNW,*) IFRBKZ
20746       READ (NBERNW,*) IFBKSP
20747       READ (NBERNW,*) IFBKST
20748       READ (NBERNW,*) EEXFBK
20749
20750       CLOSE (UNIT=NBERNW)
20751
20752 C     READ (NBERTP) (P0(I),P1(I),P2(I),I=1,1001)
20753 C     READ (NBERTP) IA,IZ
20754 C     DO 2 I=1,6
20755 C        FLA(I)=IA(I)
20756 C        FLZ(I)=IZ(I)
20757 C   2 CONTINUE
20758 C     READ (NBERTP) RHO,OMEGA
20759 C     READ (NBERTP) EXMASS
20760 C     READ (NBERTP) CAM2
20761 C     READ (NBERTP) CAM3
20762 C     READ (NBERTP) CAM4
20763 C     READ (NBERTP) CAM5
20764 C     READ (NBERTP) ((T(I,J),J=1,7),I=1,3)
20765 C     DO 3 I=1,7
20766 C        T(4,I) = ZERZER
20767 C   3 CONTINUE
20768 C     READ (NBERTP) RMASS
20769 C     READ (NBERTP) ALPH
20770 C     READ (NBERTP) BET
20771 C     READ (NBERTP) INWAPS
20772 C     READ (NBERTP) WAPS
20773 C     READ (NBERTP) T12NUC
20774 C     READ (NBERTP) JSPNUC
20775 C     READ (NBERTP) JPTNUC
20776 C     READ (NBERTP) INWISM
20777 C     READ (NBERTP) IZWISM
20778 C     READ (NBERTP) WAPISM
20779 C     READ (NBERTP) T12ISM
20780 C     READ (NBERTP) JSPISM
20781 C     READ (NBERTP) JPTISM
20782 C     READ (NBERTP) APRIME
20783 C     WRITE( LUNOUT,'(A)' ) ' *** Evaporation: using 1977 Waps data ***'
20784 C     READ (NBERTP) AHELP , BHELP , LRMSCH, LRD1O2, LTRASP
20785 C     IF ( ABS (AHELP-ALPHA0) .GT. CSNNRM * ALPHA0 .OR.
20786 C    &     ABS (BHELP-GAMSK0) .GT. CSNNRM * GAMSK0 ) THEN
20787 C        WRITE (LUNOUT,*)
20788 C    &         ' *** Inconsistent Nuclear Geometry data on file ***'
20789 C        STOP
20790 C     END IF
20791 C     READ (NBERTP) RHOTAB, RHATAB, ALPTAB, RADTAB, SKITAB, HALTAB,
20792 C    &              EKATAB, PFATAB, PFRTAB
20793 C     READ (NBERTP) AANXSE, BBNXSE, CCNXSE, DDNXSE, EENXSE, ZZNXSE,
20794 C    &              EMNXSE, XMNXSE
20795 C     READ (NBERTP) AAPXSE, BBPXSE, CCPXSE, DDPXSE, EEPXSE, FFPXSE,
20796 C    &              ZZPXSE, EMPXSE, XMPXSE
20797 *  Data about Fermi-breakup:
20798 C     READ (NBERTP) IPOSST, MXPDUM, MXADUM, MXNDUM, MXZDUM, IFBSTF
20799 C     IF ( MXADUM .NE. MXAFBK .OR. MXNDUM .NE. MXNFBK .OR. MXZDUM .NE.
20800 C    &     MXZFBK .OR. MXPDUM .NE. MXPSST ) THEN
20801 C        WRITE (LUNOUT,*)' *** Inconsistent Fermi BreakUp data',
20802 C    &                   ' in the Nuclear Data file ***'
20803 C        STOP 'STOP:BERTTP-INCONS-FERMI-BREAKUP-DATA'
20804 C     END IF
20805 C     READ (NBERTP) IFRBKN
20806 C     READ (NBERTP) IFRBKZ
20807 C     READ (NBERTP) IFBKSP
20808 C     READ (NBERTP) IFBKST
20809 C     READ (NBERTP) EEXFBK
20810 C     CLOSE (UNIT=NBERTP)
20811       DO 100 JZ = 1, 130
20812          SHENUC ( JZ, 1 ) = EMVGEV * ( CAM2 (JZ) + CAM4 (JZ) )
20813   100 CONTINUE
20814       DO 200 JA = 1, 200
20815          SHENUC ( JA, 2 ) = EMVGEV * ( CAM3 (JA) + CAM5 (JA) )
20816   200 CONTINUE
20817       CALL DT_STALIN
20818       IF ( ILVMOD .LE. 0 ) THEN
20819          ILVMOD = IB0
20820       ELSE
20821          IB0 = ILVMOD
20822       END IF
20823       IF ( LLVMOD ) THEN
20824          DO 300 JZ = 1, IZCOOK
20825             CAM4 (JZ) = PZCOOK (JZ)
20826   300    CONTINUE
20827          DO 400 JN = 1, INCOOK
20828             CAM5 (JN) = PNCOOK (JZ)
20829   400    CONTINUE
20830       END IF
20831 **sr
20832       IF (LEVPRT) THEN
20833          WRITE (LUNOUT,*)
20834          IF ( ILVMOD .EQ. 1 ) THEN
20835             WRITE (LUNOUT,*)
20836      &   ' **** Standard EVAP T=0 level density used ****'
20837          ELSE IF ( ILVMOD .EQ. 2 ) THEN
20838             WRITE (LUNOUT,*)
20839      &   ' **** Gilbert & Cameron T=0 N,Z-dep. level density used ****'
20840          ELSE IF ( ILVMOD .EQ. 3 ) THEN
20841             WRITE (LUNOUT,*)
20842      &      ' **** Julich A-dependent level density used ****'
20843          ELSE IF ( ILVMOD .EQ. 4 ) THEN
20844             WRITE (LUNOUT,*)
20845      &   ' **** Brancazio & Cameron T=0 N,Z-dep. level density used',
20846      &                                                          ' ****'
20847          ELSE
20848             WRITE (LUNOUT,*)
20849      &   ' **** Unknown T=0 level density option requested ****'
20850             STOP 'BERTTP-ILVMOD'
20851          END IF
20852          IF ( JLVMOD .LE. 0 ) THEN
20853             GAMIGN = ZERZER
20854             WRITE (LUNOUT,*)
20855      &   ' **** No Excitation en. dependence for level densities ****'
20856          ELSE IF ( JLVMOD .EQ. 1 ) THEN
20857             WRITE (LUNOUT,*)
20858      &   ' **** Ignyatuk (1975, 1st) level density en. dep. used ****'
20859             WRITE (LUNOUT,*)
20860      &   ' **** with Ignyatuk (1975, 1st) set of parameters for T=oo',
20861      &                                                        ' ****'
20862             GAMIGN = 0.054D+00
20863             BETIGN = -6.3 D-05
20864             ALPIGN = 0.154D+00
20865             POWIGN = ZERZER
20866          ELSE IF ( JLVMOD .EQ. 2 ) THEN
20867             WRITE (LUNOUT,*)
20868      &   ' ****   Ignyatuk (1975, 1st) level density en. dep. used ****'
20869             WRITE (LUNOUT,*)
20870      &   ' **** with UNKNOWN set of parameters for T=oo ****'
20871             STOP 'BERTTP-JLVMOD'
20872          ELSE IF ( JLVMOD .EQ. 3 ) THEN
20873             WRITE (LUNOUT,*)
20874      &   ' ****   Ignyatuk (1975, 1st) level density en. dep. used ****'
20875             WRITE (LUNOUT,*)
20876      &   ' **** with UNKNOWN set of parameters for T=oo ****'
20877             STOP 'BERTTP-JLVMOD'
20878          ELSE IF ( JLVMOD .EQ. 4 ) THEN
20879             WRITE (LUNOUT,*)
20880      &   ' ****   Ignyatuk (1975, 2nd) level density en. dep. used ****'
20881             WRITE (LUNOUT,*)
20882      &   ' **** with Ignyatuk (1975, 2nd) set of parameters for T=oo',
20883      &                                                        ' ****'
20884             GAMIGN = 0.054D+00
20885             BETIGN = 0.162D+00
20886             ALPIGN = 0.114D+00
20887             POWIGN = -ONETHI
20888          ELSE IF ( JLVMOD .EQ. 5 ) THEN
20889             WRITE (LUNOUT,*)
20890      &   ' ****  Ignyatuk (1975, 2nd) level density en. dep. used  ****'
20891             WRITE (LUNOUT,*)
20892      &   ' **** with Iljinov & Mebel 1st set of parameters for T=oo****'
20893             GAMIGN = 0.051D+00
20894             BETIGN = 0.098D+00
20895             ALPIGN = 0.114D+00
20896             POWIGN = -ONETHI
20897          ELSE IF ( JLVMOD .EQ. 6 ) THEN
20898             WRITE (LUNOUT,*)
20899      &   ' ****   Ignyatuk (1975, 2nd) level density en. dep. used ****'
20900             WRITE (LUNOUT,*)
20901      &   ' **** with Iljinov & Mebel 2nd set of parameters for T=oo****'
20902             GAMIGN = -0.46D+00
20903             BETIGN = 0.107D+00
20904             ALPIGN = 0.111D+00
20905             POWIGN = -ONETHI
20906          ELSE IF ( JLVMOD .EQ. 7 ) THEN
20907             WRITE (LUNOUT,*)
20908      &   ' ****   Ignyatuk (1975, 2nd) level density en. dep. used ****'
20909             WRITE (LUNOUT,*)
20910      &   ' **** with Iljinov & Mebel 3rd set of parameters for T=oo****'
20911             GAMIGN = 0.059D+00
20912             BETIGN = 0.257D+00
20913             ALPIGN = 0.072D+00
20914             POWIGN = -ONETHI
20915          ELSE IF ( JLVMOD .EQ. 8 ) THEN
20916             WRITE (LUNOUT,*)
20917      &   ' ****   Ignyatuk (1975, 2nd) level density en. dep. used ****'
20918             WRITE (LUNOUT,*)
20919      &   ' **** with Iljinov & Mebel 4th set of parameters for T=oo****'
20920             GAMIGN = -0.37D+00
20921             BETIGN = 0.229D+00
20922             ALPIGN = 0.077D+00
20923             POWIGN = -ONETHI
20924          ELSE
20925             WRITE (LUNOUT,*)
20926      &   ' **** Unknown T=oo level density option requested ****'
20927             STOP 'BERTTP-JLVMOD'
20928          END IF
20929          IF ( LLVMOD ) THEN
20930             WRITE (LUNOUT,*)
20931      &      ' **** Cook''s modified pairing energy used ****'
20932          ELSE
20933             WRITE (LUNOUT,*)
20934      &      ' **** Original Gilbert/Cameron pairing energy used ****'
20935          END IF
20936       ENDIF
20937 **
20938
20939       ILVMOD = IB0
20940       DO 500 JZ = 1, 130
20941          PAENUC ( JZ, 1 ) = EMVGEV * CAM4 (JZ)
20942   500 CONTINUE
20943       DO 600 JA = 1, 200
20944          PAENUC ( JA, 2 ) = EMVGEV * CAM5 (JA)
20945   600 CONTINUE
20946       RETURN
20947       END
20948
20949 *$ CREATE DT_EVEVAP.FOR
20950 *COPY DT_EVEVAP
20951 *
20952 *====evevap============================================================*
20953 *
20954       SUBROUTINE DT_EVEVAP(WE)
20955
20956       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20957       SAVE
20958       PARAMETER ( LINP = 10 ,
20959      &            LOUT = 6 ,
20960      &            LDAT = 9 )
20961
20962 * flags for input different options
20963       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
20964       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
20965      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
20966
20967       LEVAPO = .FALSE.
20968
20969       RETURN
20970       END
20971
20972 *$ CREATE DT_FRBKIN.FOR
20973 *COPY DT_FRBKIN
20974 *
20975 *====frbkin============================================================*
20976 *
20977       SUBROUTINE DT_FRBKIN(LDUM1,LDUM2)
20978
20979       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20980       SAVE
20981       PARAMETER ( LINP = 10 ,
20982      &            LOUT = 6 ,
20983      &            LDAT = 9 )
20984
20985       LOGICAL LDUM1,LDUM2
20986
20987       RETURN
20988       END
20989
20990 *$ CREATE DT_EXPLOD.FOR
20991 *COPY DT_EXPLOD
20992 *
20993 *=== explod ===========================================================*
20994 *
20995       SUBROUTINE DT_EXPLOD( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
20996      &                    PYEXPL, PZEXPL )
20997
20998       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20999       SAVE
21000
21001       DIMENSION PXEXPL (NPEXPL), PYEXPL (NPEXPL), PZEXPL (NPEXPL),
21002      &          ETEXPL (NPEXPL), AMEXPL (NPEXPL)
21003
21004       RETURN
21005       END
21006
21007 ************************************************************************
21008 *                                                                      *
21009 *  DPMJET 3.0:   cross section routines                                *
21010 *                                                                      *
21011 ************************************************************************
21012 *
21013 *
21014 *     SUBROUTINE DT_SHNDIF
21015 *         diffractive cross sections (all energies)
21016 *     SUBROUTINE DT_PHOXS
21017 *         total and inel. cross sections from PHOJET interpol. tables
21018 *     SUBROUTINE DT_XSHN
21019 *         total and el. cross sections for all energies
21020 *     SUBROUTINE DT_SIHNAB
21021 *         pion 2-nucleon absorption cross sections
21022 *     SUBROUTINE DT_SIGEMU
21023 *         cross section for target "compounds"
21024 *     SUBROUTINE DT_SIGGA
21025 *         photon nucleus cross sections
21026 *     SUBROUTINE DT_SIGGAT
21027 *         photon nucleus cross sections from tables
21028 *     SUBROUTINE DT_SANO
21029 *         anomalous hard photon-nucleon cross sections from tables
21030 *     SUBROUTINE DT_SIGGP
21031 *         photon nucleon cross sections
21032 *     SUBROUTINE DT_SIGVEL
21033 *         quasi-elastic vector meson prod. cross sections
21034 *     DOUBLE PRECISION FUNCTION DT_SIGVP
21035 *         sigma_VN(tilde)
21036 *     DOUBLE PRECISION FUNCTION DT_RRM2
21037 *     DOUBLE PRECISION FUNCTION DT_RM2
21038 *     DOUBLE PRECISION FUNCTION DT_SAM2
21039 *     SUBROUTINE DT_CKMT
21040 *     SUBROUTINE DT_CKMTX
21041 *     SUBROUTINE DT_PDF0
21042 *     SUBROUTINE DT_CKMTQ0
21043 *     SUBROUTINE DT_CKMTDE
21044 *     SUBROUTINE DT_CKMTPR
21045 *     FUNCTION DT_CKMTFF
21046 *
21047 *     SUBROUTINE DT_FLUINI
21048 *         total nucleon cross section fluctuation treatment
21049 *
21050 *     SUBROUTINE DT_SIGTBL
21051 *         pre-tabulation of low-energy elastic x-sec. using SIHNEL
21052 *     SUBROUTINE DT_XSTABL
21053 *         service routines
21054 *
21055 *
21056 *$ CREATE DT_SHNDIF.FOR
21057 *COPY DT_SHNDIF
21058 *
21059 *===shndif===============================================================*
21060 *
21061       SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
21062
21063 **********************************************************************
21064 *   Single diffractive hadron-nucleon cross sections                 *
21065 *                                              S.Roesler 14/1/93     *
21066 *                                                                    *
21067 *   The cross sections are calculated from extrapolated single       *
21068 *   diffractive antiproton-proton cross sections (DTUJET92) using    *
21069 *   scaling relations between total and single diffractive cross     *
21070 *   sections.                                                        *
21071 **********************************************************************
21072
21073       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21074       SAVE
21075       PARAMETER (ZERO=0.0D0)
21076
21077 * particle properties (BAMJET index convention)
21078       CHARACTER*8  ANAME
21079       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21080      &                IICH(210),IIBAR(210),K1(210),K2(210)
21081 *
21082       CSD1   =   4.201483727D0
21083       CSD4   = -0.4763103556D-02
21084       CSD5   =  0.4324148297D0
21085 *
21086       CHMSD1 =  0.8519297242D0
21087       CHMSD4 = -0.1443076599D-01
21088       CHMSD5 =  0.4014954567D0
21089 *
21090       EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
21091       PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
21092 *
21093       SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
21094       SHMSD  = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
21095       FRAC   = SHMSD/SDIAPP
21096 *
21097       GOTO( 10, 20,999,999,999,999,999, 10, 20,999,
21098      &     999, 20, 20, 20, 20, 20, 10, 20, 20, 10,
21099      &      10, 10, 20, 20, 20) KPROJ
21100 *
21101    10 CONTINUE
21102 *---------------------------- p - p , n - p , sigma0+- - p ,
21103 *                             Lambda - p
21104       CSD1   =  6.004476070D0
21105       CSD4   = -0.1257784606D-03
21106       CSD5   =  0.2447335720D0
21107       SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
21108       SIGDIH = FRAC*SIGDIF
21109       RETURN
21110 *
21111    20 CONTINUE
21112 *
21113       KPSCAL = 2
21114       KTSCAL = 1
21115 C     F      = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
21116       DUMZER = ZERO
21117       CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
21118       F      = SDIAPP/SIGTO
21119       KT     = 1
21120 C     SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
21121       CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
21122       SIGDIF = SIGTO*F
21123       SIGDIH = FRAC*SIGDIF
21124       RETURN
21125 *
21126   999 CONTINUE
21127 *-------------------------- leptons..
21128       SIGDIF = 1.D-10
21129       SIGDIH = 1.D-10
21130       RETURN
21131       END
21132
21133 *$ CREATE DT_PHOXS.FOR
21134 *COPY DT_PHOXS
21135 *
21136 *===phoxs================================================================*
21137 *
21138       SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
21139
21140 ************************************************************************
21141 * Total/inelastic proton-nucleon cross sections taken from PHOJET-     *
21142 * interpolation tables.                                                *
21143 * This version dated 05.11.97 is written by S. Roesler                 *
21144 ************************************************************************
21145
21146       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21147       SAVE
21148
21149       PARAMETER ( LINP = 10 ,
21150      &            LOUT = 6 ,
21151      &            LDAT = 9 )
21152       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21153       PARAMETER (TWOPI  = 6.283185307179586454D+00,
21154      &           PI     = TWOPI/TWO,
21155      &           GEV2MB = 0.38938D0)
21156
21157       LOGICAL LFIRST
21158       DATA LFIRST /.TRUE./
21159
21160 * nucleon-nucleon event-generator
21161       CHARACTER*8 CMODEL
21162       LOGICAL LPHOIN
21163       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21164 * particle properties (BAMJET index convention)
21165       CHARACTER*8  ANAME
21166       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21167      &                IICH(210),IIBAR(210),K1(210),K2(210)
21168
21169 **PHOJET105a
21170 C     PARAMETER (IEETAB=10)
21171 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21172 **PHOJET110
21173 C  energy-interpolation table
21174       INTEGER IEETA2
21175       PARAMETER ( IEETA2 = 20 )
21176       INTEGER ISIMAX
21177       DOUBLE PRECISION SIGTAB,SIGECM
21178       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21179 **
21180
21181       IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
21182          WRITE(LOUT,*) MCGENE
21183  1000    FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
21184          STOP
21185       ENDIF
21186
21187       IF (ECM.LE.ZERO) THEN
21188          EPN = SQRT(AAM(KPROJ)**2+PLAB**2)
21189          ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG))
21190       ENDIF
21191
21192       IF (MODE.EQ.1) THEN
21193 * DL
21194          DELDL = 0.0808D0
21195          EPSDL = -0.4525D0
21196          S     = ECM*ECM
21197          STOT  = 21.7D0*S**DELDL+56.08D0*S**EPSDL
21198          ALPHAP= 0.25D0
21199          BEL   = 8.5D0+2.D0*ALPHAP*LOG(S)
21200          SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
21201          SINE  = STOT-SIGEL
21202          SDIF1 = ZERO
21203       ELSE
21204 * Phojet
21205          IP = 1
21206          IF(ECM.LE.SIGECM(IP,1)) THEN
21207            I1 = 1
21208            I2 = 1
21209          ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
21210            DO 1 I=2,ISIMAX
21211               IF (ECM.LE.SIGECM(IP,I)) GOTO 2
21212     1      CONTINUE
21213     2      CONTINUE
21214            I1 = I-1
21215            I2 = I
21216          ELSE
21217            IF (LFIRST) THEN
21218               WRITE(LOUT,'(/1X,A,2E12.3)')
21219      &          'PHOXS: warning! energy above initialization limit (',
21220      &          ECM,SIGECM(IP,ISIMAX)
21221              LFIRST = .FALSE.
21222            ENDIF
21223            I1 = ISIMAX
21224            I2 = ISIMAX
21225          ENDIF
21226          FAC2 = ZERO
21227          IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
21228      &                       /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
21229          FAC1  = ONE-FAC2
21230          STOT  = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
21231          SINE  = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
21232          SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+
21233      &           FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1))
21234          BEL   = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
21235       ENDIF
21236
21237       RETURN
21238       END
21239
21240 *$ CREATE DT_XSHN.FOR
21241 *COPY DT_XSHN
21242 *
21243 *===xshn===============================================================*
21244 *
21245       SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
21246
21247 ************************************************************************
21248 * Total and elastic hadron-nucleon cross section.                      *
21249 * Below 500GeV cross sections are based on the '98 data compilation    *
21250 * of the PDG. At higher energies PHOJET results are used (patched to   *
21251 * the low energy data at 500GeV).                                      *
21252 *     IP      projectile index (BAMJET numbering scheme)               *
21253 *             (should be in the range 1..25)                           *
21254 *     IT      target index (BAMJET numbering scheme)                   *
21255 *             (1 = proton, 8 = neutron)                                *
21256 *     PL      laboratory momentum                                      *
21257 *     ECM     cm. energy (ignored if PL>0)                             *
21258 *     STOT    total cross section                                      *
21259 *     SELA    elastic cross section                                    *
21260 * Last change: 24.4.99 by S. Roesler                                   *
21261 ************************************************************************
21262
21263       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21264       SAVE
21265
21266       PARAMETER ( LINP = 10 ,
21267      &            LOUT = 6 ,
21268      &            LDAT = 9 )
21269       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
21270
21271       PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
21272      &           PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
21273       PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
21274
21275       LOGICAL LFIRST
21276 * particle properties (BAMJET index convention)
21277       CHARACTER*8  ANAME
21278       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21279      &                IICH(210),IIBAR(210),K1(210),K2(210)
21280 * nucleon-nucleon event-generator
21281       CHARACTER*8 CMODEL
21282       LOGICAL LPHOIN
21283       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21284 **PHOJET105a
21285 C     PARAMETER (IEETAB=10)
21286 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21287 **PHOJET110
21288 C  energy-interpolation table
21289       INTEGER IEETA2
21290       PARAMETER ( IEETA2 = 20 )
21291       INTEGER ISIMAX
21292       DOUBLE PRECISION SIGTAB,SIGECM
21293       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21294
21295       DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
21296       DIMENSION IDXDAT(25,2)
21297 *
21298       DATA APL /
21299      &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748,
21300      &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465,
21301      &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182,
21302      &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101,
21303      & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384,
21304      & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668,
21305      & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/
21306 *
21307 * total cross sections:
21308 * p p
21309       DATA (ASIGTO(1,K),K=1,NPOINT) /
21310      & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21311      & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21312      & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352,
21313      & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596,
21314      & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664,
21315      & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617,
21316      & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/
21317 * pbar p
21318       DATA (ASIGTO(2,K),K=1,NPOINT) /
21319      & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598,
21320      & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329,
21321      & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151,
21322      & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024,
21323      & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921,
21324      & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802,
21325      & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/
21326 * n p
21327       DATA (ASIGTO(3,K),K=1,NPOINT) /
21328      & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21329      & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21330      & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21331      & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566,
21332      & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21333      & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21334      & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21335 * pi+ p
21336       DATA (ASIGTO(4,K),K=1,NPOINT) /
21337      & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21338      & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21339      & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195,
21340      & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473,
21341      & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492,
21342      & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428,
21343      & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/
21344 * pi- p
21345       DATA (ASIGTO(5,K),K=1,NPOINT) /
21346      & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226,
21347      & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679,
21348      & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547,
21349      & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543,
21350      & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535,
21351      & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468,
21352      & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/
21353 * K+ p
21354       DATA (ASIGTO(6,K),K=1,NPOINT) /
21355      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21356      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21357      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095,
21358      & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268,
21359      & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244,
21360      & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236,
21361      & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/
21362 * K- p
21363       DATA (ASIGTO(7,K),K=1,NPOINT) /
21364      & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997,
21365      & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847,
21366      & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543,
21367      & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508,
21368      & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463,
21369      & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396,
21370      & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/
21371 * K+ n
21372       DATA (ASIGTO(8,K),K=1,NPOINT) /
21373      & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21374      & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21375      & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147,
21376      & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301,
21377      & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261,
21378      & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240,
21379      & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/
21380 * K- n
21381       DATA (ASIGTO(9,K),K=1,NPOINT) /
21382      & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778,
21383      & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773,
21384      & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437,
21385      & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454,
21386      & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343,
21387      & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330,
21388      & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/
21389 * Lambda p
21390       DATA (ASIGTO(10,K),K=1,NPOINT) /
21391      & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21392      & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629,
21393      & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499,
21394      & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567,
21395      & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21396      & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21397      & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21398 *
21399 * elastic cross sections:
21400 * p p
21401       DATA (ASIGEL(1,K),K=1,NPOINT) /
21402      & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21403      & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21404      & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350,
21405      & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397,
21406      & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275,
21407      & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115,
21408      & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/
21409 * pbar p
21410       DATA (ASIGEL(2,K),K=1,NPOINT) /
21411      & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963,
21412      & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875,
21413      & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720,
21414      & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636,
21415      & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457,
21416      & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228,
21417      & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/
21418 * n p
21419       DATA (ASIGEL(3,K),K=1,NPOINT) /
21420      & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21421      & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21422      & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21423      & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454,
21424      & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21425      & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21426      & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21427 * pi+ p
21428       DATA (ASIGEL(4,K),K=1,NPOINT) /
21429      & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21430      & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21431      & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166,
21432      & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235,
21433      & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904,
21434      & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776,
21435      & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/
21436 * pi- p
21437       DATA (ASIGEL(5,K),K=1,NPOINT) /
21438      & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727,
21439      & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217,
21440      & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209,
21441      & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140,
21442      & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895,
21443      & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800,
21444      & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/
21445 * K+ p
21446       DATA (ASIGEL(6,K),K=1,NPOINT) /
21447      & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066,
21448      & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070,
21449      & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093,
21450      & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012,
21451      & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759,
21452      & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584,
21453      & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/
21454 * K- p
21455       DATA (ASIGEL(7,K),K=1,NPOINT) /
21456      & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878,
21457      & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561,
21458      & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188,
21459      & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077,
21460      & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800,
21461      & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618,
21462      & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/
21463 * K+ n
21464       DATA (ASIGEL(8,K),K=1,NPOINT) /
21465      & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21466      & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21467      & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148,
21468      & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111,
21469      & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785,
21470      & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635,
21471      & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/
21472 * K- n
21473       DATA (ASIGEL(9,K),K=1,NPOINT) /
21474      & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613,
21475      & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606,
21476      & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914,
21477      & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979,
21478      & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559,
21479      & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489,
21480      & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/
21481 * Lambda p
21482       DATA (ASIGEL(10,K),K=1,NPOINT) /
21483      & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21484      & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630,
21485      & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502,
21486      & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454,
21487      & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21488      & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21489      & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21490
21491       DATA (IDXDAT(K,1),K=1,25) /
21492      &  1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3,
21493      &  1, 3,45, 8, 9/
21494       DATA (IDXDAT(K,2),K=1,25) /
21495      &  3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1,
21496      &  3, 1,45, 6, 7/
21497
21498       DATA LFIRST /.TRUE./
21499
21500       IF (LFIRST) THEN
21501          APLABL = LOG10(PLABLO)
21502          APLABH = LOG10(PLABHI)
21503          APTHRE = LOG10(PTHRE)
21504          ADP1   = (APTHRE-APLABL)/DBLE(NPOIN1)
21505          ADP2   = (APLABH-APTHRE)/DBLE(NPOIN2)
21506          DUM0   = ZERO
21507          PHOPLA = PLABHI
21508          PHOELA = SQRT(AAM(1)**2+PHOPLA**2)
21509          ECMS   = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA)
21510          IF (MCGENE.EQ.2) THEN
21511             IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN
21512                CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0)
21513             ELSE
21514                CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21515             ENDIF
21516          ELSE
21517             CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21518          ENDIF
21519          PHOSEL = PHOSTO-PHOSIN
21520          APHOST = LOG10(PHOSTO)
21521          APHOSE = LOG10(PHOSEL)
21522          LFIRST = .FALSE.
21523       ENDIF
21524       STOT = ZERO
21525       SELA = ZERO
21526       PLAB = PL
21527       ECMS = ECM
21528       IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN
21529          WRITE(LOUT,1000) IP,IT
21530  1000    FORMAT(1X,'DT_XSHN: cross sections not implemented for ',
21531      &          'proj/target',2I4)
21532          STOP
21533       ENDIF
21534
21535       IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN
21536          ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT))
21537          PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP)))
21538       ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN
21539          WRITE(LOUT,1001) PLAB,ECMS
21540  1001    FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5)
21541          STOP
21542       ENDIF
21543
21544 * index of spectrum
21545       IDXP = IP
21546       IF (IP.GT.25) THEN
21547          IF (AAM(IP).GT.ZERO) THEN
21548             IF (ABS(IIBAR(IP)).GT.0) THEN
21549                IDXP = 1
21550             ELSE
21551                IDXP = 13
21552             ENDIF
21553          ELSE
21554             IDXP = 7
21555          ENDIF
21556       ENDIF
21557       IDXT = 1
21558       IF (IT.EQ.8) IDXT = 2
21559       IDXS = IDXDAT(IDXP,IDXT)
21560       IF (IDXS.EQ.0) RETURN
21561
21562 * compute momentum bin indices
21563       IF (PLAB.LT.PLABLO) THEN
21564          IDX0 = 1
21565          IDX1 = 1
21566       ELSEIF (PLAB.GE.PLABHI) THEN
21567          IDX0 = NPOINT
21568          IDX1 = NPOINT
21569       ELSE
21570          APLAB = LOG10(PLAB)
21571          IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN
21572             IDX0 = INT((APLAB-APLABL)/ADP1)+1
21573          ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN
21574             IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1
21575          ENDIF
21576          IDX1 = IDX0+1
21577       ENDIF
21578
21579 * interpolate cross section
21580       IF (IDXS.GT.10) THEN
21581          IDXS1 = IDXS/10
21582          IDXS2 = IDXS-10*IDXS1
21583          IF (IDX0.EQ.IDX1) THEN
21584             IF (IDX0.EQ.1) THEN
21585                ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0))
21586                ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0))
21587             ELSE
21588                DUM0   = ZERO
21589                CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21590                PHOSEL = PHOSTO-PHOSIN
21591                ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO)
21592                ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL)
21593                ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO)
21594                ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL)
21595                ASTOT  = 0.5D0*(ASTOT1+ASTOT2)
21596                ASELA  = 0.5D0*(ASELA1+ASELA2)
21597             ENDIF
21598          ELSE
21599             FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21600             ASTOT1 = ASIGTO(IDXS1,IDX0)+
21601      &               FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0))
21602             ASTOT2 = ASIGTO(IDXS2,IDX0)+
21603      &               FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0))
21604             ASTOT  = 0.5D0*(ASTOT1+ASTOT2)
21605             ASELA1 = ASIGEL(IDXS1,IDX0)+
21606      &               FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0))
21607             ASELA2 = ASIGEL(IDXS2,IDX0)+
21608      &               FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0))
21609             ASELA  = 0.5D0*(ASELA1+ASELA2)
21610          ENDIF
21611       ELSE
21612          IF (IDX0.EQ.IDX1) THEN
21613             IF (IDX0.EQ.1) THEN
21614                ASTOT = ASIGTO(IDXS,IDX0)
21615                ASELA = ASIGEL(IDXS,IDX0)
21616             ELSE
21617                DUM0   = ZERO
21618                CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21619                PHOSEL = PHOSTO-PHOSIN
21620                ASTOT  = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO)
21621                ASELA  = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL)
21622             ENDIF
21623          ELSE
21624             FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21625             ASTOT = ASIGTO(IDXS,IDX0)+
21626      &              FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0))
21627             ASELA = ASIGEL(IDXS,IDX0)+
21628      &              FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0))
21629          ENDIF
21630       ENDIF
21631       STOT = 10.0D0**ASTOT
21632       SELA = 10.0D0**ASELA
21633
21634       RETURN
21635       END
21636
21637 *$ CREATE DT_SIHNAB.FOR
21638 *COPY DT_SIHNAB
21639 *
21640 *===sihnab===============================================================*
21641 *
21642       SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
21643
21644 **********************************************************************
21645 * Pion 2-nucleon absorption cross sections.                          *
21646 * (sigma_tot for pi+ d --> p p, pi- d --> n n                        *
21647 *  taken from Ritchie PRC 28 (1983) 926 )                            *
21648 * This version dated 18.05.96 is written by S. Roesler               *
21649 **********************************************************************
21650
21651       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21652       SAVE
21653       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
21654       PARAMETER (AMPR = 938.0D0,
21655      &           AMPI = 140.0D0,
21656      &           AMDE = TWO*AMPR,
21657      &           A    = -1.2D0,
21658      &           B    = 3.5D0,
21659      &           C    = 7.4D0,
21660      &           D    = 5600.0D0,
21661      &           ER   = 2136.0D0)
21662
21663       SIGABS = ZERO
21664       IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
21665      &                   .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
21666       PTOT = PLAB*1.0D3
21667       EKIN = SQRT(AMPI**2+PTOT**2)-AMPI
21668       IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN
21669       ECM  = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE )
21670       SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D)
21671 * approximate 3N-abs., I=1-abs. etc.
21672       SIGABS = SIGABS/0.40D0
21673 * pi0-absorption (rough approximation!!)
21674       IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS
21675
21676       RETURN
21677       END
21678
21679 *$ CREATE DT_SIGEMU.FOR
21680 *COPY DT_SIGEMU
21681 *
21682 *===sigemu=============================================================*
21683 *
21684       SUBROUTINE DT_SIGEMU
21685
21686 ************************************************************************
21687 * Combined cross section for target compounds.                         *
21688 * This version dated 6.4.98   is written by S. Roesler                 *
21689 ************************************************************************
21690
21691       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21692       SAVE
21693       PARAMETER ( LINP = 10 ,
21694      &            LOUT = 6 ,
21695      &            LDAT = 9 )
21696       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21697      &           OHALF=0.5D0,ONE=1.0D0)
21698
21699       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21700 * Glauber formalism: cross sections
21701       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21702      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21703      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21704      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21705      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21706      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21707      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21708      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21709      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21710      &                BSLOPE,NEBINI,NQBINI
21711 * emulsion treatment
21712       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
21713      &                NCOMPO,IEMUL
21714 * nucleon-nucleon event-generator
21715       CHARACTER*8 CMODEL
21716       LOGICAL LPHOIN
21717       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21718
21719       IF (MCGENE.NE.4) THEN
21720          WRITE(LOUT,'(A)') ' DT_SIGEMU:    Combined cross sections'
21721          WRITE(LOUT,'(15X,A)') '-----------------------'
21722       ENDIF
21723       DO 1 IE=1,NEBINI
21724          DO 2 IQ=1,NQBINI
21725             SIGTOT = ZERO
21726             SIGELA = ZERO
21727             SIGQEP = ZERO
21728             SIGQET = ZERO
21729             SIGQE2 = ZERO
21730             SIGPRO = ZERO
21731             SIGDEL = ZERO
21732             SIGDQE = ZERO
21733             ERRTOT = ZERO
21734             ERRELA = ZERO
21735             ERRQEP = ZERO
21736             ERRQET = ZERO
21737             ERRQE2 = ZERO
21738             ERRPRO = ZERO
21739             ERRDEL = ZERO
21740             ERRDQE = ZERO
21741             IF (NCOMPO.GT.0) THEN
21742                DO 3 IC=1,NCOMPO
21743                   SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC)
21744                   SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC)
21745                   SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC)
21746                   SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC)
21747                   SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC)
21748                   SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC)
21749                   SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC)
21750                   SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC)
21751                   ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2
21752                   ERRELA = ERRELA+XEELA(IE,IQ,IC)**2
21753                   ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2
21754                   ERRQET = ERRQET+XEQET(IE,IQ,IC)**2
21755                   ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2
21756                   ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2
21757                   ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2
21758                   ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2
21759     3          CONTINUE
21760                ERRTOT = SQRT(ERRTOT)
21761                ERRELA = SQRT(ERRELA)
21762                ERRQEP = SQRT(ERRQEP)
21763                ERRQET = SQRT(ERRQET)
21764                ERRQE2 = SQRT(ERRQE2)
21765                ERRPRO = SQRT(ERRPRO)
21766                ERRDEL = SQRT(ERRDEL)
21767                ERRDQE = SQRT(ERRDQE)
21768             ELSE
21769                SIGTOT = XSTOT(IE,IQ,1)
21770                SIGELA = XSELA(IE,IQ,1)
21771                SIGQEP = XSQEP(IE,IQ,1)
21772                SIGQET = XSQET(IE,IQ,1)
21773                SIGQE2 = XSQE2(IE,IQ,1)
21774                SIGPRO = XSPRO(IE,IQ,1)
21775                SIGDEL = XSDEL(IE,IQ,1)
21776                SIGDQE = XSDQE(IE,IQ,1)
21777                ERRTOT = XETOT(IE,IQ,1)
21778                ERRELA = XEELA(IE,IQ,1)
21779                ERRQEP = XEQEP(IE,IQ,1)
21780                ERRQET = XEQET(IE,IQ,1)
21781                ERRQE2 = XEQE2(IE,IQ,1)
21782                ERRPRO = XEPRO(IE,IQ,1)
21783                ERRDEL = XEDEL(IE,IQ,1)
21784                ERRDQE = XEDQE(IE,IQ,1)
21785             ENDIF
21786             IF (MCGENE.NE.4) THEN
21787                WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ)
21788  1000         FORMAT(/,1X,'E_cm =',F9.1,' GeV  Q^2 =',F6.1,' GeV^2 :',/)
21789                WRITE(LOUT,1001) SIGTOT,ERRTOT
21790  1001          FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb')
21791                WRITE(LOUT,1002) SIGELA,ERRELA
21792  1002          FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb')
21793                WRITE(LOUT,1003) SIGQEP,ERRQEP
21794  1003          FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-',
21795      &                F11.5,' mb')
21796                WRITE(LOUT,1004) SIGQET,ERRQET
21797  1004          FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
21798      &                F11.5,' mb')
21799                WRITE(LOUT,1005) SIGQE2,ERRQE2
21800  1005          FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4,
21801      &                ' +-',F11.5,' mb')
21802                WRITE(LOUT,1006) SIGPRO,ERRPRO
21803  1006          FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb')
21804                WRITE(LOUT,1007) SIGDEL,ERRDEL
21805  1007          FORMAT(1X,'diff-el   ',27X,F10.4,' +-',F11.5,' mb')
21806                WRITE(LOUT,1008) SIGDQE,ERRDQE
21807  1008          FORMAT(1X,'diff-qel  ',27X,F10.4,' +-',F11.5,' mb')
21808             ENDIF
21809
21810     2    CONTINUE
21811     1 CONTINUE
21812
21813       RETURN
21814       END
21815
21816 *$ CREATE DT_SIGGA.FOR
21817 *COPY DT_SIGGA
21818 *
21819 *===sigga==============================================================*
21820 *
21821       SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
21822
21823 ************************************************************************
21824 * Total/inelastic photon-nucleus cross sections.                       *
21825 *     !!!! Overwrites SHMAKI-initialization. Do not use it during      *
21826 *          production runs !!!!                                        *
21827 * This version dated 27.03.96 is written by S. Roesler                 *
21828 ************************************************************************
21829
21830       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21831       SAVE
21832       PARAMETER ( LINP = 10 ,
21833      &            LOUT = 6 ,
21834      &            LDAT = 9 )
21835       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21836      &           OHALF=0.5D0,ONE=1.0D0)
21837       PARAMETER (AMPROT = 0.938D0)
21838
21839       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21840 * Glauber formalism: cross sections
21841       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21842      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21843      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21844      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21845      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21846      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21847      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21848      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21849      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21850      &                BSLOPE,NEBINI,NQBINI
21851
21852       NT  = NTI
21853       X   = XI
21854       Q2  = Q2I
21855       ECM = ECMI
21856       XNU = XNUI
21857       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21858      &   ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT)
21859       CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1)
21860       STOT  = XSTOT(1,1,1)
21861       ETOT  = XETOT(1,1,1)
21862       SIN   = XSPRO(1,1,1)
21863       EIN   = XEPRO(1,1,1)
21864
21865       RETURN
21866       END
21867
21868 *$ CREATE DT_SIGGAT.FOR
21869 *COPY DT_SIGGAT
21870 *
21871 *===siggat=============================================================*
21872 *
21873       SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
21874
21875 ************************************************************************
21876 * Total/inelastic photon-nucleus cross sections.                       *
21877 * Uses pre-tabulated cross section.                                    *
21878 * This version dated 29.07.96 is written by S. Roesler                 *
21879 ************************************************************************
21880
21881       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21882       SAVE
21883       PARAMETER ( LINP = 10 ,
21884      &            LOUT = 6 ,
21885      &            LDAT = 9 )
21886       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21887      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21888
21889       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21890 * Glauber formalism: cross sections
21891       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21892      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21893      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21894      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21895      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21896      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21897      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21898      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21899      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21900      &                BSLOPE,NEBINI,NQBINI
21901
21902       NTARG = ABS(NT)
21903       I1   = 1
21904       I2   = 1
21905       RATE = ONE
21906       IF (NEBINI.GT.1) THEN
21907          IF (ECMI.GE.ECMNN(NEBINI)) THEN
21908             I1   = NEBINI
21909             I2   = NEBINI
21910             RATE = ONE
21911          ELSEIF (ECMI.GT.ECMNN(1)) THEN
21912             DO 1 I=2,NEBINI
21913                IF (ECMI.LT.ECMNN(I)) THEN
21914                   I1   = I-1
21915                   I2   = I
21916                   RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
21917                   GOTO 2
21918                ENDIF
21919     1       CONTINUE
21920     2       CONTINUE
21921          ENDIF
21922       ENDIF
21923       J1   = 1
21924       J2   = 1
21925       RATQ = ONE
21926       IF (NQBINI.GT.1) THEN
21927          IF (Q2I.GE.Q2G(NQBINI)) THEN
21928             J1   = NQBINI
21929             J2   = NQBINI
21930             RATQ = ONE
21931          ELSEIF (Q2I.GT.Q2G(1)) THEN
21932             DO 3 I=2,NQBINI
21933                IF (Q2I.LT.Q2G(I)) THEN
21934                   J1   = I-1
21935                   J2   = I
21936                   RATQ = LOG10(    Q2I/MAX(Q2G(J1),TINY14))/
21937      &                   LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
21938 C                 RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
21939                   GOTO 4
21940                ENDIF
21941     3       CONTINUE
21942     4       CONTINUE
21943          ENDIF
21944       ENDIF
21945
21946       STOT = XSTOT(I1,J1,NTARG)+
21947      &   RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+
21948      &   RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+
21949      &   RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+
21950      &              XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG))
21951
21952       RETURN
21953       END
21954
21955 *$ CREATE DT_SANO.FOR
21956 *COPY DT_SANO
21957 *
21958 *===sigano=============================================================*
21959 *
21960       DOUBLE PRECISION FUNCTION DT_SANO(ECM)
21961
21962 ************************************************************************
21963 * This version dated 31.07.96 is written by S. Roesler                 *
21964 ************************************************************************
21965
21966       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21967       SAVE
21968       PARAMETER ( LINP = 10 ,
21969      &            LOUT = 6 ,
21970      &            LDAT = 9 )
21971       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21972      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21973       PARAMETER (NE = 8)
21974
21975 * VDM parameter for photon-nucleus interactions
21976       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21977 * properties of interacting particles
21978       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
21979
21980       DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
21981       DATA ECMANO /
21982      &             0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03,
21983      &             0.100D+04,0.200D+04,0.500D+04
21984      &            /
21985 * fixed cut (3 GeV/c)
21986       DATA FRAANO /
21987      &             0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00,
21988      &             0.062D+00,0.054D+00,0.042D+00
21989      &            /
21990       DATA SIGHRD /
21991      &           4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01,
21992      &           3.3086D-01,7.6255D-01,2.1319D+00
21993      &            /
21994 * running cut (based on obsolete Phojet-caluclations, bugs..)
21995 C     DATA FRAANO /
21996 C    &             0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
21997 C    &             0.167E+00,0.150E+00,0.131E+00
21998 C    &            /
21999 C     DATA SIGHRD /
22000 C    &           6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
22001 C    &           2.5736E-01,4.5593E-01,8.2550E-01
22002 C    &            /
22003
22004       DT_SANO = ZERO
22005       IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
22006       J1   = 0
22007       J2   = 0
22008       RATE = ONE
22009       IF (ECM.GE.ECMANO(NE)) THEN
22010          J1 = NE
22011          J2 = NE
22012       ELSEIF (ECM.GT.ECMANO(1)) THEN
22013          DO 1 IE=2,NE
22014             IF (ECM.LT.ECMANO(IE)) THEN
22015                J1   = IE-1
22016                J2   = IE
22017                RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
22018                GOTO 2
22019             ENDIF
22020     1    CONTINUE
22021     2    CONTINUE
22022       ENDIF
22023       IF ((J1.GT.0).AND.(J2.GT.0)) THEN
22024          AFRA1  = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14))
22025          AFRA2  = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14))
22026          DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1))
22027       ENDIF
22028
22029       RETURN
22030       END
22031
22032 *$ CREATE DT_SIGGP.FOR
22033 *COPY DT_SIGGP
22034 *
22035 *===siggp==============================================================*
22036 *
22037       SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
22038
22039 ************************************************************************
22040 * Total/inelastic photon-nucleon cross sections.                       *
22041 * This version dated 30.04.96 is written by S. Roesler                 *
22042 ************************************************************************
22043
22044       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22045       SAVE
22046       PARAMETER ( LINP = 10 ,
22047      &            LOUT = 6 ,
22048      &            LDAT = 9 )
22049       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22050       PARAMETER (TWOPI  = 6.283185307179586476925286766559D+00,
22051      &           PI     = TWOPI/TWO,
22052      &           GEV2MB = 0.38938D0,
22053      &           ALPHEM = ONE/137.0D0)
22054
22055 * particle properties (BAMJET index convention)
22056       CHARACTER*8  ANAME
22057       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22058      &                IICH(210),IIBAR(210),K1(210),K2(210)
22059 * VDM parameter for photon-nucleus interactions
22060       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22061
22062 **PHOJET105a
22063 C     CHARACTER*8 MDLNA
22064 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
22065 C     PARAMETER (IEETAB=10)
22066 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
22067 **PHOJET110
22068 C  model switches and parameters
22069       CHARACTER*8 MDLNA
22070       INTEGER ISWMDL,IPAMDL
22071       DOUBLE PRECISION PARMDL
22072       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
22073 C  energy-interpolation table
22074       INTEGER IEETA2
22075       PARAMETER ( IEETA2 = 20 )
22076       INTEGER ISIMAX
22077       DOUBLE PRECISION SIGTAB,SIGECM
22078       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
22079 **
22080
22081 C     PARAMETER (NPOINT=80)
22082       PARAMETER (NPOINT=16)
22083       DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22084
22085       STOT = ZERO
22086       SINE = ZERO
22087       SDIR = ZERO
22088
22089       W2 = ECMI**2
22090       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
22091      &   W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
22092       Q2 = Q2I
22093       X  = XI
22094 * photoprod.
22095       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22096          Q2 = 0.0001D0
22097          X  = Q2/(W2+Q2-AAM(1)**2)
22098 * DIS
22099       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
22100          X  = Q2/(W2+Q2-AAM(1)**2)
22101       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22102          Q2 = (W2-AAM(1)**2)*X/(ONE-X)
22103       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
22104          W2 = Q2*(ONE-X)/X+AAM(1)**2
22105       ELSE
22106          WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
22107          STOP
22108       ENDIF
22109       ECM = SQRT(W2)
22110
22111       IF (MODEGA.EQ.1) THEN
22112          SCALE = SQRT(Q2)
22113          CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
22114      &                                                       IDPDF)
22115 C        W = SQRT(W2)
22116 C        ALLMF2 = PHO_ALLM97(Q2,W)
22117 C        write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22118          STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22119          SINE = ZERO
22120          SDIR = ZERO
22121       ELSEIF (MODEGA.EQ.2) THEN
22122          IF (INTRGE(1).EQ.1) THEN
22123             AMLO2 = (3.0D0*AAM(13))**2
22124          ELSEIF (INTRGE(1).EQ.2) THEN
22125             AMLO2 = AAM(33)**2
22126          ELSE
22127             AMLO2 = AAM(96)**2
22128          ENDIF
22129          IF (INTRGE(2).EQ.1) THEN
22130             AMHI2 = W2/TWO
22131          ELSEIF (INTRGE(2).EQ.2) THEN
22132             AMHI2 = W2/4.0D0
22133          ELSE
22134             AMHI2 = W2
22135          ENDIF
22136          AMHI20 = (ECM-AAM(1))**2
22137          IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22138          XAMLO  = LOG( AMLO2+Q2 )
22139          XAMHI  = LOG( AMHI2+Q2 )
22140 **PHOJET105a
22141 C        CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
22142 **PHOJET112
22143          CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
22144 **
22145          SUM  = ZERO
22146          DO 1 J=1,NPOINT
22147             AM2 = EXP(ABSZX(J))-Q2
22148             IF (AM2.LT.16.0D0) THEN
22149                R = TWO
22150             ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
22151                R = 10.0D0/3.0D0
22152             ELSE
22153                R = 11.0D0/3.0D0
22154             ENDIF
22155 C           FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
22156             FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
22157      &            * (ONE+EPSPOL*Q2/AM2)
22158             SUM = SUM+WEIGHT(J)*FAC
22159     1    CONTINUE
22160          SINE = SUM
22161          SDIR = DT_SIGVP(X,Q2)
22162          STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
22163          SDIR = SDIR/(0.588D0+RL2+Q2)
22164 C        STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2)
22165       ELSEIF (MODEGA.EQ.3) THEN
22166          CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM)
22167       ELSEIF (MODEGA.EQ.4) THEN
22168 *  load cross sections from PHOJET interpolation table
22169          IP = 1
22170          IF(ECM.LE.SIGECM(IP,1)) THEN
22171            I1 = 1
22172            I2 = 1
22173          ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
22174            DO 2 I=2,ISIMAX
22175               IF (ECM.LE.SIGECM(IP,I)) GOTO 3
22176     2      CONTINUE
22177     3      CONTINUE
22178            I1 = I-1
22179            I2 = I
22180          ELSE
22181            WRITE(LOUT,'(/1X,A,2E12.3)')
22182      &       'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
22183            I1 = ISIMAX
22184            I2 = ISIMAX
22185          ENDIF
22186          FAC2 = ZERO
22187          IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
22188      &                       /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
22189          FAC1 = ONE-FAC2
22190 *  cross section dependence on photon virtuality
22191          FSUP1 = ZERO
22192          DO 4 I=1,3
22193             FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
22194      &                                /(1.D0+Q2/PARMDL(30+I))**2
22195     4    CONTINUE
22196          FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
22197          FAC1  = FAC1*FSUP1
22198          FAC2  = FAC2*FSUP1
22199          FSUP2 = 1.0D0
22200          STOT  = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
22201          SINE  = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
22202          SDIR  = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
22203 **re:
22204          STOT  = STOT-SDIR
22205 **
22206          SDIR  = SDIR/(FSUP1*FSUP2)
22207 **re:
22208          STOT  = STOT+SDIR
22209 **
22210       ENDIF
22211
22212       RETURN
22213       END
22214
22215 *$ CREATE DT_SIGVEL.FOR
22216 *COPY DT_SIGVEL
22217 *
22218 *===sigvel=============================================================*
22219 *
22220       SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
22221
22222 ************************************************************************
22223 * Cross section for elastic vector meson production                    *
22224 * This version dated 10.05.96 is written by S. Roesler                 *
22225 ************************************************************************
22226
22227       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22228       SAVE
22229       PARAMETER ( LINP = 10 ,
22230      &            LOUT = 6 ,
22231      &            LDAT = 9 )
22232       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22233       PARAMETER (TWOPI  = 6.283185307179586476925286766559D+00,
22234      &           PI     = TWOPI/TWO,
22235      &           GEV2MB = 0.38938D0,
22236      &           ALPHEM = ONE/137.0D0)
22237
22238 * particle properties (BAMJET index convention)
22239       CHARACTER*8  ANAME
22240       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22241      &                IICH(210),IIBAR(210),K1(210),K2(210)
22242 * VDM parameter for photon-nucleus interactions
22243       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22244
22245       W2 = ECMI**2
22246       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
22247      &   W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
22248       Q2 = Q2I
22249       X  = XI
22250 * photoprod.
22251       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22252          Q2 = 0.0001D0
22253          X  = Q2/(W2+Q2-AAM(1)**2)
22254 * DIS
22255       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
22256          X  = Q2/(W2+Q2-AAM(1)**2)
22257       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
22258          Q2 = (W2-AAM(1)**2)*X/(ONE-X)
22259       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
22260          W2 = Q2*(ONE-X)/X+AAM(1)**2
22261       ELSE
22262          WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
22263          STOP
22264       ENDIF
22265       ECM = SQRT(W2)
22266
22267       AMV  = AAM(IDXV)
22268       AMV2 = AMV**2
22269
22270       BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
22271      &        +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
22272       ROSH   = 0.1D0
22273       STOVP  = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
22274       SELVP  = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
22275
22276       IF (IDXV.EQ.33) THEN
22277          COUPL = 0.00365D0
22278       ELSE
22279          STOP
22280       ENDIF
22281       SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
22282       SIG2 = SELVP
22283       SVEL  = COUPL * (AMV2/(AMV2+Q2))**2
22284      &              * (ONE+EPSPOL*Q2/AMV2) * SELVP
22285
22286       RETURN
22287       END
22288
22289 *$ CREATE DT_SIGVP.FOR
22290 *COPY DT_SIGVP
22291 *
22292 *===sigvp==============================================================*
22293 *
22294       DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
22295
22296 ************************************************************************
22297 * sigma_Vp                                                             *
22298 ************************************************************************
22299
22300       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22301       SAVE
22302
22303       PARAMETER ( LINP = 10 ,
22304      &            LOUT = 6 ,
22305      &            LDAT = 9 )
22306       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22307       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22308      &           PI    = TWOPI/TWO,
22309      &           GEV2MB = 0.38938D0,
22310      &           AMPROT = 0.938D0,
22311      &           ALPHEM = ONE/137.0D0)
22312 * VDM parameter for photon-nucleus interactions
22313       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22314
22315       X  = XI
22316       Q2 = Q2I
22317       IF (XI.LE.ZERO)  X  = 0.0001D0
22318       IF (Q2I.LE.ZERO) Q2 = 0.0001D0
22319
22320       ECM    = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
22321
22322       SCALE = SQRT(Q2)
22323       IF (MODEGA.EQ.1) THEN
22324          CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
22325      &                                                       IDPDF)
22326 C        W = ECM
22327 C        ALLMF2 = PHO_ALLM97(Q2,W)
22328 C        write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22329 C        STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22330 C        DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
22331          DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB
22332       ELSEIF (MODEGA.EQ.4) THEN
22333          CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3)
22334 C        F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
22335          DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
22336       ELSE
22337          STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
22338       ENDIF
22339
22340       RETURN
22341
22342       END
22343
22344 *$ CREATE DT_RRM2.FOR
22345 *COPY DT_RRM2
22346 *
22347 *===RRM2===============================================================*
22348 *
22349       DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
22350
22351       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22352       SAVE
22353       PARAMETER ( LINP = 10 ,
22354      &            LOUT = 6 ,
22355      &            LDAT = 9 )
22356       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22357       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22358      &           PI    = TWOPI/TWO,
22359      &           GEV2MB = 0.38938D0)
22360
22361 * particle properties (BAMJET index convention)
22362       CHARACTER*8  ANAME
22363       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22364      &                IICH(210),IIBAR(210),K1(210),K2(210)
22365 * VDM parameter for photon-nucleus interactions
22366       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22367
22368       S   = Q2*(ONE-X)/X+AAM(1)**2
22369       ECM = SQRT(S)
22370
22371       IF (INTRGE(1).EQ.1) THEN
22372          AMLO2 = (3.0D0*AAM(13))**2
22373       ELSEIF (INTRGE(1).EQ.2) THEN
22374          AMLO2 = AAM(33)**2
22375       ELSE
22376          AMLO2 = AAM(96)**2
22377       ENDIF
22378       IF (INTRGE(2).EQ.1) THEN
22379          AMHI2 = S/TWO
22380       ELSEIF (INTRGE(2).EQ.2) THEN
22381          AMHI2 = S/4.0D0
22382       ELSE
22383          AMHI2 = S
22384       ENDIF
22385       AMHI20 = (ECM-AAM(1))**2
22386       IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22387
22388       AM1C2 = 16.0D0
22389       AM2C2 = 121.0D0
22390       IF (AMHI2.LE.AM1C2) THEN
22391          DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2)
22392       ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22393          DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22394      &          10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2)
22395       ELSE
22396          DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22397      &          10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+
22398      &          11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2)
22399       ENDIF
22400
22401       RETURN
22402       END
22403
22404 *$ CREATE DT_RM2.FOR
22405 *COPY DT_RM2
22406 *
22407 *===RM2================================================================*
22408 *
22409       DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
22410
22411       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22412       SAVE
22413       PARAMETER ( LINP = 10 ,
22414      &            LOUT = 6 ,
22415      &            LDAT = 9 )
22416       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22417       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22418      &           PI    = TWOPI/TWO,
22419      &           GEV2MB = 0.38938D0)
22420 * VDM parameter for photon-nucleus interactions
22421       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22422
22423       IF (RL2.LE.ZERO) THEN
22424          DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) -
22425      &        (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2))
22426      &         +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2))
22427       ELSE
22428          TMPMLO = LOG(ONE+RL2/(AMLO2+Q2))
22429          TMPMHI = LOG(ONE+RL2/(AMHI2+Q2))
22430          DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI
22431      &       -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO)
22432      &       +EPSPOL*(
22433      &         -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
22434      &       -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
22435       ENDIF
22436
22437       RETURN
22438       END
22439
22440 *$ CREATE DT_SAM2.FOR
22441 *COPY DT_SAM2
22442 *
22443 *===SAM2===============================================================*
22444 *
22445       DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
22446
22447       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22448       SAVE
22449       PARAMETER ( LINP = 10 ,
22450      &            LOUT = 6 ,
22451      &            LDAT = 9 )
22452       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
22453      &           TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0)
22454       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22455      &           PI    = TWOPI/TWO,
22456      &           GEV2MB = 0.38938D0)
22457
22458 * particle properties (BAMJET index convention)
22459       CHARACTER*8  ANAME
22460       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22461      &                IICH(210),IIBAR(210),K1(210),K2(210)
22462 * VDM parameter for photon-nucleus interactions
22463       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22464
22465       S = ECM**2
22466       IF (INTRGE(1).EQ.1) THEN
22467          AMLO2 = (3.0D0*AAM(13))**2
22468       ELSEIF (INTRGE(1).EQ.2) THEN
22469          AMLO2 = AAM(33)**2
22470       ELSE
22471          AMLO2 = AAM(96)**2
22472       ENDIF
22473       IF (INTRGE(2).EQ.1) THEN
22474          AMHI2 = S/TWO
22475       ELSEIF (INTRGE(2).EQ.2) THEN
22476          AMHI2 = S/4.0D0
22477       ELSE
22478          AMHI2 = S
22479       ENDIF
22480       AMHI20 = (ECM-AAM(1))**2
22481       IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22482
22483       AM1C2 = 16.0D0
22484       AM2C2 = 121.0D0
22485       YLO   = LOG(AMLO2+Q2)
22486       YC1   = LOG(AM1C2+Q2)
22487       YC2   = LOG(AM2C2+Q2)
22488       YHI   = LOG(AMHI2+Q2)
22489       IF (AMHI2.LE.AM1C2) THEN
22490          FACHI = TWO
22491       ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22492          FACHI = TENTRD
22493       ELSE
22494          FACHI = ELVTRD
22495       ENDIF
22496
22497     1 CONTINUE
22498       YSAM2  = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
22499       IF (YSAM2.LE.YC1) THEN
22500          FAC = TWO
22501       ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
22502          FAC = TENTRD
22503       ELSE
22504          FAC = ELVTRD
22505       ENDIF
22506       WEIGMX = FACHI*(ONE-Q2*EXP(  -YHI))
22507       XSAM2  = FAC  *(ONE-Q2*EXP(-YSAM2))
22508       IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
22509
22510       DT_SAM2   = EXP(YSAM2)-Q2
22511
22512       RETURN
22513       END
22514
22515 *$ CREATE DT_CKMT.FOR
22516 *COPY DT_CKMT
22517 *
22518 *===ckmt===============================================================*
22519 *
22520       SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
22521      &                F2,IPAR)
22522
22523 ************************************************************************
22524 * This version dated 31.01.96 is written by S. Roesler                 *
22525 ************************************************************************
22526
22527       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22528       SAVE
22529       PARAMETER ( LINP = 10 ,
22530      &            LOUT = 6 ,
22531      &            LDAT = 9 )
22532       PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
22533
22534       PARAMETER (Q02 = 2.0D0,
22535      &           DQ2 = 10.05D0,
22536      &           Q12 = Q02+DQ2)
22537
22538       DIMENSION PD(-6:6),SEA(3),VAL(2)
22539
22540       CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR)
22541       CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR)
22542       ADQ2 = LOG10(Q12)-LOG10(Q02)
22543       F2P  = (F2Q1-F2Q0)/ADQ2
22544       CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0)
22545       CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1)
22546       F2PP = (F2PQ1-F2PQ0)/ADQ2
22547       FX   = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02
22548
22549       Q2     = MAX(SCALE**2.0D0,TINY10)
22550       SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2
22551       IF (Q2.LT.Q02) THEN
22552          CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22553          UPV  = VAL(1)
22554          DNV  = VAL(2)
22555          USEA = SEA(1)
22556          DSEA = SEA(2)
22557          STR  = SEA(3)
22558          CHM  = 0.0D0
22559          BOT  = 0.0D0
22560          TOP  = 0.0D0
22561          GL   = GLU
22562       ELSE
22563          CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
22564          F2 = F2*SMOOTH
22565          UPV  = PD(2)-PD(3)
22566          DNV  = PD(1)-PD(3)
22567          USEA = PD(3)
22568          DSEA = PD(3)
22569          STR  = PD(3)
22570          CHM  = PD(4)
22571          BOT  = PD(5)
22572          TOP  = PD(6)
22573          GL   = PD(0)
22574 C        UPV  = UPV*SMOOTH
22575 C        DNV  = DNV*SMOOTH
22576 C        USEA = USEA*SMOOTH
22577 C        DSEA = DSEA*SMOOTH
22578 C        STR  = STR*SMOOTH
22579 C        CHM  = CHM*SMOOTH
22580 C        GL   = GL*SMOOTH
22581       ENDIF
22582
22583       RETURN
22584       END
22585 C
22586
22587 *$ CREATE DT_CKMTX.FOR
22588 *COPY DT_CKMTX
22589       SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
22590 C**********************************************************************
22591 C
22592 C     PDF based on Regge theory, evolved with .... by ....
22593 C
22594 C     input: IPAR     2212   proton (not installed)
22595 C                       45   Pomeron
22596 C                      100   Deuteron
22597 C
22598 C     output: PD(-6:6) x*f(x)  parton distribution functions
22599 C            (PDFLIB convention: d = PD(1), u = PD(2) )
22600 C
22601 C**********************************************************************
22602
22603       SAVE
22604       DOUBLE PRECISION  X,SCALE2,PD(-6:6),CDN,CUP,F2
22605       PARAMETER ( LINP = 10 ,
22606      &            LOUT = 6 ,
22607      &            LDAT = 9 )
22608       DIMENSION QQ(7)
22609 C
22610       Q2=SNGL(SCALE2)
22611       Q1S=Q2
22612       XX=SNGL(X)
22613 C  QCD lambda for evolution
22614       OWLAM = 0.23D0
22615       OWLAM2=OWLAM**2
22616 C  Q0**2 for evolution
22617       Q02 = 2.D0
22618 C
22619 C
22620 C  the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
22621 C                        q(6)=x*charm, q(7)=x*gluon
22622 C
22623       SB=0.
22624       IF(Q2-Q02) 1,1,2
22625     2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
22626     1 CONTINUE
22627       IF(IPAR.EQ.2212) THEN
22628         CALL DT_CKMTPR(1,0,XX,SB,QQ(1))
22629         CALL DT_CKMTPR(2,0,XX,SB,QQ(2))
22630         CALL DT_CKMTPR(3,0,XX,SB,QQ(3))
22631         CALL DT_CKMTPR(4,0,XX,SB,QQ(4))
22632         CALL DT_CKMTPR(5,0,XX,SB,QQ(5))
22633         CALL DT_CKMTPR(8,0,XX,SB,QQ(6))
22634         CALL DT_CKMTPR(7,0,XX,SB,QQ(7))
22635 C     ELSEIF (IPAR.EQ.45) THEN
22636 C       CALL CKMTPO(1,0,XX,SB,QQ(1))
22637 C       CALL CKMTPO(2,0,XX,SB,QQ(2))
22638 C       CALL CKMTPO(3,0,XX,SB,QQ(3))
22639 C       CALL CKMTPO(4,0,XX,SB,QQ(4))
22640 C       CALL CKMTPO(5,0,XX,SB,QQ(5))
22641 C       CALL CKMTPO(8,0,XX,SB,QQ(6))
22642 C       CALL CKMTPO(7,0,XX,SB,QQ(7))
22643       ELSEIF (IPAR.EQ.100) THEN
22644         CALL DT_CKMTDE(1,0,XX,SB,QQ(1))
22645         CALL DT_CKMTDE(2,0,XX,SB,QQ(2))
22646         CALL DT_CKMTDE(3,0,XX,SB,QQ(3))
22647         CALL DT_CKMTDE(4,0,XX,SB,QQ(4))
22648         CALL DT_CKMTDE(5,0,XX,SB,QQ(5))
22649         CALL DT_CKMTDE(8,0,XX,SB,QQ(6))
22650         CALL DT_CKMTDE(7,0,XX,SB,QQ(7))
22651       ELSE
22652         WRITE(LOUT,'(1X,A,I4,A)')
22653      &     'CKMTX:   IPAR =',IPAR,' not implemented!'
22654         STOP
22655       ENDIF
22656 C
22657       PD(-6) = 0.D0
22658       PD(-5) = 0.D0
22659       PD(-4) = DBLE(QQ(6))
22660       PD(-3) = DBLE(QQ(3))
22661       PD(-2) = DBLE(QQ(4))
22662       PD(-1) = DBLE(QQ(5))
22663       PD(0)  = DBLE(QQ(7))
22664       PD(1)  = DBLE(QQ(2))
22665       PD(2)  = DBLE(QQ(1))
22666       PD(3)  = DBLE(QQ(3))
22667       PD(4)  = DBLE(QQ(6))
22668       PD(5)  = 0.D0
22669       PD(6)  = 0.D0
22670       IF(IPAR.EQ.45) THEN
22671         CDN = (PD(1)-PD(-1))/2.D0
22672         CUP = (PD(2)-PD(-2))/2.D0
22673         PD(-1) = PD(-1) + CDN
22674         PD(-2) = PD(-2) + CUP
22675         PD(1) = PD(-1)
22676         PD(2) = PD(-2)
22677       ENDIF
22678       F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+
22679      &     1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+
22680      &     1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4))
22681       END
22682 C
22683
22684 *$ CREATE DT_PDF0.FOR
22685 *COPY DT_PDF0
22686 *
22687 *===pdf0===============================================================*
22688 *
22689       SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22690
22691 ************************************************************************
22692 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2       *
22693 * an F_2-ansatz given in Capella et al. PLB 337(1994)358.              *
22694 *                   IPAR  = 2212   proton                              *
22695 *                         =  100   deuteron                            *
22696 * This version dated 31.01.96 is written by S. Roesler                 *
22697 ************************************************************************
22698
22699       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22700       SAVE
22701       PARAMETER ( LINP = 10 ,
22702      &            LOUT = 6 ,
22703      &            LDAT = 9 )
22704       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22705
22706       PARAMETER (
22707      &              AA     = 0.1502D0,
22708      &              BBDEU  = 1.2D0,
22709      &              BUD    = 0.754D0,
22710      &              BDD    = 0.4495D0,
22711      &              BUP    = 1.2064D0,
22712      &              BDP    = 0.1798D0,
22713      &              DELTA0 = 0.07684D0,
22714      &              D      = 1.117D0,
22715      &              C      = 3.5489D0,
22716      &              A      = 0.2631D0,
22717      &              B      = 0.6452D0,
22718      &              ALPHAR = 0.415D0,
22719      &              E      = 0.1D0
22720      &          )
22721
22722       PARAMETER (NPOINT=16)
22723 C     DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22724       DIMENSION SEA(3),VAL(2)
22725
22726       DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22727       AN    = 1.5D0*(1.0D0+Q2/(Q2+C))
22728 * proton, deuteron
22729       IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22730          CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22731          SEA(1) = 0.75D0*SEA0
22732          SEA(2) = SEA(1)
22733          SEA(3) = SEA(1)
22734          VAL(1) = 9.0D0/4.0D0*VALU0
22735          VAL(2) = 9.0D0*VALD0
22736          GLU0   = SEA(1)/(1.0D0-X)
22737          F2     = SEA0+VALU0+VALD0
22738          F2PDF  = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+
22739      &            1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+
22740      &            1.0D0/9.0D0*(2.0D0*SEA(3))
22741          IF (ABS(F2-F2PDF).GT.TINY9) THEN
22742             WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF
22743             STOP
22744          ENDIF
22745 **PHOJET105a
22746 C        CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22747 **PHOJET112
22748 C        CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22749 **
22750 C        SUMQ = ZERO
22751 C        SUMG = ZERO
22752 C        DO 1 J=1,NPOINT
22753 C           CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
22754 C           VALU0 = 9.0D0/4.0D0*VALU0
22755 C           VALD0 = 9.0D0*VALD0
22756 C           SEA0  = 0.75D0*SEA0
22757 C           SUMQ  = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
22758 C           SUMG  = SUMG+ (SEA0/(1.0D0-ABSZX(J)))  *WEIGHT(J)
22759 C   1    CONTINUE
22760 C        GLU = GLU0*(1.0D0-SUMQ)/SUMG
22761       ELSE
22762          WRITE(LOUT,'(1X,A,I4,A)')
22763      &      'PDF0:   IPAR =',IPAR,' not implemented!'
22764          STOP
22765       ENDIF
22766
22767       RETURN
22768       END
22769
22770 *$ CREATE DT_CKMTQ0.FOR
22771 *COPY DT_CKMTQ0
22772 *
22773 *===ckmtq0=============================================================*
22774 *
22775       SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22776
22777 ************************************************************************
22778 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2       *
22779 * an F_2-ansatz given in Capella et al. PLB 337(1994)358.              *
22780 *                   IPAR  = 2212   proton                              *
22781 *                         =  100   deuteron                            *
22782 * This version dated 31.01.96 is written by S. Roesler                 *
22783 ************************************************************************
22784
22785       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22786       SAVE
22787       PARAMETER ( LINP = 10 ,
22788      &            LOUT = 6 ,
22789      &            LDAT = 9 )
22790       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22791
22792       PARAMETER (
22793      &              AA     = 0.1502D0,
22794      &              BBDEU  = 1.2D0,
22795      &              BUD    = 0.754D0,
22796      &              BDD    = 0.4495D0,
22797      &              BUP    = 1.2064D0,
22798      &              BDP    = 0.1798D0,
22799      &              DELTA0 = 0.07684D0,
22800      &              D      = 1.117D0,
22801      &              C      = 3.5489D0,
22802      &              A      = 0.2631D0,
22803      &              B      = 0.6452D0,
22804      &              ALPHAR = 0.415D0,
22805      &              E      = 0.1D0
22806      &          )
22807
22808       DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22809       AN    = 1.5D0*(1.0D0+Q2/(Q2+C))
22810 * proton, deuteron
22811       IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22812          IF (IPAR.EQ.2212) THEN
22813             BU = BUP
22814             BD = BDP
22815          ELSE
22816             BU = BUD
22817             BD = BDD
22818          ENDIF
22819          SEA0  = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)*
22820      &          (Q2/(Q2+A))**(1.0D0+DELTA)
22821          VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN*
22822      &           (Q2/(Q2+B))**(ALPHAR)
22823          VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)*
22824      &           (Q2/(Q2+B))**(ALPHAR)
22825       ELSE
22826          WRITE(LOUT,'(1X,A,I4,A)')
22827      &      'CKMTQ0: IPAR =',IPAR,' not implemented!'
22828          STOP
22829       ENDIF
22830       RETURN
22831       END
22832 C
22833 C
22834
22835 *$ CREATE DT_CKMTDE.FOR
22836 *COPY DT_CKMTDE
22837       SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
22838 C
22839 C**********************************************************************
22840 C    Deuteron - PDFs
22841 C    I   = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
22842 C    ANS = PDF(I)
22843 C    This version by S. Roesler, 30.01.96
22844 C**********************************************************************
22845
22846       SAVE
22847       DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
22848       EQUIVALENCE (GF(1,1,1),DL(1))
22849       DATA DELTA/.13/
22850 C
22851       DATA (DL(K),K=    1,   85) /
22852      &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00,
22853      &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00,
22854      &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01,
22855      &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00,
22856      &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00,
22857      &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00,
22858      &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00,
22859      &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00,
22860      &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00,
22861      &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00,
22862      &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02,
22863      &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01,
22864      &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01,
22865      &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01,
22866      &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01,
22867      &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01,
22868      &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/
22869       DATA (DL(K),K=   86,  170) /
22870      &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01,
22871      &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02,
22872      &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01,
22873      &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01,
22874      &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01,
22875      &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01,
22876      &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01,
22877      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22878      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22879      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22880      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22881      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22882      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22883      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22884      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22885      &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00,
22886      &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/
22887       DATA (DL(K),K=  171,  255) /
22888      &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01,
22889      &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00,
22890      &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00,
22891      &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00,
22892      &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00,
22893      &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00,
22894      &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00,
22895      &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00,
22896      &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02,
22897      &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00,
22898      &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00,
22899      &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00,
22900      &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00,
22901      &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00,
22902      &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01,
22903      &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01,
22904      &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/
22905       DATA (DL(K),K=  256,  340) /
22906      &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01,
22907      &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01,
22908      &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01,
22909      &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01,
22910      &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01,
22911      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22912      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22913      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22914      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22915      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22916      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22917      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22918      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22919      &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00,
22920      &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00,
22921      &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01,
22922      &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/
22923       DATA (DL(K),K=  341,  425) /
22924      &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00,
22925      &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00,
22926      &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00,
22927      &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00,
22928      &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00,
22929      &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00,
22930      &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02,
22931      &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00,
22932      &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00,
22933      &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00,
22934      &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00,
22935      &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00,
22936      &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00,
22937      &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01,
22938      &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02,
22939      &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00,
22940      &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/
22941       DATA (DL(K),K=  426,  510) /
22942      &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00,
22943      &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01,
22944      &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00,
22945      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22946      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22947      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22948      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22949      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22950      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22951      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22952      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22953      &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00,
22954      &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00,
22955      &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01,
22956      &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00,
22957      &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00,
22958      &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/
22959       DATA (DL(K),K=  511,  595) /
22960      &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00,
22961      &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00,
22962      &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00,
22963      &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00,
22964      &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01,
22965      &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00,
22966      &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00,
22967      &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00,
22968      &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00,
22969      &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00,
22970      &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00,
22971      &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00,
22972      &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01,
22973      &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00,
22974      &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00,
22975      &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00,
22976      &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/
22977       DATA (DL(K),K=  596,  680) /
22978      &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00,
22979      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22980      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22981      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22982      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22983      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22984      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22985      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22986      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22987      &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00,
22988      &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00,
22989      &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01,
22990      &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00,
22991      &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00,
22992      &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00,
22993      &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00,
22994      &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/
22995       DATA (DL(K),K=  681,  765) /
22996      &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00,
22997      &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00,
22998      &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01,
22999      &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00,
23000      &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00,
23001      &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00,
23002      &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00,
23003      &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00,
23004      &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00,
23005      &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00,
23006      &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01,
23007      &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00,
23008      &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00,
23009      &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00,
23010      &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00,
23011      &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00,
23012      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23013       DATA (DL(K),K=  766,  850) /
23014      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23015      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23016      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23017      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23018      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23019      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23020      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23021      &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23022      &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00,
23023      &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01,
23024      &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00,
23025      &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00,
23026      &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00,
23027      &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00,
23028      &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01,
23029      &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00,
23030      &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/
23031       DATA (DL(K),K=  851,  935) /
23032      &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01,
23033      &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00,
23034      &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00,
23035      &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00,
23036      &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00,
23037      &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00,
23038      &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00,
23039      &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00,
23040      &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01,
23041      &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00,
23042      &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00,
23043      &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00,
23044      &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00,
23045      &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00,
23046      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23047      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23048      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23049       DATA (DL(K),K=  936, 1020) /
23050      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23051      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23052      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23053      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23054      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23055      &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23056      &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00,
23057      &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01,
23058      &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00,
23059      &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00,
23060      &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00,
23061      &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00,
23062      &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01,
23063      &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00,
23064      &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00,
23065      &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01,
23066      &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/
23067       DATA (DL(K),K= 1021, 1105) /
23068      &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00,
23069      &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00,
23070      &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00,
23071      &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01,
23072      &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00,
23073      &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00,
23074      &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01,
23075      &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00,
23076      &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00,
23077      &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00,
23078      &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00,
23079      &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01,
23080      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23081      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23082      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23083      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23084      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23085       DATA (DL(K),K= 1106, 1190) /
23086      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23087      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23088      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23089      &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01,
23090      &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00,
23091      &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01,
23092      &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01,
23093      &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00,
23094      &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01,
23095      &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01,
23096      &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01,
23097      &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01,
23098      &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00,
23099      &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01,
23100      &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01,
23101      &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00,
23102      &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/
23103       DATA (DL(K),K= 1191, 1275) /
23104      &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01,
23105      &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01,
23106      &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01,
23107      &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00,
23108      &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00,
23109      &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01,
23110      &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00,
23111      &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01,
23112      &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01,
23113      &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01,
23114      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23115      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23116      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23117      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23118      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23119      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23120      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23121       DATA (DL(K),K= 1276, 1360) /
23122      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23123      &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01,
23124      &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00,
23125      &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00,
23126      &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01,
23127      &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00,
23128      &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01,
23129      &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01,
23130      &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02,
23131      &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01,
23132      &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00,
23133      &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00,
23134      &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01,
23135      &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00,
23136      &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01,
23137      &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01,
23138      &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/
23139       DATA (DL(K),K= 1361, 1445) /
23140      &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01,
23141      &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00,
23142      &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00,
23143      &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01,
23144      &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00,
23145      &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01,
23146      &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01,
23147      &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01,
23148      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23149      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23150      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23151      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23152      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23153      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23154      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23155      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23156      &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/
23157       DATA (DL(K),K= 1446, 1530) /
23158      &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00,
23159      &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00,
23160      &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01,
23161      &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00,
23162      &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01,
23163      &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01,
23164      &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02,
23165      &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01,
23166      &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00,
23167      &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00,
23168      &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01,
23169      &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00,
23170      &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01,
23171      &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01,
23172      &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02,
23173      &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01,
23174      &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/
23175       DATA (DL(K),K= 1531, 1615) /
23176      &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00,
23177      &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01,
23178      &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00,
23179      &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01,
23180      &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01,
23181      &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02,
23182      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23183      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23184      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23185      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23186      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23187      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23188      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23189      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23190      &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01,
23191      &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00,
23192      &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/
23193       DATA (DL(K),K= 1616, 1700) /
23194      &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01,
23195      &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00,
23196      &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01,
23197      &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01,
23198      &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02,
23199      &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01,
23200      &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00,
23201      &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00,
23202      &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01,
23203      &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00,
23204      &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01,
23205      &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01,
23206      &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02,
23207      &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01,
23208      &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00,
23209      &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00,
23210      &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/
23211       DATA (DL(K),K= 1701, 1785) /
23212      &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00,
23213      &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02,
23214      &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02,
23215      &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02,
23216      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23217      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23218      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23219      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23220      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23221      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23222      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23223      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23224      &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01,
23225      &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00,
23226      &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00,
23227      &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01,
23228      &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/
23229       DATA (DL(K),K= 1786, 1870) /
23230      &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01,
23231      &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01,
23232      &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02,
23233      &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02,
23234      &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00,
23235      &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00,
23236      &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02,
23237      &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00,
23238      &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02,
23239      &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02,
23240      &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02,
23241      &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02,
23242      &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00,
23243      &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01,
23244      &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02,
23245      &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00,
23246      &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/
23247       DATA (DL(K),K= 1871, 1955) /
23248      &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02,
23249      &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02,
23250      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23251      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23252      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23253      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23254      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23255      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23256      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23257      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23258      &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02,
23259      &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00,
23260      &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00,
23261      &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02,
23262      &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00,
23263      &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02,
23264      &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/
23265       DATA (DL(K),K= 1956, 2040) /
23266      &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03,
23267      &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02,
23268      &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00,
23269      &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01,
23270      &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02,
23271      &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00,
23272      &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02,
23273      &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02,
23274      &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03,
23275      &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02,
23276      &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00,
23277      &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01,
23278      &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02,
23279      &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00,
23280      &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02,
23281      &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02,
23282      &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/
23283       DATA (DL(K),K= 2041, 2125) /
23284      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23285      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23286      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23287      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23288      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23289      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23290      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23291      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23292      &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02,
23293      &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00,
23294      &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00,
23295      &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02,
23296      &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00,
23297      &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02,
23298      &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02,
23299      &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03,
23300      &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/
23301       DATA (DL(K),K= 2126, 2210) /
23302      &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00,
23303      &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01,
23304      &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02,
23305      &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00,
23306      &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02,
23307      &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02,
23308      &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03,
23309      &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02,
23310      &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00,
23311      &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01,
23312      &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02,
23313      &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00,
23314      &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02,
23315      &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02,
23316      &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03,
23317      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23318      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23319       DATA (DL(K),K= 2211, 2295) /
23320      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23321      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23322      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23323      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23324      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23325      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23326      &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23327      &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00,
23328      &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01,
23329      &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02,
23330      &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00,
23331      &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02,
23332      &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02,
23333      &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03,
23334      &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02,
23335      &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00,
23336      &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/
23337       DATA (DL(K),K= 2296, 2380) /
23338      &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02,
23339      &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00,
23340      &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02,
23341      &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02,
23342      &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03,
23343      &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03,
23344      &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00,
23345      &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01,
23346      &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03,
23347      &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01,
23348      &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03,
23349      &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03,
23350      &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03,
23351      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23352      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23353      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23354      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23355       DATA (DL(K),K= 2381, 2465) /
23356      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23357      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23358      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23359      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23360      &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23361      &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00,
23362      &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01,
23363      &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02,
23364      &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00,
23365      &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02,
23366      &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02,
23367      &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04,
23368      &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03,
23369      &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00,
23370      &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01,
23371      &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03,
23372      &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/
23373       DATA (DL(K),K= 2466, 2550) /
23374      &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03,
23375      &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03,
23376      &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03,
23377      &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03,
23378      &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01,
23379      &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02,
23380      &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03,
23381      &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01,
23382      &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03,
23383      &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03,
23384      &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04,
23385      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23386      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23387      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23388      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23389      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23390      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23391       DATA (DL(K),K= 2551, 2635) /
23392      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23393      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23394      &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03,
23395      &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00,
23396      &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01,
23397      &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03,
23398      &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00,
23399      &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03,
23400      &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03,
23401      &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04,
23402      &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03,
23403      &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00,
23404      &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01,
23405      &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03,
23406      &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01,
23407      &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03,
23408      &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/
23409       DATA (DL(K),K= 2636, 2720) /
23410      &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04,
23411      &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03,
23412      &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01,
23413      &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02,
23414      &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03,
23415      &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01,
23416      &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03,
23417      &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03,
23418      &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04,
23419      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23420      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23421      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23422      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23423      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23424      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23425      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23426      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23427       DATA (DL(K),K= 2721, 2805) /
23428      &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03,
23429      &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00,
23430      &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01,
23431      &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03,
23432      &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00,
23433      &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03,
23434      &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03,
23435      &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04,
23436      &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03,
23437      &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01,
23438      &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02,
23439      &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03,
23440      &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01,
23441      &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03,
23442      &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03,
23443      &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04,
23444      &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/
23445       DATA (DL(K),K= 2806, 2890) /
23446      &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01,
23447      &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02,
23448      &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04,
23449      &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01,
23450      &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04,
23451      &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04,
23452      &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04,
23453      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23454      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23455      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23456      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23457      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23458      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23459      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23460      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23461      &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03,
23462      &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/
23463       DATA (DL(K),K= 2891, 2975) /
23464      &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02,
23465      &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03,
23466      &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01,
23467      &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03,
23468      &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04,
23469      &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05,
23470      &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04,
23471      &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01,
23472      &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02,
23473      &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04,
23474      &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01,
23475      &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04,
23476      &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04,
23477      &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05,
23478      &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04,
23479      &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01,
23480      &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/
23481       DATA (DL(K),K= 2976, 3060) /
23482      &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04,
23483      &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01,
23484      &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04,
23485      &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04,
23486      &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05,
23487      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23488      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23489      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23490      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23491      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23492      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23493      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23494      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23495      &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04,
23496      &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01,
23497      &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02,
23498      &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/
23499       DATA (DL(K),K= 3061, 3145) /
23500      &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01,
23501      &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04,
23502      &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04,
23503      &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06,
23504      &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04,
23505      &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01,
23506      &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02,
23507      &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04,
23508      &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01,
23509      &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04,
23510      &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04,
23511      &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05,
23512      &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04,
23513      &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01,
23514      &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03,
23515      &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04,
23516      &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/
23517       DATA (DL(K),K= 3146, 3230) /
23518      &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05,
23519      &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05,
23520      &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05,
23521      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23522      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23523      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23524      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23525      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23526      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23527      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23528      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23529      &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04,
23530      &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01,
23531      &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02,
23532      &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04,
23533      &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01,
23534      &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/
23535       DATA (DL(K),K= 3231, 3315) /
23536      &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05,
23537      &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06,
23538      &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05,
23539      &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01,
23540      &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03,
23541      &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05,
23542      &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01,
23543      &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05,
23544      &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05,
23545      &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06,
23546      &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05,
23547      &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02,
23548      &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03,
23549      &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05,
23550      &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02,
23551      &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05,
23552      &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/
23553       DATA (DL(K),K= 3316, 3400) /
23554      &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07,
23555      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23556      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23557      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23558      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23559      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23560      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23561      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23562      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23563      &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05,
23564      &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01,
23565      &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03,
23566      &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05,
23567      &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01,
23568      &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05,
23569      &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05,
23570      &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/
23571       DATA (DL(K),K= 3401, 3485) /
23572      &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05,
23573      &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02,
23574      &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03,
23575      &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05,
23576      &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01,
23577      &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06,
23578      &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06,
23579      &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06,
23580      &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06,
23581      &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02,
23582      &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04,
23583      &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05,
23584      &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02,
23585      &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07,
23586      &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07,
23587      &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06,
23588      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23589       DATA (DL(K),K= 3486, 3570) /
23590      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23591      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23592      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23593      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23594      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23595      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23596      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23597      &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05,
23598      &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02,
23599      &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03,
23600      &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05,
23601      &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01,
23602      &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07,
23603      &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07,
23604      &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06,
23605      &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07,
23606      &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/
23607       DATA (DL(K),K= 3571, 3655) /
23608      &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04,
23609      &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05,
23610      &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02,
23611      &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07,
23612      &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07,
23613      &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06,
23614      &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07,
23615      &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03,
23616      &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04,
23617      &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06,
23618      &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02,
23619      &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07,
23620      &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07,
23621      &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07,
23622      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23623      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23624      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23625       DATA (DL(K),K= 3656, 3740) /
23626      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23627      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23628      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23629      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23630      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23631      &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07,
23632      &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02,
23633      &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04,
23634      &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06,
23635      &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02,
23636      &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06,
23637      &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06,
23638      &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06,
23639      &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06,
23640      &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03,
23641      &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04,
23642      &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/
23643       DATA (DL(K),K= 3741, 3825) /
23644      &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02,
23645      &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07,
23646      &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07,
23647      &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07,
23648      &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07,
23649      &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03,
23650      &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05,
23651      &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07,
23652      &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03,
23653      &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07,
23654      &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08,
23655      &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08,
23656      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23657      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23658      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23659      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23660      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23661       DATA (DL(K),K= 3826, 3910) /
23662      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23663      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23664      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23665      &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08,
23666      &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03,
23667      &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05,
23668      &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06,
23669      &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02,
23670      &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06,
23671      &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06,
23672      &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06,
23673      &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06,
23674      &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04,
23675      &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05,
23676      &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06,
23677      &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03,
23678      &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/
23679       DATA (DL(K),K= 3911, 3995) /
23680      &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07,
23681      &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07,
23682      &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07,
23683      &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04,
23684      &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06,
23685      &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06,
23686      &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04,
23687      &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07,
23688      &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07,
23689      &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07,
23690      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23691      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23692      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23693      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23694      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23695      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23696      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23697       DATA (DL(K),K= 3996, 4000) /
23698      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23699 C
23700       ANS = 0.
23701       IF (X.GT.0.9985) RETURN
23702       IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
23703 C
23704       IS  = S/DELTA+1
23705       IS1 = IS+1
23706       DO 1 L=1,25
23707          KL    = L+NDRV*25
23708          F1(L) = GF(I,IS,KL)
23709          F2(L) = GF(I,IS1,KL)
23710     1 CONTINUE
23711       A1 = DT_CKMTFF(X,F1)
23712       A2 = DT_CKMTFF(X,F2)
23713 C      A1=ALOG(A1)
23714 C      A2=ALOG(A2)
23715       S1  = (IS-1)*DELTA
23716       S2  = S1+DELTA
23717       ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
23718 C      ANS=EXP(ANS)
23719       RETURN
23720       END
23721 C
23722 C
23723
23724 *$ CREATE DT_CKMTPR.FOR
23725 *COPY DT_CKMTPR
23726       SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
23727 C
23728 C**********************************************************************
23729 C    Proton   - PDFs
23730 C    I   = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
23731 C    ANS = PDF(I)
23732 C    This version by S. Roesler, 31.01.96
23733 C**********************************************************************
23734
23735       SAVE
23736       DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
23737       EQUIVALENCE (GF(1,1,1),DL(1))
23738       DATA DELTA/.10/
23739 C
23740       DATA (DL(K),K=    1,   85) /
23741      &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00,
23742      &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00,
23743      &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01,
23744      &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00,
23745      &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00,
23746      &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00,
23747      &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00,
23748      &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00,
23749      &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00,
23750      &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00,
23751      &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02,
23752      &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00,
23753      &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01,
23754      &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00,
23755      &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01,
23756      &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00,
23757      &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/
23758       DATA (DL(K),K=   86,  170) /
23759      &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01,
23760      &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02,
23761      &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01,
23762      &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01,
23763      &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01,
23764      &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01,
23765      &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01,
23766      &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01,
23767      &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01,
23768      &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02,
23769      &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01,
23770      &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01,
23771      &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01,
23772      &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23773      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23774      &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00,
23775      &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/
23776       DATA (DL(K),K=  171,  255) /
23777      &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01,
23778      &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00,
23779      &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00,
23780      &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00,
23781      &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00,
23782      &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00,
23783      &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00,
23784      &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00,
23785      &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02,
23786      &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00,
23787      &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00,
23788      &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00,
23789      &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00,
23790      &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00,
23791      &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00,
23792      &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01,
23793      &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/
23794       DATA (DL(K),K=  256,  340) /
23795      &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01,
23796      &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01,
23797      &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01,
23798      &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01,
23799      &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01,
23800      &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01,
23801      &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01,
23802      &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02,
23803      &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01,
23804      &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01,
23805      &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01,
23806      &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23807      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23808      &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00,
23809      &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00,
23810      &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01,
23811      &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/
23812       DATA (DL(K),K=  341,  425) /
23813      &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00,
23814      &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00,
23815      &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00,
23816      &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00,
23817      &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00,
23818      &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00,
23819      &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01,
23820      &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00,
23821      &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00,
23822      &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00,
23823      &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00,
23824      &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00,
23825      &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00,
23826      &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00,
23827      &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02,
23828      &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00,
23829      &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/
23830       DATA (DL(K),K=  426,  510) /
23831      &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00,
23832      &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00,
23833      &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00,
23834      &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00,
23835      &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01,
23836      &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02,
23837      &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01,
23838      &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01,
23839      &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01,
23840      &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23841      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23842      &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00,
23843      &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00,
23844      &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01,
23845      &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00,
23846      &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00,
23847      &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/
23848       DATA (DL(K),K=  511,  595) /
23849      &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00,
23850      &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00,
23851      &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00,
23852      &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00,
23853      &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01,
23854      &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00,
23855      &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00,
23856      &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00,
23857      &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00,
23858      &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00,
23859      &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00,
23860      &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00,
23861      &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01,
23862      &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00,
23863      &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00,
23864      &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00,
23865      &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/
23866       DATA (DL(K),K=  596,  680) /
23867      &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00,
23868      &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00,
23869      &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00,
23870      &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02,
23871      &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00,
23872      &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00,
23873      &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00,
23874      &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23875      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23876      &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23877      &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00,
23878      &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01,
23879      &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00,
23880      &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00,
23881      &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00,
23882      &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00,
23883      &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/
23884       DATA (DL(K),K=  681,  765) /
23885      &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00,
23886      &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00,
23887      &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01,
23888      &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00,
23889      &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00,
23890      &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00,
23891      &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00,
23892      &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00,
23893      &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00,
23894      &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00,
23895      &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01,
23896      &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00,
23897      &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00,
23898      &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00,
23899      &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00,
23900      &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00,
23901      &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/
23902       DATA (DL(K),K=  766,  850) /
23903      &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00,
23904      &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01,
23905      &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00,
23906      &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00,
23907      &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00,
23908      &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23909      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23910      &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23911      &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00,
23912      &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01,
23913      &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00,
23914      &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00,
23915      &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00,
23916      &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00,
23917      &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01,
23918      &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00,
23919      &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/
23920       DATA (DL(K),K=  851,  935) /
23921      &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01,
23922      &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00,
23923      &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00,
23924      &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00,
23925      &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00,
23926      &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00,
23927      &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00,
23928      &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00,
23929      &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01,
23930      &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00,
23931      &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00,
23932      &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00,
23933      &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00,
23934      &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00,
23935      &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00,
23936      &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00,
23937      &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/
23938       DATA (DL(K),K=  936, 1020) /
23939      &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00,
23940      &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00,
23941      &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00,
23942      &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23943      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23944      &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23945      &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00,
23946      &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01,
23947      &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00,
23948      &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00,
23949      &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00,
23950      &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00,
23951      &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01,
23952      &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00,
23953      &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00,
23954      &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01,
23955      &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/
23956       DATA (DL(K),K= 1021, 1105) /
23957      &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00,
23958      &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00,
23959      &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00,
23960      &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01,
23961      &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00,
23962      &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00,
23963      &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01,
23964      &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00,
23965      &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00,
23966      &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00,
23967      &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00,
23968      &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01,
23969      &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00,
23970      &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00,
23971      &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01,
23972      &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00,
23973      &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/
23974       DATA (DL(K),K= 1106, 1190) /
23975      &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00,
23976      &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00,
23977      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23978      &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01,
23979      &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00,
23980      &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01,
23981      &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01,
23982      &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00,
23983      &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01,
23984      &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01,
23985      &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01,
23986      &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01,
23987      &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00,
23988      &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01,
23989      &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01,
23990      &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00,
23991      &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/
23992       DATA (DL(K),K= 1191, 1275) /
23993      &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01,
23994      &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01,
23995      &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01,
23996      &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00,
23997      &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00,
23998      &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01,
23999      &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00,
24000      &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01,
24001      &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01,
24002      &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01,
24003      &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01,
24004      &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00,
24005      &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00,
24006      &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01,
24007      &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00,
24008      &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01,
24009      &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/
24010       DATA (DL(K),K= 1276, 1360) /
24011      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24012      &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01,
24013      &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00,
24014      &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00,
24015      &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01,
24016      &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00,
24017      &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01,
24018      &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01,
24019      &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02,
24020      &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01,
24021      &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00,
24022      &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00,
24023      &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01,
24024      &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00,
24025      &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01,
24026      &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01,
24027      &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/
24028       DATA (DL(K),K= 1361, 1445) /
24029      &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01,
24030      &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00,
24031      &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00,
24032      &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01,
24033      &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00,
24034      &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01,
24035      &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01,
24036      &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01,
24037      &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01,
24038      &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00,
24039      &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00,
24040      &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01,
24041      &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00,
24042      &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01,
24043      &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00,
24044      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24045      &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/
24046       DATA (DL(K),K= 1446, 1530) /
24047      &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00,
24048      &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00,
24049      &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01,
24050      &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00,
24051      &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01,
24052      &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01,
24053      &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02,
24054      &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01,
24055      &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00,
24056      &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00,
24057      &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01,
24058      &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00,
24059      &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01,
24060      &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01,
24061      &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02,
24062      &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01,
24063      &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/
24064       DATA (DL(K),K= 1531, 1615) /
24065      &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00,
24066      &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01,
24067      &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00,
24068      &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01,
24069      &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01,
24070      &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02,
24071      &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01,
24072      &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00,
24073      &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00,
24074      &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01,
24075      &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00,
24076      &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01,
24077      &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24078      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24079      &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01,
24080      &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00,
24081      &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/
24082       DATA (DL(K),K= 1616, 1700) /
24083      &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01,
24084      &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00,
24085      &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01,
24086      &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01,
24087      &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02,
24088      &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01,
24089      &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00,
24090      &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00,
24091      &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01,
24092      &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00,
24093      &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01,
24094      &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01,
24095      &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02,
24096      &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01,
24097      &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00,
24098      &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00,
24099      &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/
24100       DATA (DL(K),K= 1701, 1785) /
24101      &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00,
24102      &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01,
24103      &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01,
24104      &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02,
24105      &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01,
24106      &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00,
24107      &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00,
24108      &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02,
24109      &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00,
24110      &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02,
24111      &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24112      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24113      &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01,
24114      &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00,
24115      &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00,
24116      &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01,
24117      &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/
24118       DATA (DL(K),K= 1786, 1870) /
24119      &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01,
24120      &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01,
24121      &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02,
24122      &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01,
24123      &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00,
24124      &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00,
24125      &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02,
24126      &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00,
24127      &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02,
24128      &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02,
24129      &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02,
24130      &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02,
24131      &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00,
24132      &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00,
24133      &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02,
24134      &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00,
24135      &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/
24136       DATA (DL(K),K= 1871, 1955) /
24137      &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02,
24138      &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02,
24139      &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02,
24140      &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00,
24141      &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01,
24142      &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02,
24143      &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00,
24144      &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02,
24145      &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00,
24146      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24147      &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02,
24148      &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00,
24149      &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00,
24150      &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02,
24151      &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00,
24152      &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02,
24153      &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/
24154       DATA (DL(K),K= 1956, 2040) /
24155      &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03,
24156      &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02,
24157      &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00,
24158      &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00,
24159      &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02,
24160      &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00,
24161      &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02,
24162      &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02,
24163      &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03,
24164      &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02,
24165      &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00,
24166      &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01,
24167      &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02,
24168      &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00,
24169      &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02,
24170      &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02,
24171      &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/
24172       DATA (DL(K),K= 2041, 2125) /
24173      &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02,
24174      &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01,
24175      &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01,
24176      &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02,
24177      &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00,
24178      &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02,
24179      &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24180      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24181      &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02,
24182      &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00,
24183      &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00,
24184      &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02,
24185      &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00,
24186      &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02,
24187      &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02,
24188      &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03,
24189      &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/
24190       DATA (DL(K),K= 2126, 2210) /
24191      &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00,
24192      &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01,
24193      &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02,
24194      &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00,
24195      &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02,
24196      &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02,
24197      &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03,
24198      &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02,
24199      &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01,
24200      &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01,
24201      &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02,
24202      &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00,
24203      &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02,
24204      &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02,
24205      &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03,
24206      &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02,
24207      &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/
24208       DATA (DL(K),K= 2211, 2295) /
24209      &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01,
24210      &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02,
24211      &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00,
24212      &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02,
24213      &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24214      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24215      &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02,
24216      &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00,
24217      &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01,
24218      &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02,
24219      &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00,
24220      &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02,
24221      &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02,
24222      &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03,
24223      &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02,
24224      &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01,
24225      &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/
24226       DATA (DL(K),K= 2296, 2380) /
24227      &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02,
24228      &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00,
24229      &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02,
24230      &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02,
24231      &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03,
24232      &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02,
24233      &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01,
24234      &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01,
24235      &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02,
24236      &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00,
24237      &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03,
24238      &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03,
24239      &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03,
24240      &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03,
24241      &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01,
24242      &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01,
24243      &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/
24244       DATA (DL(K),K= 2381, 2465) /
24245      &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00,
24246      &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03,
24247      &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00,
24248      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24249      &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02,
24250      &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00,
24251      &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01,
24252      &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02,
24253      &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00,
24254      &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02,
24255      &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02,
24256      &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04,
24257      &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02,
24258      &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01,
24259      &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01,
24260      &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03,
24261      &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/
24262       DATA (DL(K),K= 2466, 2550) /
24263      &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03,
24264      &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03,
24265      &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03,
24266      &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03,
24267      &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01,
24268      &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01,
24269      &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03,
24270      &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00,
24271      &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03,
24272      &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03,
24273      &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03,
24274      &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03,
24275      &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01,
24276      &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02,
24277      &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03,
24278      &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00,
24279      &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/
24280       DATA (DL(K),K= 2551, 2635) /
24281      &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24282      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24283      &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03,
24284      &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01,
24285      &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01,
24286      &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03,
24287      &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00,
24288      &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03,
24289      &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03,
24290      &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04,
24291      &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03,
24292      &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01,
24293      &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01,
24294      &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03,
24295      &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00,
24296      &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03,
24297      &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/
24298       DATA (DL(K),K= 2636, 2720) /
24299      &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04,
24300      &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03,
24301      &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01,
24302      &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02,
24303      &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03,
24304      &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00,
24305      &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03,
24306      &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03,
24307      &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04,
24308      &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03,
24309      &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01,
24310      &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02,
24311      &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03,
24312      &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01,
24313      &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03,
24314      &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24315      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24316       DATA (DL(K),K= 2721, 2805) /
24317      &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03,
24318      &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01,
24319      &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01,
24320      &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03,
24321      &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00,
24322      &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03,
24323      &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03,
24324      &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04,
24325      &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03,
24326      &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01,
24327      &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02,
24328      &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03,
24329      &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00,
24330      &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03,
24331      &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03,
24332      &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04,
24333      &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/
24334       DATA (DL(K),K= 2806, 2890) /
24335      &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01,
24336      &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02,
24337      &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03,
24338      &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01,
24339      &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04,
24340      &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04,
24341      &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04,
24342      &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04,
24343      &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01,
24344      &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02,
24345      &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04,
24346      &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01,
24347      &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04,
24348      &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24349      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24350      &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03,
24351      &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/
24352       DATA (DL(K),K= 2891, 2975) /
24353      &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02,
24354      &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03,
24355      &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00,
24356      &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03,
24357      &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03,
24358      &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05,
24359      &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04,
24360      &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01,
24361      &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02,
24362      &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04,
24363      &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00,
24364      &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04,
24365      &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04,
24366      &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05,
24367      &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04,
24368      &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01,
24369      &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/
24370       DATA (DL(K),K= 2976, 3060) /
24371      &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04,
24372      &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01,
24373      &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04,
24374      &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04,
24375      &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05,
24376      &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04,
24377      &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02,
24378      &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02,
24379      &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04,
24380      &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01,
24381      &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04,
24382      &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24383      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24384      &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04,
24385      &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01,
24386      &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02,
24387      &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/
24388       DATA (DL(K),K= 3061, 3145) /
24389      &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00,
24390      &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04,
24391      &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04,
24392      &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05,
24393      &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04,
24394      &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01,
24395      &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02,
24396      &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04,
24397      &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01,
24398      &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04,
24399      &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04,
24400      &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05,
24401      &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04,
24402      &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02,
24403      &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02,
24404      &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04,
24405      &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/
24406       DATA (DL(K),K= 3146, 3230) /
24407      &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04,
24408      &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04,
24409      &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05,
24410      &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05,
24411      &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02,
24412      &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03,
24413      &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05,
24414      &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01,
24415      &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05,
24416      &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24417      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24418      &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04,
24419      &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01,
24420      &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02,
24421      &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04,
24422      &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01,
24423      &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/
24424       DATA (DL(K),K= 3231, 3315) /
24425      &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04,
24426      &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06,
24427      &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04,
24428      &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02,
24429      &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03,
24430      &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05,
24431      &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01,
24432      &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05,
24433      &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05,
24434      &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06,
24435      &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05,
24436      &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02,
24437      &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03,
24438      &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05,
24439      &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01,
24440      &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05,
24441      &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/
24442       DATA (DL(K),K= 3316, 3400) /
24443      &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06,
24444      &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05,
24445      &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02,
24446      &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03,
24447      &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05,
24448      &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01,
24449      &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05,
24450      &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24451      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24452      &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05,
24453      &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02,
24454      &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03,
24455      &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05,
24456      &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01,
24457      &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05,
24458      &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05,
24459      &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/
24460       DATA (DL(K),K= 3401, 3485) /
24461      &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05,
24462      &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02,
24463      &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03,
24464      &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05,
24465      &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01,
24466      &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05,
24467      &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05,
24468      &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07,
24469      &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05,
24470      &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02,
24471      &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03,
24472      &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05,
24473      &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01,
24474      &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06,
24475      &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06,
24476      &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06,
24477      &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/
24478       DATA (DL(K),K= 3486, 3570) /
24479      &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03,
24480      &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04,
24481      &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06,
24482      &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02,
24483      &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06,
24484      &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24485      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24486      &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05,
24487      &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02,
24488      &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03,
24489      &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06,
24490      &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01,
24491      &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06,
24492      &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06,
24493      &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07,
24494      &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06,
24495      &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/
24496       DATA (DL(K),K= 3571, 3655) /
24497      &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03,
24498      &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06,
24499      &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01,
24500      &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06,
24501      &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06,
24502      &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07,
24503      &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06,
24504      &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03,
24505      &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04,
24506      &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06,
24507      &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02,
24508      &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07,
24509      &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07,
24510      &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07,
24511      &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07,
24512      &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03,
24513      &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/
24514       DATA (DL(K),K= 3656, 3740) /
24515      &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06,
24516      &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02,
24517      &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07,
24518      &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00,
24519      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24520      &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07,
24521      &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02,
24522      &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04,
24523      &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07,
24524      &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01,
24525      &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07,
24526      &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07,
24527      &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07,
24528      &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07,
24529      &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03,
24530      &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04,
24531      &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/
24532       DATA (DL(K),K= 3741, 3825) /
24533      &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02,
24534      &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07,
24535      &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07,
24536      &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07,
24537      &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07,
24538      &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03,
24539      &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04,
24540      &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07,
24541      &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02,
24542      &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07,
24543      &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07,
24544      &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08,
24545      &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07,
24546      &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04,
24547      &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05,
24548      &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09,
24549      &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/
24550       DATA (DL(K),K= 3826, 3910) /
24551      &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08,
24552      &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00,
24553      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24554      &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08,
24555      &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03,
24556      &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05,
24557      &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06,
24558      &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02,
24559      &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07,
24560      &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07,
24561      &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07,
24562      &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07,
24563      &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04,
24564      &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05,
24565      &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06,
24566      &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03,
24567      &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/
24568       DATA (DL(K),K= 3911, 3995) /
24569      &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07,
24570      &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07,
24571      &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07,
24572      &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04,
24573      &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06,
24574      &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07,
24575      &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03,
24576      &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07,
24577      &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07,
24578      &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07,
24579      &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07,
24580      &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05,
24581      &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06,
24582      &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07,
24583      &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04,
24584      &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08,
24585      &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/
24586       DATA (DL(K),K= 3996, 4000) /
24587      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24588 C
24589       ANS = 0.
24590       IF (X.GT.0.9985) RETURN
24591       IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
24592 C
24593       IS  = S/DELTA+1
24594       IS1 = IS+1
24595       DO 1 L=1,25
24596          KL    = L+NDRV*25
24597          F1(L) = GF(I,IS,KL)
24598          F2(L) = GF(I,IS1,KL)
24599     1 CONTINUE
24600       A1 = DT_CKMTFF(X,F1)
24601       A2 = DT_CKMTFF(X,F2)
24602 C      A1=ALOG(A1)
24603 C      A2=ALOG(A2)
24604       S1  = (IS-1)*DELTA
24605       S2  = S1+DELTA
24606       ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
24607 C      ANS=EXP(ANS)
24608       RETURN
24609       END
24610 C
24611
24612 *$ CREATE DT_CKMTFF.FOR
24613 *COPY DT_CKMTFF
24614       FUNCTION DT_CKMTFF(X,FVL)
24615 C**********************************************************************
24616 C
24617 C     LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
24618 C     FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
24619 C     NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
24620 C     IN MAIN ROUTINE.
24621 C
24622 C**********************************************************************
24623
24624       SAVE
24625       DIMENSION FVL(25),XGRID(25)
24626       DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
24627      *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
24628 C
24629       DT_CKMTFF=0.
24630       DO 1 I=1,NX
24631       IF(X.LT.XGRID(I)) GO TO 2
24632     1 CONTINUE
24633     2 I=I-1
24634       IF(I.EQ.0) THEN
24635          I=I+1
24636       ELSE IF(I.GT.23) THEN
24637          I=23
24638       ENDIF
24639       J=I+1
24640       K=J+1
24641       AXI=LOG(XGRID(I))
24642       BXI=LOG(1.-XGRID(I))
24643       AXJ=LOG(XGRID(J))
24644       BXJ=LOG(1.-XGRID(J))
24645       AXK=LOG(XGRID(K))
24646       BXK=LOG(1.-XGRID(K))
24647       FI=LOG(ABS(FVL(I)) +1.E-15)
24648       FJ=LOG(ABS(FVL(J)) +1.E-16)
24649       FK=LOG(ABS(FVL(K)) +1.E-17)
24650       DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
24651       ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
24652      $ BXI))/DET
24653       ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
24654       BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
24655       IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
24656      1RETURN
24657 C      IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
24658 C         WRITE(6,2001) X,FVL
24659 C 2001    FORMAT(8E12.4)
24660 C         WRITE(6,2001) ALPHA,BETA,ALOGA,DET
24661 C      ENDIF
24662       DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
24663       RETURN
24664       END
24665
24666 *$ CREATE DT_FLUINI.FOR
24667 *COPY DT_FLUINI
24668 *
24669 *===fluini=============================================================*
24670 *
24671       SUBROUTINE DT_FLUINI
24672
24673 ************************************************************************
24674 * Initialisation of the nucleon-nucleon cross section fluctuation      *
24675 * treatment. The original version by J. Ranft.                         *
24676 * This version dated 21.04.95 is revised by S. Roesler.                *
24677 ************************************************************************
24678
24679       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24680       SAVE
24681       PARAMETER ( LINP = 10 ,
24682      &            LOUT = 6 ,
24683      &            LDAT = 9 )
24684       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
24685
24686       PARAMETER ( A     = 0.1D0,
24687      &            B     = 0.893D0,
24688      &            OM    = 1.1D0,
24689      &            N     = 6,
24690      &            DX    = 0.003D0)
24691
24692 * n-n cross section fluctuations
24693       PARAMETER (NBINS = 1000)
24694       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
24695       DIMENSION FLUSI(NBINS),FLUIX(NBINS)
24696
24697       WRITE(LOUT,1000)
24698  1000 FORMAT(/,1X,'FLUINI:  hadronic cross section fluctuations ',
24699      &       'treated')
24700
24701       FLUSU  = ZERO
24702       FLUSUU = ZERO
24703
24704       DO 1 I=1,NBINS
24705          X        = DBLE(I)*DX
24706          FLUIX(I) = X
24707          FLUS     = ((X-B)/(OM*B))**N
24708          IF (FLUS.LE.20.0D0) THEN
24709             FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
24710          ELSE
24711             FLUSI(I) = ZERO
24712          ENDIF
24713          FLUSU = FLUSU+FLUSI(I)
24714     1 CONTINUE
24715       DO 2 I=1,NBINS
24716          FLUSUU   = FLUSUU+FLUSI(I)/FLUSU
24717          FLUSI(I) = FLUSUU
24718     2 CONTINUE
24719
24720 C     WRITE(LOUT,1001)
24721 C1001 FORMAT(1X,'FLUCTUATIONS')
24722 C     CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
24723
24724       DO 3 I=1,NBINS
24725          AF = DBLE(I)*0.001D0
24726          DO 4 J=1,NBINS
24727             IF (AF.LE.FLUSI(J)) THEN
24728                FLUIXX(I) = FLUIX(J)
24729                GOTO 5
24730             ENDIF
24731     4    CONTINUE
24732     5    CONTINUE
24733     3 CONTINUE
24734       FLUIXX(1)     = FLUIX(1)
24735       FLUIXX(NBINS) = FLUIX(NBINS)
24736
24737       RETURN
24738       END
24739
24740 *$ CREATE DT_SIGTBL.FOR
24741 *COPY DT_SIGTBL
24742 *
24743 *===sigtab=============================================================*
24744 *
24745       SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
24746
24747 ************************************************************************
24748 * This version dated 18.11.95 is written by S. Roesler                 *
24749 ************************************************************************
24750
24751       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24752       SAVE
24753       PARAMETER ( LINP = 10 ,
24754      &            LOUT = 6 ,
24755      &            LDAT = 9 )
24756
24757       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24758      &           OHALF=0.5D0,ONE=1.0D0)
24759       PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150)
24760
24761       LOGICAL LINIT
24762
24763 * particle properties (BAMJET index convention)
24764       CHARACTER*8  ANAME
24765       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24766      &                IICH(210),IIBAR(210),K1(210),K2(210)
24767
24768       DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23)
24769       DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0,
24770      &             0, 0, 3, 4, 0, 0, 0, 0, 0, 0,
24771      &             0, 0, 5/
24772       DATA LINIT /.FALSE./
24773
24774 * precalculation and tabulation of elastic cross sections
24775       IF (ABS(MODE).EQ.1) THEN
24776          IF (MODE.EQ.1)
24777      &      OPEN(LDAT,FILE='outdata0/sigtab.out',STATUS='UNKNOWN')
24778          PLABLX = LOG10(PLO)
24779          PLABHX = LOG10(PHI)
24780          DPLAB  = (PLABHX-PLABLX)/DBLE(NBINS)
24781          DO 1 I=1,NBINS+1
24782             PLAB = PLABLX+DBLE(I-1)*DPLAB
24783             PLAB = 10**PLAB
24784             DO 2 IPROJ=1,23
24785                IDX = IDSIG(IPROJ)
24786                IF (IDX.GT.0) THEN
24787 C                 CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
24788 C                 CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
24789                   DUMZER = ZERO
24790                   CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
24791                   CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
24792                ENDIF
24793     2       CONTINUE
24794             IF (MODE.EQ.1) THEN
24795                WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5),
24796      &                                (SIGEN(IDX,I),IDX=1,5)
24797  1000          FORMAT(F5.1,10F7.2)
24798             ENDIF
24799     1    CONTINUE
24800          IF (MODE.EQ.1) CLOSE(LDAT)
24801          LINIT = .TRUE.
24802       ELSE
24803          SIGE = -ONE
24804          IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
24805      &                           .AND.(PTOT.LE.PHI) ) THEN
24806             IDX = IDSIG(JP)
24807             IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
24808                PLABX = LOG10(PTOT)
24809                IF (PLABX.LE.PLABLX) THEN
24810                   I1 = 1
24811                   I2 = 1
24812                ELSEIF (PLABX.GE.PLABHX) THEN
24813                   I1 = NBINS+1
24814                   I2 = NBINS+1
24815                ELSE
24816                   I1 = INT((PLABX-PLABLX)/DPLAB)+1
24817                   I2 = I1+1
24818                ENDIF
24819                PLAB1X = PLABLX+DBLE(I1-1)*DPLAB
24820                PLAB2X = PLABLX+DBLE(I2-1)*DPLAB
24821                PBIN   = PLAB2X-PLAB1X
24822                IF (PBIN.GT.TINY10) THEN
24823                   RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X)
24824                ELSE
24825                   RATX = ZERO
24826                ENDIF
24827                IF (JT.EQ.1) THEN
24828                   SIG1 = SIGEP(IDX,I1)
24829                   SIG2 = SIGEP(IDX,I2)
24830                ELSE
24831                   SIG1 = SIGEN(IDX,I1)
24832                   SIG2 = SIGEN(IDX,I2)
24833                ENDIF
24834                SIGE = SIG1+RATX*(SIG2-SIG1)
24835             ENDIF
24836          ENDIF
24837       ENDIF
24838
24839       RETURN
24840       END
24841
24842 *$ CREATE DT_XSTABL.FOR
24843 *COPY DT_XSTABL
24844 *
24845 *===xstabl=============================================================*
24846 *
24847       SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
24848
24849       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24850       SAVE
24851       PARAMETER ( LINP = 10 ,
24852      &            LOUT = 6 ,
24853      &            LDAT = 9 )
24854       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24855      &           OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
24856       LOGICAL LLAB,LELOG,LQLOG
24857
24858 * particle properties (BAMJET index convention)
24859       CHARACTER*8  ANAME
24860       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24861      &                IICH(210),IIBAR(210),K1(210),K2(210)
24862 * properties of interacting particles
24863       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
24864       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
24865 * Glauber formalism: cross sections
24866       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
24867      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
24868      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
24869      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
24870      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
24871      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
24872      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
24873      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
24874      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
24875      &                BSLOPE,NEBINI,NQBINI
24876 * emulsion treatment
24877       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
24878      &                NCOMPO,IEMUL
24879
24880       DIMENSION WHAT(6)
24881
24882       LLAB   = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
24883       ELO    = ABS(WHAT(1))
24884       EHI    = ABS(WHAT(2))
24885       IF (ELO.GT.EHI) ELO = EHI
24886       LELOG  = WHAT(3).LT.ZERO
24887       NEBINS = MAX(INT(ABS(WHAT(3))),1)
24888       DEBINS = (EHI-ELO)/DBLE(NEBINS)
24889       IF (LELOG) THEN
24890          AELO   = LOG10(ELO)
24891          AEHI   = LOG10(EHI)
24892          ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
24893       ENDIF
24894       Q2LO   = WHAT(4)
24895       Q2HI   = WHAT(5)
24896       IF (Q2LO.GT.Q2HI) Q2LO = Q2HI
24897       LQLOG  = WHAT(6).LT.ZERO
24898       NQBINS = MAX(INT(ABS(WHAT(6))),1)
24899       DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS)
24900       IF (LQLOG) THEN
24901          AQ2LO  = LOG10(Q2LO)
24902          AQ2HI  = LOG10(Q2HI)
24903          ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
24904       ENDIF
24905
24906       IF ( ELO.EQ. EHI) NEBINS = 0
24907       IF (Q2LO.EQ.Q2HI) NQBINS = 0
24908
24909       WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT
24910  1000 FORMAT(/,1X,'XSTABL:  E_lo  =',E10.3,' GeV  E_hi  =',E10.3,
24911      &       ' GeV     Lab = ',L1,'  qel: ',I2,/,10X,'Q2_lo =',F10.5,
24912      &       ' GeV^2  Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2,
24913      &       '   A_p = ',I3,'   A_t = ',I3,/)
24914
24915 C     IF (IJPROJ.NE.7) THEN
24916          WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)'
24917 * normalize fractions of emulsion components
24918          IF (NCOMPO.GT.0) THEN
24919             SUMFRA = ZERO
24920             DO 10 I=1,NCOMPO
24921                SUMFRA = SUMFRA+EMUFRA(I)
24922    10       CONTINUE
24923             IF (SUMFRA.GT.ZERO) THEN
24924                DO 11 I=1,NCOMPO
24925                   EMUFRA(I) = EMUFRA(I)/SUMFRA
24926    11          CONTINUE
24927             ENDIF
24928          ENDIF
24929 C     ELSE
24930 C        WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
24931 C     ENDIF
24932       DO 1 I=1,NEBINS+1
24933          IF (LELOG) THEN
24934             E = 10**(AELO+DBLE(I-1)*ADEBIN)
24935          ELSE
24936             E = ELO+DBLE(I-1)*DEBINS
24937          ENDIF
24938          DO 2 J=1,NQBINS+1
24939             IF (LQLOG) THEN
24940                Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
24941             ELSE
24942                Q2 = Q2LO+DBLE(J-1)*DQBINS
24943             ENDIF
24944 c            IF (IJPROJ.NE.7) THEN
24945                IF (LLAB) THEN
24946                   PLAB = ZERO
24947                   ECM  = ZERO
24948                   CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
24949                ELSE
24950                   ECM = E
24951                ENDIF
24952                XI  = ZERO
24953                Q2I = ZERO
24954                IF (IJPROJ.EQ.7) Q2I = Q2
24955                IF (NCOMPO.GT.0) THEN
24956                   DO 20 IC=1,NCOMPO
24957                      IIT = IEMUMA(IC)
24958                      CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
24959    20             CONTINUE
24960                ELSE
24961                   CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
24962 C                 CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
24963                ENDIF
24964                IF (NCOMPO.GT.0) THEN
24965                   XTOT = ZERO
24966                   ETOT = ZERO
24967                   XELA = ZERO
24968                   EELA = ZERO
24969                   XQEP = ZERO
24970                   EQEP = ZERO
24971                   XQET = ZERO
24972                   EQET = ZERO
24973                   XQE2 = ZERO
24974                   EQE2 = ZERO
24975                   XPRO = ZERO
24976                   EPRO = ZERO
24977                   XPRO1= ZERO
24978                   XDEL = ZERO
24979                   EDEL = ZERO
24980                   XDQE = ZERO
24981                   EDQE = ZERO
24982                   DO 21 IC=1,NCOMPO
24983                      XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC)
24984                      ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2
24985                      XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC)
24986                      EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2
24987                      XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC)
24988                      EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2
24989                      XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC)
24990                      EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2
24991                      XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC)
24992                      EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2
24993                      XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC)
24994                      EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2
24995                      XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC)
24996                      EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2
24997                      XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC)
24998                      EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2
24999                      YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC)
25000      &                     -XSQEP(1,1,IC)-XSQET(1,1,IC)
25001      &                     -XSQE2(1,1,IC)
25002                      XPRO1= XPRO1+EMUFRA(IC)*YPRO
25003    21             CONTINUE
25004                   ETOT = SQRT(ETOT)
25005                   EELA = SQRT(EELA)
25006                   EQEP = SQRT(EQEP)
25007                   EQET = SQRT(EQET)
25008                   EQE2 = SQRT(EQE2)
25009                   EPRO = SQRT(EPRO)
25010                   EDEL = SQRT(EDEL)
25011                   EDQE = SQRT(EDQE)
25012                   WRITE(LOUT,'(8E9.3)')
25013      &               E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
25014 C                 WRITE(LOUT,'(4E9.3)')
25015 C    &               E,XDEL,XDQE,XDEL+XDQE
25016                ELSE
25017                   WRITE(LOUT,'(11E10.3)')
25018      &              E,
25019      &              XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1),
25020      &              XSQE2(1,1,1),XSPRO(1,1,1),
25021      &              XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1)
25022      &             -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1),
25023      &              XSDEL(1,1,1)+XSDQE(1,1,1)
25024 C                 WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
25025 C    &                                    XSDEL(1,1,1)+XSDQE(1,1,1)
25026                ENDIF
25027 c            ELSE
25028 c               IF (LLAB) THEN
25029 c                  IF (IT.GT.1) THEN
25030 c                     IF (IXSQEL.EQ.0) THEN
25031 cC                       CALL DT_SIGGA(IT,  Q2, E,ZERO,ZERO,
25032 cC                       CALL DT_SIGGA(IT,   E,Q2,ZERO,ZERO,
25033 c                        CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
25034 c     &                             STOT,ETOT,SIN,EIN,STOT0)
25035 c                        IF (IRATIO.EQ.1) THEN
25036 c                           CALL DT_SIGGP(  Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
25037 cC                          CALL DT_SIGGP(   E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
25038 cC                          CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
25039 c*!! save cross sections
25040 c                           STOTA = STOT
25041 c                           ETOTA = ETOT
25042 c                           STOTP = STGP
25043 c*!!
25044 c                           STOT  = STOT/(DBLE(IT)*STGP)
25045 c                           SIN   =  SIN/(DBLE(IT)*SIGP)
25046 c                           STOT0 = STGP
25047 c                           ETOT  = ZERO
25048 c                           EIN   = ZERO
25049 c                        ENDIF
25050 c                     ELSE
25051 c                        WRITE(LOUT,*)
25052 c     &                  ' XSTABL:  qel. xs. not implemented for nuclei'
25053 c                        STOP
25054 c                     ENDIF
25055 c                  ELSE
25056 c                     ETOT = ZERO
25057 c                     EIN  = ZERO
25058 c                     STOT0= ZERO
25059 c                     IF (IXSQEL.EQ.0) THEN
25060 c                        CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
25061 c                     ELSE
25062 c                       SIN = ZERO
25063 c                       CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
25064 c                     ENDIF
25065 c                  ENDIF
25066 c               ELSE
25067 c                  IF (IT.GT.1) THEN
25068 c                     IF (IXSQEL.EQ.0) THEN
25069 c                        CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
25070 c     &                             STOT,ETOT,SIN,EIN,STOT0)
25071 c                        IF (IRATIO.EQ.1) THEN
25072 c                           CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
25073 c*!! save cross sections
25074 c                           STOTA = STOT
25075 c                           ETOTA = ETOT
25076 c                           STOTP = STGP
25077 c*!!
25078 c                           STOT  = STOT/(DBLE(IT)*STGP)
25079 c                           SIN   =  SIN/(DBLE(IT)*SIGP)
25080 c                           STOT0 = STGP
25081 c                           ETOT  = ZERO
25082 c                           EIN   = ZERO
25083 c                        ENDIF
25084 c                     ELSE
25085 c                        WRITE(LOUT,*)
25086 c     &                  ' XSTABL:  qel. xs. not implemented for nuclei'
25087 c                        STOP
25088 c                     ENDIF
25089 c                  ELSE
25090 c                     ETOT = ZERO
25091 c                     EIN  = ZERO
25092 c                     STOT0= ZERO
25093 c                     IF (IXSQEL.EQ.0) THEN
25094 c                        CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
25095 c                     ELSE
25096 c                       SIN = ZERO
25097 c                       CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
25098 c                     ENDIF
25099 c                  ENDIF
25100 c               ENDIF
25101 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
25102 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
25103 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
25104 c               WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
25105 c            ENDIF
25106     2    CONTINUE
25107     1 CONTINUE
25108
25109       RETURN
25110       END
25111
25112 *$ CREATE DT_TESTXS.FOR
25113 *COPY DT_TESTXS
25114 *
25115 *===testxs=============================================================*
25116 *
25117       SUBROUTINE DT_TESTXS
25118
25119       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25120       SAVE
25121
25122       DIMENSION XSTOT(26,2),XSELA(26,2)
25123
25124       OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN')
25125       OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN')
25126       OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN')
25127       OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN')
25128       DUMECM = 0.0D0
25129       PLABL = 0.01D0
25130       PLABH = 10000.0D0
25131       NBINS = 120
25132       APLABL = LOG10(PLABL)
25133       APLABH = LOG10(PLABH)
25134       ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
25135       DO 1 I=1,NBINS+1
25136          ADP = APLABL+DBLE(I-1)*ADPLAB
25137          P = 10.0D0**ADP
25138          DO 2 J=1,26
25139             CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1))
25140             CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2))
25141     2    CONTINUE
25142          WRITE(10,1000) P,(XSTOT(K,1),K=1,26)
25143          WRITE(11,1000) P,(XSELA(K,1),K=1,26)
25144          WRITE(12,1000) P,(XSTOT(K,2),K=1,26)
25145          WRITE(13,1000) P,(XSELA(K,2),K=1,26)
25146     1 CONTINUE
25147  1000 FORMAT(F8.3,26F9.3)
25148
25149       RETURN
25150       END
25151
25152 ************************************************************************
25153 *                                                                      *
25154 *  DTUNUC 2.0:   library routines                                      *
25155 *                                   processed by S. Roesler, 6.5.95    *
25156 *                                                                      *
25157 ************************************************************************
25158 *
25159 *     1) Handling of parton momenta
25160 *          SUBROUTINE MASHEL
25161 *          SUBROUTINE DFERMI
25162 *
25163 *     2) Handling of parton flavors and particle indices
25164 *          INTEGER FUNCTION IPDG2B
25165 *          INTEGER FUNCTION IB2PDG
25166 *          INTEGER FUNCTION IQUARK
25167 *          INTEGER FUNCTION IBJQUA
25168 *          INTEGER FUNCTION ICIHAD
25169 *          INTEGER FUNCTION IPDGHA
25170 *          INTEGER FUNCTION MCHAD
25171 *          SUBROUTINE FLAHAD
25172 *
25173 *     3) Energy-momentum and quantum number conservation check routines
25174 *          SUBROUTINE EMC1
25175 *          SUBROUTINE EMC2
25176 *          SUBROUTINE EVTEMC
25177 *          SUBROUTINE EVTFLC
25178 *          SUBROUTINE EVTCHG
25179 *
25180 *     4) Transformations
25181 *          SUBROUTINE LTINI
25182 *          SUBROUTINE LTRANS
25183 *          SUBROUTINE LTNUC
25184 *          SUBROUTINE DALTRA
25185 *          SUBROUTINE DTRAFO
25186 *          SUBROUTINE STTRAN
25187 *          SUBROUTINE MYTRAN
25188 *          SUBROUTINE LT2LAO
25189 *          SUBROUTINE LT2LAB
25190 *
25191 *     5) Sampling from distributions
25192 *          INTEGER FUNCTION NPOISS
25193 *          DOUBLE PRECISION FUNCTION SAMPXB
25194 *          DOUBLE PRECISION FUNCTION SAMPEX
25195 *          DOUBLE PRECISION FUNCTION SAMSQX
25196 *          DOUBLE PRECISION FUNCTION BETREJ
25197 *          DOUBLE PRECISION FUNCTION DGAMRN
25198 *          DOUBLE PRECISION FUNCTION DBETAR
25199 *          SUBROUTINE RANNOR
25200 *          SUBROUTINE DPOLI
25201 *          SUBROUTINE DSFECF
25202 *          SUBROUTINE RACO
25203 *
25204 *     6) Special functions, algorithms and service routines
25205 *          DOUBLE PRECISION FUNCTION YLAMB
25206 *          SUBROUTINE SORT
25207 *          SUBROUTINE SORT1
25208 *          SUBROUTINE DT_XTIME
25209 *
25210 *     7) Random number generator package
25211 *          DOUBLE PRECISION FUNCTION DT_RNDM
25212 *          SUBROUTINE DT_RNDMST
25213 *          SUBROUTINE DT_RNDMIN
25214 *          SUBROUTINE DT_RNDMOU
25215 *          SUBROUTINE DT_RNDMTE
25216 *
25217 ************************************************************************
25218 *                                                                      *
25219 *                 1) Handling of parton momenta                        *
25220 *                                                                      *
25221 ************************************************************************
25222 *$ CREATE DT_MASHEL.FOR
25223 *COPY DT_MASHEL
25224 *
25225 *===mashel=============================================================*
25226 *
25227       SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
25228
25229 ************************************************************************
25230 *                                                                      *
25231 *    rescaling of momenta of two partons to put both                   *
25232 *                                       on mass shell                  *
25233 *                                                                      *
25234 *    input:       PA1,PA2   input momentum vectors                     *
25235 *                 XM1,2     desired masses of particles afterwards     *
25236 *                 P1,P2     changed momentum vectors                   *
25237 *                                                                      *
25238 * The original version is written by R. Engel.                         *
25239 * This version dated 12.12.94 is modified by S. Roesler.               *
25240 ************************************************************************
25241
25242       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25243       SAVE
25244       PARAMETER ( LINP = 10 ,
25245      &            LOUT = 6 ,
25246      &            LDAT = 9 )
25247       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
25248
25249       DIMENSION PA1(4),PA2(4),P1(4),P2(4)
25250
25251       IREJ = 0
25252
25253 * Lorentz transformation into system CMS
25254       PX  = PA1(1)+PA2(1)
25255       PY  = PA1(2)+PA2(2)
25256       PZ  = PA1(3)+PA2(3)
25257       EE  = PA1(4)+PA2(4)
25258       XPTOT = SQRT(PX**2+PY**2+PZ**2)
25259       XMS   = (EE-XPTOT)*(EE+XPTOT)
25260       IF(XMS.LT.(XM1+XM2)**2) THEN
25261 C        WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
25262          GOTO 9999
25263       ENDIF
25264       XMS = SQRT(XMS)
25265       BGX = PX/XMS
25266       BGY = PY/XMS
25267       BGZ = PZ/XMS
25268       GAM = EE/XMS
25269       CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
25270      &           PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
25271 * rotation angles
25272       COD = P1(3)/PTOT1
25273 C     SID = SQRT((ONE-COD)*(ONE+COD))
25274       PPT = SQRT(P1(1)**2+P1(2)**2)
25275       SID = PPT/PTOT1
25276       COF = ONE
25277       SIF = ZERO
25278       IF(PTOT1*SID.GT.TINY10) THEN
25279          COF   = P1(1)/(SID*PTOT1)
25280          SIF   = P1(2)/(SID*PTOT1)
25281          ANORF = SQRT(COF*COF+SIF*SIF)
25282          COF   = COF/ANORF
25283          SIF   = SIF/ANORF
25284       ENDIF
25285 * new CM momentum and energies (for masses XM1,XM2)
25286       XM12 = SIGN(XM1**2,XM1)
25287       XM22 = SIGN(XM2**2,XM2)
25288       SS   = XMS**2
25289       PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
25290       EE1  = SQRT(XM12+PCMP**2)
25291       EE2  = XMS-EE1
25292 * back rotation
25293       MODE = 1
25294       CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
25295       CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
25296      &            PTOT1,P1(1),P1(2),P1(3),P1(4))
25297       CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
25298      &            PTOT2,P2(1),P2(2),P2(3),P2(4))
25299 * check consistency
25300       DEL = XMS*0.0001D0
25301       IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
25302         IDEV = 1
25303       ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
25304         IDEV = 2
25305       ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
25306         IDEV = 3
25307       ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
25308         IDEV = 4
25309       ELSE
25310         IDEV = 0
25311       ENDIF
25312       IF (IDEV.NE.0) THEN
25313          WRITE(LOUT,'(/1X,A,I3)')
25314      &      'MASHEL: inconsistent transformation',IDEV
25315          WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:'
25316          WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1
25317          WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2
25318          WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:'
25319          WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4)
25320          WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4)
25321       ENDIF
25322       RETURN
25323
25324  9999 CONTINUE
25325       IREJ = 1
25326       RETURN
25327       END
25328
25329 *$ CREATE DT_DFERMI.FOR
25330 *COPY DT_DFERMI
25331 *
25332 *===dfermi=============================================================*
25333 *
25334       SUBROUTINE DT_DFERMI(GPART)
25335
25336 ************************************************************************
25337 * Find largest of three random numbers.                                *
25338 ************************************************************************
25339
25340       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25341       SAVE
25342
25343       DIMENSION G(3)
25344
25345       DO 10 I=1,3
25346         G(I)=DT_RNDM(GPART)
25347    10 CONTINUE
25348       IF (G(3).LT.G(2)) GOTO 40
25349       IF (G(3).LT.G(1)) GOTO 30
25350       GPART = G(3)
25351    20 RETURN
25352    30 GPART = G(1)
25353       GOTO 20
25354    40 IF (G(2).LT.G(1)) GOTO 30
25355       GPART = G(2)
25356       GOTO 20
25357
25358       END
25359
25360 ************************************************************************
25361 *                                                                      *
25362 *         2) Handling of parton flavors and particle indices           *
25363 *                                                                      *
25364 ************************************************************************
25365 *$ CREATE IDT_IPDG2B.FOR
25366 *COPY IDT_IPDG2B
25367 *
25368 *===ipdg2b=============================================================*
25369 *
25370       INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
25371
25372 ************************************************************************
25373 *                                                                      *
25374 *     conversion of quark numbering scheme                             *
25375 *                                                                      *
25376 *     input:   PDG parton numbering                                    *
25377 *              for diquarks:  NN number of the constituent quark       *
25378 *                             (e.g. ID=2301,NN=1 -> ICONV2=1)          *
25379 *                                                                      *
25380 *     output:  BAMJET particle codes                                   *
25381 *              1 u     7 a-u   (MODE=1)  -1 a-u   (MODE=2)             *
25382 *              2 d     8 a-d             -2 a-d                        *
25383 *              3 s     9 a-s             -3 a-s                        *
25384 *              4 c    10 a-c             -4 a-c                        *
25385 *                                                                      *
25386 * This is a modified version of ICONV2 written by R. Engel.            *
25387 * This version dated 13.12.94 is written by S. Roesler.                *
25388 ************************************************************************
25389
25390       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25391       SAVE
25392       PARAMETER ( LINP = 10 ,
25393      &            LOUT = 6 ,
25394      &            LDAT = 9 )
25395
25396       IDA = ABS(ID)
25397 * diquarks
25398       IF (IDA.GT.6) THEN
25399         KF  = 3
25400         IF (IDA.GE.1000) KF = 4
25401         IDA = IDA/(10**(KF-NN))
25402         IDA = MOD(IDA,10)
25403       ENDIF
25404 * exchange up and dn quarks
25405       IF (IDA.EQ.1) THEN
25406         IDA = 2
25407       ELSEIF (IDA.EQ.2) THEN
25408         IDA = 1
25409       ENDIF
25410 * antiquarks
25411       IF (ID.LT.0) THEN
25412          IF (MODE.EQ.1) THEN
25413             IDA = IDA+6
25414          ELSE
25415             IDA = -IDA
25416          ENDIF
25417       ENDIF
25418       IDT_IPDG2B = IDA
25419
25420       RETURN
25421       END
25422
25423 *$ CREATE IDT_IB2PDG.FOR
25424 *COPY IDT_IB2PDG
25425 *
25426 *===ib2pdg=============================================================*
25427 *
25428       INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
25429
25430 ************************************************************************
25431 *                                                                      *
25432 *     conversion of quark numbering scheme                             *
25433 *                                                                      *
25434 *     input:   BAMJET particle codes                                   *
25435 *              1 u     7 a-u   (MODE=1)  -1 a-u   (MODE=2)             *
25436 *              2 d     8 a-d             -2 a-d                        *
25437 *              3 s     9 a-s             -3 a-s                        *
25438 *              4 c    10 a-c             -4 a-c                        *
25439 *                                                                      *
25440 *     output:  PDG parton numbering                                    *
25441 *                                                                      *
25442 * This version dated 13.12.94 is written by S. Roesler.                *
25443 ************************************************************************
25444
25445       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25446       SAVE
25447       PARAMETER ( LINP = 10 ,
25448      &            LOUT = 6 ,
25449      &            LDAT = 9 )
25450
25451       DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
25452       DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
25453       DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
25454      &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
25455      &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
25456
25457       IDA = ID1
25458       IDB = ID2
25459       IF (MODE.EQ.1) THEN
25460          IF (ID1.GT.6) IDA = -(ID1-6)
25461          IF (ID2.GT.6) IDB = -(ID2-6)
25462       ENDIF
25463       IF (ID2.EQ.0) THEN
25464          IDT_IB2PDG = IHKKQ(IDA)
25465       ELSE
25466          IDT_IB2PDG = IHKKQQ(IDA,IDB)
25467       ENDIF
25468
25469       RETURN
25470       END
25471
25472 *$ CREATE IDT_IQUARK.FOR
25473 *COPY IDT_IQUARK
25474 *
25475 *===ipdgqu=============================================================*
25476 *
25477       INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
25478
25479 ************************************************************************
25480 *                                                                      *
25481 *     quark contents according to PDG conventions                      *
25482 *     (random selection in case of quark mixing)                       *
25483 *                                                                      *
25484 *     input:   IDBAMJ BAMJET particle code                             *
25485 *              K      1..3   quark number                              *
25486 *                                                                      *
25487 *     output:  1   d  (anti --> neg.)                                  *
25488 *              2   u                                                   *
25489 *              3   s                                                   *
25490 *              4   c                                                   *
25491 *                                                                      *
25492 * This version written by R. Engel.                                    *
25493 ************************************************************************
25494
25495       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25496       SAVE
25497
25498       IQ = IDT_IBJQUA(K,IDBAMJ)
25499 * quark-antiquark
25500       IF (IQ.GT.6) THEN
25501          IQ = 6-IQ
25502       ENDIF
25503 * exchange of up and down
25504       IF (ABS(IQ).EQ.1) THEN
25505          IQ = SIGN(2,IQ)
25506       ELSEIF (ABS(IQ).EQ.2) THEN
25507          IQ = SIGN(1,IQ)
25508       ENDIF
25509       IDT_IQUARK = IQ
25510
25511       RETURN
25512       END
25513
25514 *$ CREATE IDT_IBJQUA.FOR
25515 *COPY IDT_IBJQUA
25516 *
25517 *===ibamq==============================================================*
25518 *
25519       INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
25520
25521 ************************************************************************
25522 *                                                                      *
25523 *     quark contents according to BAMJET conventions                   *
25524 *     (random selection in case of quark mixing)                       *
25525 *                                                                      *
25526 *     input:   IDBAMJ BAMJET particle code                             *
25527 *              K      1..3   quark number                              *
25528 *                                                                      *
25529 *     output:  1   u      7   u bar                                    *
25530 *              2   d      8   d bar                                    *
25531 *              3   s      9   s bar                                    *
25532 *              4   c     10   c bar                                    *
25533 *                                                                      *
25534 * This version written by R. Engel.                                    *
25535 ************************************************************************
25536
25537       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25538       SAVE
25539
25540       DIMENSION ITAB(3,210)
25541       DATA ((ITAB(I,K),I=1,3),K=1,30) /
25542      &    1,  1,  2,   7,  7,  8,   0,  0,  0,
25543      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25544      &    0,  0,  0,   1,  2,  2,   7,  8,  8,
25545 *sr 10.1.94
25546 C    &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25547      &    0,  0,  0,   0,  0,  0,   3,  8,  0,
25548 *
25549      &    1,  8,  0,   2,  7,  0,   1,  9,  0,
25550 *sr 10.1.94
25551 C    &    3,  7,  0,   0,  0,  0,   0,  0,  0,
25552      &    3,  7,  0,   3,  1,  2,   9,  7,  8,
25553 *sr 10.1.94
25554 C    &    0,  0,  0,   2,  2,  3,   1,  1,  3,
25555      &    2,  9,  0,   2,  2,  3,   1,  1,  3,
25556 *
25557      &    1,  2,  3, 201,202,  0,   2,  9,  0,
25558      &    3,  8,  0,   0,  0,  0,   0,  0,  0,
25559      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25560       DATA ((ITAB(I,K),I=1,3),K=31,60) /
25561      &    3,  9,  0,   1,  8,  0, 203,204,  0,
25562      &    2,  7,  0,   0,  0,  0,   1,  9,  0,
25563      &    2,  9,  0,   3,  7,  0,   3,  8,  0,
25564      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25565      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25566      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25567      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25568      &    0,  0,  0,   1,  1,  1,   1,  1,  2,
25569      &    1,  2,  2,   2,  2,  2,   0,  0,  0,
25570      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25571       DATA ((ITAB(I,K),I=1,3),K=61,90) /
25572      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25573      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25574      &    7,  7,  7,   7,  7,  8,   7,  8,  8,
25575      &    8,  8,  8,   0,  0,  0,   0,  0,  0,
25576      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25577      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25578      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25579      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25580      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25581      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25582       DATA ((ITAB(I,K),I=1,3),K=91,120) /
25583      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25584      &    0,  0,  0,   0,  0,  0,   3,  9,  0,
25585      &    1,  3,  3,   2,  3,  3,   7,  7,  9,
25586      &    7,  8,  9,   8,  8,  9,   7,  9,  9,
25587      &    8,  9,  9,   1,  1,  3,   1,  2,  3,
25588      &    2,  2,  3,   1,  3,  3,   2,  3,  3,
25589      &    3,  3,  3,   7,  7,  9,   7,  8,  9,
25590      &    8,  8,  9,   7,  9,  9,   8,  9,  9,
25591      &    9,  9,  9,   4,  7,  0,   4,  8,  0,
25592      &    2, 10,  0,   1, 10,  0,   4,  9,  0 /
25593       DATA ((ITAB(I,K),I=1,3),K=121,150) /
25594      &    3, 10,  0,   4, 10,  0,   4,  7,  0,
25595      &    4,  8,  0,   2, 10,  0,   1, 10,  0,
25596      &    4,  9,  0,   3, 10,  0,   4, 10,  0,
25597      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25598      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25599      &    0,  0,  0,   1,  2,  4,   1,  3,  4,
25600      &    2,  3,  4,   1,  1,  4,   0,  0,  0,
25601      &    2,  2,  4,   0,  0,  0,   0,  0,  0,
25602      &    3,  3,  4,   1,  4,  4,   2,  4,  4,
25603      &    3,  4,  4,   7,  8, 10,   7,  9, 10 /
25604       DATA ((ITAB(I,K),I=1,3),K=151,180) /
25605      &    8,  9, 10,   7,  7, 10,   0,  0,  0,
25606      &    8,  8, 10,   0,  0,  0,   0,  0,  0,
25607      &    9,  9, 10,   7, 10, 10,   8, 10, 10,
25608      &    9, 10, 10,   1,  1,  4,   1,  2,  4,
25609      &    2,  2,  4,   1,  3,  4,   2,  3,  4,
25610      &    3,  3,  4,   1,  4,  4,   2,  4,  4,
25611      &    3,  4,  4,   4,  4,  4,   7,  7, 10,
25612      &    7,  8, 10,   8,  8, 10,   7,  9, 10,
25613      &    8,  9, 10,   9,  9, 10,   7, 10, 10,
25614      &    8, 10, 10,   9, 10, 10,  10, 10, 10 /
25615       DATA ((ITAB(I,K),I=1,3),K=181,210) /
25616      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25617      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25618      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25619      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25620      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25621      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25622      &    0,  0,  0,   0,  0,  0,   1,  7,  0,
25623      &    2,  8,  0,   1,  7,  0,   2,  8,  0,
25624      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25625      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25626       DATA IDOLD /0/
25627
25628       ONE = 1.0D0
25629       IF (ITAB(1,IDBAMJ).LE.200) THEN
25630          ID = ITAB(K,IDBAMJ)
25631       ELSE
25632          IF(IDOLD.NE.IDBAMJ) THEN
25633             IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
25634      &           DT_RNDM(ONE)+ITAB(1,IDBAMJ))
25635         ELSE
25636            IDOLD = 0
25637         ENDIF
25638         ID = ITAB(K,IT)
25639       ENDIF
25640       IDOLD  = IDBAMJ
25641       IDT_IBJQUA = ID
25642
25643       RETURN
25644       END
25645
25646 *$ CREATE IDT_ICIHAD.FOR
25647 *COPY IDT_ICIHAD
25648 *
25649 *===icihad=============================================================*
25650 *
25651       INTEGER FUNCTION IDT_ICIHAD(MCIND)
25652
25653 ************************************************************************
25654 * Conversion of particle index PDG proposal --> BAMJET-index scheme    *
25655 * This is a completely new version dated 25.10.95.                     *
25656 * Renamed to be not in conflict with the modified PHOJET-version       *
25657 ************************************************************************
25658
25659       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25660       SAVE
25661
25662 * hadron index conversion (BAMJET <--> PDG)
25663       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25664      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25665      &                IAMCIN(210)
25666
25667       IDT_ICIHAD = 0
25668       KPDG   = ABS(MCIND)
25669       IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
25670       IF (MCIND.LT.0) THEN
25671          JSIGN = 1
25672       ELSE
25673          JSIGN = 2
25674       ENDIF
25675       IF (KPDG.GE.10000) THEN
25676          DO 1 I=1,19
25677             IDT_ICIHAD = IBAM5(JSIGN,I)
25678             IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
25679             IDT_ICIHAD = 0
25680     1    CONTINUE
25681       ELSEIF (KPDG.GE.1000) THEN
25682          DO 2 I=1,29
25683             IDT_ICIHAD = IBAM4(JSIGN,I)
25684             IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
25685             IDT_ICIHAD = 0
25686     2    CONTINUE
25687       ELSEIF (KPDG.GE.100) THEN
25688          DO 3 I=1,22
25689             IDT_ICIHAD = IBAM3(JSIGN,I)
25690             IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
25691             IDT_ICIHAD = 0
25692     3    CONTINUE
25693       ELSEIF (KPDG.GE.10) THEN
25694          DO 4 I=1,7
25695             IDT_ICIHAD = IBAM2(JSIGN,I)
25696             IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
25697             IDT_ICIHAD = 0
25698     4    CONTINUE
25699       ENDIF
25700     5 CONTINUE
25701
25702       RETURN
25703       END
25704
25705 *$ CREATE IDT_IPDGHA.FOR
25706 *COPY IDT_IPDGHA
25707 *
25708 *===ipdgha=============================================================*
25709 *
25710       INTEGER FUNCTION IDT_IPDGHA(MCIND)
25711
25712 ************************************************************************
25713 * Conversion of particle index BAMJET-index scheme --> PDG proposal    *
25714 * Adopted from the original by S. Roesler. This version dated 12.5.95  *
25715 * Renamed to be not in conflict with the modified PHOJET-version       *
25716 ************************************************************************
25717
25718       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25719       SAVE
25720
25721 * hadron index conversion (BAMJET <--> PDG)
25722       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25723      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25724      &                IAMCIN(210)
25725
25726       IDT_IPDGHA = IAMCIN(MCIND)
25727
25728       RETURN
25729       END
25730
25731 *$ CREATE DT_FLAHAD.FOR
25732 *COPY DT_FLAHAD
25733 *
25734 *===flahad=============================================================*
25735 *
25736       SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
25737
25738 ************************************************************************
25739 * sampling of FLAvor composition for HADrons/photons                   *
25740 *              ID         BAMJET-id of hadron                          *
25741 *              IF1,2,3    flavor content                               *
25742 *                         (u,d,s: 1,2,3;  au,ad,as: -1,-1,-3)          *
25743 * Note:  -  u,d numbering as in BAMJET                                 *
25744 *        -  ID .le. 30 !!                                              *
25745 * This version dated 12.03.96 is written by S. Roesler                 *
25746 ************************************************************************
25747
25748       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25749       SAVE
25750
25751 * auxiliary common for reggeon exchange (DTUNUC 1.x)
25752       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
25753      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
25754      &                IQTCHR(-6:6),MQUARK(3,39)
25755
25756       DIMENSION JSEL(3,6)
25757       DATA JSEL/ 1,2,3,  2,3,1,  3,1,2,  1,3,2,   2,1,3,   3,2,1/
25758
25759       ONE = 1.0D0
25760       IF (ID.EQ.7) THEN
25761 * photon (charge dependent flavour sampling)
25762          K = INT(DT_RNDM(ONE)*6.D0+1.D0)
25763          IF (K.LE.4) THEN
25764             IF1 = 2
25765             IF2 = -2
25766          ELSE IF(K.EQ.5) THEN
25767             IF1 = 1
25768             IF2 = -1
25769          ELSE
25770             IF1 = 3
25771             IF2 = -3
25772          ENDIF
25773          IF(DT_RNDM(ONE).LT.0.5D0) THEN
25774             K   = IF1
25775             IF1 = IF2
25776             IF2 = K
25777          ENDIF
25778          IF3 = 0
25779       ELSE
25780 * hadron
25781          IX  = INT(1.0D0+5.99999D0*DT_RNDM(ONE))
25782          IF1 = MQUARK(JSEL(1,IX),ID)
25783          IF2 = MQUARK(JSEL(2,IX),ID)
25784          IF3 = MQUARK(JSEL(3,IX),ID)
25785          IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN
25786             IF1 = IF3
25787             IF3 = 0
25788          ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
25789             IF2 = IF3
25790             IF3 = 0
25791          ENDIF
25792       ENDIF
25793
25794       RETURN
25795       END
25796
25797 *$ CREATE IDT_MCHAD.FOR
25798 *COPY IDT_MCHAD
25799 *
25800 *===mchad==============================================================*
25801 *
25802       INTEGER FUNCTION IDT_MCHAD(ITDTU)
25803
25804 ************************************************************************
25805 * Conversion of particle index BAMJET-index scheme --> HADRIN index s. *
25806 * Adopted from the original by S. Roesler. This version dated 6.5.95   *
25807 *                                                                      *
25808 * Last change 28.12.2006 by S. Roesler.                                *
25809 ************************************************************************
25810
25811       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25812       SAVE
25813
25814       DIMENSION ITRANS(210)
25815       DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14,
25816      &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13,
25817      &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8,
25818      &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2,
25819      &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1,
25820      &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9,
25821      &9, 9, 9, 85*- 1,7*-1,1,8,-1/
25822
25823       IF ( ITDTU .GT. 0 ) THEN
25824          IDT_MCHAD = ITRANS(ITDTU)
25825       ELSE
25826          IDT_MCHAD = -1
25827       END IF
25828
25829       RETURN
25830       END
25831
25832 ************************************************************************
25833 *                                                                      *
25834 *   3) Energy-momentum and quantum number conservation check routines  *
25835 *                                                                      *
25836 ************************************************************************
25837 *$ CREATE DT_EMC1.FOR
25838 *COPY DT_EMC1
25839 *
25840 *===emc1===============================================================*
25841 *
25842       SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
25843
25844 ************************************************************************
25845 * This version dated 15.12.94 is written by S. Roesler                 *
25846 ************************************************************************
25847
25848       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25849       SAVE
25850       PARAMETER ( LINP = 10 ,
25851      &            LOUT = 6 ,
25852      &            LDAT = 9 )
25853       PARAMETER (TINY10=1.0D-10)
25854
25855       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
25856
25857       IREJ = 0
25858
25859       IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
25860      &   WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
25861
25862       IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN
25863          IF (MODE.EQ.1) THEN
25864             CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM)
25865          ELSEIF (MODE.EQ.2) THEN
25866             CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM)
25867          ENDIF
25868          CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM)
25869          CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM)
25870          CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM)
25871       ELSEIF (MODE.LT.0) THEN
25872          IF (MODE.EQ.-1) THEN
25873             CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM)
25874          ELSEIF (MODE.EQ.-2) THEN
25875             CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM)
25876          ENDIF
25877          CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM)
25878          CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM)
25879          CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM)
25880       ENDIF
25881
25882       IF (ABS(MODE).EQ.3) THEN
25883          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1)
25884          IF (IREJ1.NE.0) GOTO 9999
25885       ENDIF
25886       RETURN
25887
25888  9999 CONTINUE
25889       IREJ = 1
25890       RETURN
25891       END
25892
25893 *$ CREATE DT_EMC2.FOR
25894 *COPY DT_EMC2
25895 *
25896 *===emc2===============================================================*
25897 *
25898       SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
25899      &                                                MODE,IPOS,IREJ)
25900
25901 ************************************************************************
25902 *             MODE = 1   energy-momentum cons. check                   *
25903 *                  = 2   flavor-cons. check                            *
25904 *                  = 3   energy-momentum & flavor cons. check          *
25905 *                  = 4   energy-momentum & charge cons. check          *
25906 *                  = 5   energy-momentum & flavor & charge cons. check *
25907 * This version dated 16.01.95 is written by S. Roesler                 *
25908 ************************************************************************
25909
25910       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25911       SAVE
25912       PARAMETER ( LINP = 10 ,
25913      &            LOUT = 6 ,
25914      &            LDAT = 9 )
25915       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
25916
25917 * event history
25918       PARAMETER (NMXHKK=200000)
25919       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25920      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25921      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25922 * extended event history
25923       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25924      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25925      &                IHIST(2,NMXHKK)
25926
25927       IREJ  = 0
25928       IREJ1 = 0
25929       IREJ2 = 0
25930       IREJ3 = 0
25931
25932       IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25933      &                CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM)
25934       IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25935      &                                CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM)
25936       IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM)
25937       DO 1 I=1,NHKK
25938          IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR.
25939      &       (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR.
25940      &       (ISTHKK(I).EQ.IP5))                          THEN
25941             IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25942      &                                    .OR.(MODE.EQ.5))
25943      &      CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
25944      &                                               2,IDUM,IDUM)
25945             IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25946      &         CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM)
25947             IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25948      &                            CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM)
25949          ENDIF
25950          IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR.
25951      &       (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR.
25952      &       (ISTHKK(I).EQ.IN5))                          THEN
25953             IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25954      &                                    .OR.(MODE.EQ.5))
25955      &      CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
25956      &                                                   2,IDUM,IDUM)
25957             IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25958      &         CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM)
25959             IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25960      &                            CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM)
25961          ENDIF
25962     1 CONTINUE
25963       IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25964      &   CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1)
25965       IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25966      &   CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2)
25967       IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3)
25968       IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999
25969
25970       RETURN
25971
25972  9999 CONTINUE
25973       IREJ = 1
25974       RETURN
25975       END
25976
25977 *$ CREATE DT_EVTEMC.FOR
25978 *COPY DT_EVTEMC
25979 *
25980 *===evtemc=============================================================*
25981 *
25982       SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
25983
25984 ************************************************************************
25985 * This version dated 13.12.94 is written by S. Roesler                 *
25986 ************************************************************************
25987
25988       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25989       SAVE
25990       PARAMETER ( LINP = 10 ,
25991      &            LOUT = 6 ,
25992      &            LDAT = 9 )
25993       PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10,
25994      &           ZERO=0.0D0)
25995
25996 * event history
25997       PARAMETER (NMXHKK=200000)
25998       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25999      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26000      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26001 * flags for input different options
26002       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
26003       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
26004      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
26005
26006       IREJ = 0
26007
26008       MODE = IMODE
26009       CHKLEV = TINY10
26010       IF (MODE.EQ.4) THEN
26011          CHKLEV = TINY2
26012          MODE   = 3
26013       ELSEIF (MODE.EQ.5) THEN
26014          CHKLEV = TINY1
26015          MODE   = 3
26016       ELSEIF (MODE.EQ.-1) THEN
26017          CHKLEV = EIO
26018          MODE   = 3
26019       ENDIF
26020
26021       IF (ABS(MODE).EQ.3) THEN
26022          PXDEV = PX
26023          PYDEV = PY
26024          PZDEV = PZ
26025          EDEV  = E
26026          IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4
26027          IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR.
26028      &       (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN
26029             IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)')
26030      &         'EVTEMC: energy-momentum cons. failure at pos. ',IPOS,
26031      &         '  event  ',NEVHKK,
26032      &         ' ! ',PXDEV,PYDEV,PZDEV,EDEV
26033             PX   = 0.0D0
26034             PY   = 0.0D0
26035             PZ   = 0.0D0
26036             E    = 0.0D0
26037             GOTO 9999
26038          ENDIF
26039          PX   = 0.0D0
26040          PY   = 0.0D0
26041          PZ   = 0.0D0
26042          E    = 0.0D0
26043          RETURN
26044       ENDIF
26045
26046       IF (MODE.EQ.1) THEN
26047          PX = 0.0D0
26048          PY = 0.0D0
26049          PZ = 0.0D0
26050          E  = 0.0D0
26051       ENDIF
26052
26053       PX = PX+PXIO
26054       PY = PY+PYIO
26055       PZ = PZ+PZIO
26056       E  = E+EIO
26057
26058       RETURN
26059
26060  9999 CONTINUE
26061       IREJ = 1
26062       RETURN
26063       END
26064
26065 *$ CREATE DT_EVTFLC.FOR
26066 *COPY DT_EVTFLC
26067 *
26068 *===evtflc=============================================================*
26069 *
26070       SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
26071
26072 ************************************************************************
26073 * Flavor conservation check.                                           *
26074 *        ID       identity of particle                                 *
26075 *        ID1 = 1  ID for q,aq,qq,aqaq in PDG-numbering scheme          *
26076 *            = 2  ID for particle/resonance in BAMJET numbering scheme *
26077 *            = 3  ID for particle/resonance in PDG    numbering scheme *
26078 *        MODE = 1 initialization and add ID                            *
26079 *             =-1 initialization and subtract ID                       *
26080 *             = 2 add ID                                               *
26081 *             =-2 subtract ID                                          *
26082 *             = 3 check flavor cons.                                   *
26083 *        IPOS     flag to give position of call of EVTFLC to output    *
26084 *                 unit in case of violation                            *
26085 * This version dated 10.01.95 is written by S. Roesler                 *
26086 ************************************************************************
26087
26088       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26089       SAVE
26090       PARAMETER ( LINP = 10 ,
26091      &            LOUT = 6 ,
26092      &            LDAT = 9 )
26093       PARAMETER (TINY10=1.0D-10)
26094
26095       IREJ = 0
26096
26097       IF (MODE.EQ.3) THEN
26098          IF (IFL.NE.0) THEN
26099             WRITE(LOUT,'(1X,A,I3,A,I3)')
26100      &         'EVTFLC: flavor-conservation failure at pos. ',IPOS,
26101      &         ' !  IFL = ',IFL
26102             IFL = 0
26103             GOTO 9999
26104          ENDIF
26105          IFL = 0
26106          RETURN
26107       ENDIF
26108
26109       IF (MODE.EQ.1) IFL = 0
26110       IF (ID.EQ.0)   RETURN
26111
26112       IF (ID1.EQ.1) THEN
26113          IDD = ABS(ID)
26114          NQ  = 1
26115          IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
26116          IF (IDD.GE.1000) NQ = 3
26117          DO 1 I=1,NQ
26118             IFBAM = IDT_IPDG2B(ID,I,2)
26119             IF (ABS(IFBAM).EQ.1) THEN
26120                IFBAM = SIGN(2,IFBAM)
26121             ELSEIF (ABS(IFBAM).EQ.2) THEN
26122                IFBAM = SIGN(1,IFBAM)
26123             ENDIF
26124             IF (MODE.GT.0) THEN
26125                IFL = IFL+IFBAM
26126             ELSE
26127                IFL = IFL-IFBAM
26128             ENDIF
26129     1    CONTINUE
26130          RETURN
26131       ENDIF
26132
26133       IDD = ID
26134       IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
26135       IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
26136          DO 2 I=1,3
26137             IF (MODE.GT.0) THEN
26138                IFL = IFL+IDT_IQUARK(I,IDD)
26139             ELSE
26140                IFL = IFL-IDT_IQUARK(I,IDD)
26141             ENDIF
26142     2    CONTINUE
26143       ENDIF
26144       RETURN
26145
26146  9999 CONTINUE
26147       IREJ = 1
26148       RETURN
26149       END
26150
26151 *$ CREATE DT_EVTCHG.FOR
26152 *COPY DT_EVTCHG
26153 *
26154 *===evtchg=============================================================*
26155 *
26156       SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
26157
26158 ************************************************************************
26159 * Charge conservation check.                                           *
26160 *        ID       identity of particle (PDG-numbering scheme)          *
26161 *        MODE = 1 initialization                                       *
26162 *             =-2 subtract ID-charge                                   *
26163 *             = 2 add ID-charge                                        *
26164 *             = 3 check charge cons.                                   *
26165 *        IPOS     flag to give position of call of EVTCHG to output    *
26166 *                 unit in case of violation                            *
26167 * This version dated 10.01.95 is written by S. Roesler                 *
26168 * Last change: s.r. 21.01.01                                           *
26169 ************************************************************************
26170
26171       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26172       SAVE
26173       PARAMETER ( LINP = 10 ,
26174      &            LOUT = 6 ,
26175      &            LDAT = 9 )
26176
26177 * event history
26178       PARAMETER (NMXHKK=200000)
26179       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26180      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26181      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26182 * particle properties (BAMJET index convention)
26183       CHARACTER*8  ANAME
26184       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26185      &                IICH(210),IIBAR(210),K1(210),K2(210)
26186
26187       IREJ = 0
26188
26189       IF (MODE.EQ.1) THEN
26190          ICH  = 0
26191          IBAR = 0
26192          RETURN
26193       ENDIF
26194
26195       IF (MODE.EQ.3) THEN
26196          IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN
26197             WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)')
26198      &         'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS,
26199      &         '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK
26200             ICH  = 0
26201             IBAR = 0
26202             GOTO 9999
26203          ENDIF
26204          ICH  = 0
26205          IBAR = 0
26206          RETURN
26207       ENDIF
26208
26209       IF (ID.EQ.0)   RETURN
26210
26211       IDD = IDT_ICIHAD(ID)
26212 * modification 21.1.01: use intrinsic phojet-functions to determine charge
26213 * and baryon number
26214 C     IF (IDD.GT.0) THEN
26215 C        IF (MODE.EQ.2) THEN
26216 C           ICH  = ICH+IICH(IDD)
26217 C           IBAR = IBAR+IIBAR(IDD)
26218 C        ELSEIF (MODE.EQ.-2) THEN
26219 C           ICH  = ICH-IICH(IDD)
26220 C           IBAR = IBAR-IIBAR(IDD)
26221 C        ENDIF
26222 C     ELSE
26223 C        WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
26224 C        CALL DT_EVTOUT(4)
26225 C        STOP
26226 C     ENDIF
26227       IF (MODE.EQ.2) THEN
26228          ICH  = ICH+IPHO_CHR3(ID,1)/3
26229          IBAR = IBAR+IPHO_BAR3(ID,1)/3
26230       ELSEIF (MODE.EQ.-2) THEN
26231          ICH  = ICH-IPHO_CHR3(ID,1)/3
26232          IBAR = IBAR-IPHO_BAR3(ID,1)/3
26233       ENDIF
26234
26235       RETURN
26236
26237  9999 CONTINUE
26238       IREJ = 1
26239       RETURN
26240       END
26241
26242 ************************************************************************
26243 *                                                                      *
26244 *                 4) Transformations                                   *
26245 *                                                                      *
26246 ************************************************************************
26247 *$ CREATE DT_LTINI.FOR
26248 *COPY DT_LTINI
26249 *
26250 *===ltini==============================================================*
26251 *
26252       SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
26253
26254 ************************************************************************
26255 * Initializations of Lorentz-transformations, calculation of Lorentz-  *
26256 * parameters.                                                          *
26257 * This version dated 13.11.95 is written by  S. Roesler.               *
26258 ************************************************************************
26259
26260       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26261       SAVE
26262       PARAMETER ( LINP = 10 ,
26263      &            LOUT = 6 ,
26264      &            LDAT = 9 )
26265       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,
26266      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
26267
26268 * Lorentz-parameters of the current interaction
26269       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26270      &                UMO,PPCM,EPROJ,PPROJ
26271 * properties of photon/lepton projectiles
26272       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
26273 * particle properties (BAMJET index convention)
26274       CHARACTER*8  ANAME
26275       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26276      &                IICH(210),IIBAR(210),K1(210),K2(210)
26277 * nucleon-nucleon event-generator
26278       CHARACTER*8 CMODEL
26279       LOGICAL LPHOIN
26280       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
26281
26282       Q2   = VIRT
26283       IDP  = IDPR
26284       IF (MCGENE.NE.3) THEN
26285 * lepton-projectiles and PHOJET: initialize real photon instead
26286          IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26287      &       (IDPR.EQ.10).OR.(IDPR.EQ.11).OR.
26288      &       (IDPR.EQ. 5).OR.(IDPR.EQ. 6))   THEN
26289             IDP = 7
26290             Q2  = ZERO
26291          ENDIF
26292       ENDIF
26293       IDT  = IDTA
26294       EPN  = EPN0
26295       PPN  = PPN0
26296       ECM  = ECM0
26297       AMP  = AAM(IDP)-SQRT(ABS(Q2))
26298       AMT  = AAM(IDT)
26299       AMP2 = SIGN(AMP**2,AMP)
26300       AMT2 = AMT**2
26301       IF (ECM0.GT.ZERO) THEN
26302          EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT)
26303          IF (AMP2.GT.ZERO) THEN
26304             PPN = SQRT((EPN+AMP)*(EPN-AMP))
26305          ELSE
26306             PPN = SQRT(EPN**2-AMP2)
26307          ENDIF
26308       ELSE
26309          IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26310             IF (IDP.EQ.7) EPN = ABS(EPN)
26311             IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP
26312             IF (AMP2.GT.ZERO) THEN
26313                PPN = SQRT((EPN+AMP)*(EPN-AMP))
26314             ELSE
26315                PPN = SQRT(EPN**2-AMP2)
26316             ENDIF
26317          ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26318             IF (AMP2.GT.ZERO) THEN
26319                EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
26320             ELSE
26321                EPN = SQRT(PPN**2+AMP2)
26322             ENDIF
26323          ENDIF
26324          ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
26325       ENDIF
26326       UMO   = ECM
26327       EPROJ = EPN
26328       PPROJ = PPN
26329       IF (AMP2.GT.ZERO) THEN
26330          ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
26331          PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
26332       ELSE
26333          ETARG = TINY10
26334          PTARG = TINY10
26335       ENDIF
26336 * photon-projectiles (get momentum in cm-frame for virtuality Q^2)
26337       IF (IDP.EQ.7) THEN
26338          PGAMM(1) = ZERO
26339          PGAMM(2) = ZERO
26340          AMGAM  = AMP
26341          AMGAM2 = AMP2
26342          IF (ECM0.GT.ZERO) THEN
26343             S = ECM0**2
26344          ELSE
26345             IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26346                S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0)
26347             ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26348                S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2)
26349             ENDIF
26350          ENDIF
26351          PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2
26352      &                     +AMGAM2**2+AMT2**2)/(4.0D0*S) )
26353          PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2)
26354          IF (MODE.EQ.1) THEN
26355             PNUCL(1) = ZERO
26356             PNUCL(2) = ZERO
26357             PNUCL(3) = -PGAMM(3)
26358             PNUCL(4) = SQRT(S)-PGAMM(4)
26359          ENDIF
26360       ENDIF
26361       IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26362      &    (IDPR.EQ.10).OR.(IDPR.EQ.11))   THEN
26363          PLEPT0(1) = ZERO
26364          PLEPT0(2) = ZERO
26365 * neglect lepton masses
26366 C        AMLPT2   = AAM(IDPR)**2
26367          AMLPT2   = ZERO
26368 *
26369          IF (ECM0.GT.ZERO) THEN
26370             S = ECM0**2
26371          ELSE
26372             IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26373                S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0)
26374             ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26375                S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2)
26376             ENDIF
26377          ENDIF
26378          PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2
26379      &                     +AMLPT2**2+AMT2**2)/(4.0D0*S) )
26380          PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2)
26381          PNUCL(1) = ZERO
26382          PNUCL(2) = ZERO
26383          PNUCL(3) = -PLEPT0(3)
26384          PNUCL(4) = SQRT(S)-PLEPT0(4)
26385       ENDIF
26386 * Lorentz-parameter for transformation Lab. - projectile rest system
26387       IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
26388          GALAB = TINY10
26389          BGLAB = TINY10
26390          BLAB  = TINY10
26391       ELSE
26392          GALAB = EPROJ/AMP
26393          BGLAB = PPROJ/AMP
26394          BLAB  = BGLAB/GALAB
26395       ENDIF
26396 * Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
26397       IF (IDP.EQ.7) THEN
26398          GACMS(1) = TINY10
26399          BGCMS(1) = TINY10
26400       ELSE
26401          GACMS(1) = (ETARG+AMP)/UMO
26402          BGCMS(1) = PTARG/UMO
26403       ENDIF
26404 * Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
26405       GACMS(2) = (EPROJ+AMT)/UMO
26406       BGCMS(2) = PPROJ/UMO
26407       PPCM     = GACMS(2)*PPROJ-BGCMS(2)*EPROJ
26408
26409       EPN0 = EPN
26410       PPN0 = PPN
26411       ECM0 = ECM
26412
26413       RETURN
26414       END
26415
26416 *$ CREATE DT_LTRANS.FOR
26417 *COPY DT_LTRANS
26418 *
26419 *===ltrans=============================================================*
26420 *
26421       SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
26422
26423 ************************************************************************
26424 * Lorentz-transformations.                                             *
26425 *   MODE = 1(-1)    projectile rest syst.   --> Lab (back)             *
26426 *        = 2(-2)    projectile rest syst.   --> nucl.-nucl.cms (back)  *
26427 *        = 3(-3)    target rest syst. (=Lab)--> nucl.-nucl.cms (back)  *
26428 * This version dated 01.11.95 is written by  S. Roesler.               *
26429 ************************************************************************
26430
26431       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26432       SAVE
26433       PARAMETER ( LINP = 10 ,
26434      &            LOUT = 6 ,
26435      &            LDAT = 9 )
26436       PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
26437
26438       PARAMETER (SQTINF=1.0D+15)
26439
26440 * particle properties (BAMJET index convention)
26441       CHARACTER*8  ANAME
26442       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26443      &                IICH(210),IIBAR(210),K1(210),K2(210)
26444
26445       PXO = PXI
26446       PYO = PYI
26447       CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
26448
26449 * check particle mass for consistency (numerical rounding errors)
26450       PO     = SQRT(PXO*PXO+PYO*PYO+PZO*PZO)
26451       AMO2   = (PEO-PO)*(PEO+PO)
26452       AMORQ2 = AAM(ID)**2
26453       AMDIF2 = ABS(AMO2-AMORQ2)
26454       IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN
26455          DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO))
26456          PEO   = PEO+DELTA
26457          PO1   = PO -DELTA
26458          PXO   = PXO*PO1/PO
26459          PYO   = PYO*PO1/PO
26460          PZO   = PZO*PO1/PO
26461 C        WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
26462       ENDIF
26463
26464       RETURN
26465       END
26466
26467 *$ CREATE DT_LTNUC.FOR
26468 *COPY DT_LTNUC
26469 *
26470 *===ltnuc==============================================================*
26471 *
26472       SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
26473
26474 ************************************************************************
26475 * Lorentz-transformations.                                             *
26476 *   PIN        longitudnal momentum       (input)                      *
26477 *   EIN        energy                     (input)                      *
26478 *   POUT       transformed long. momentum (output)                     *
26479 *   EOUT       transformed energy         (output)                     *
26480 *   MODE = 1(-1)    projectile rest syst.   --> Lab (back)             *
26481 *        = 2(-2)    projectile rest syst.   --> nucl.-nucl.cms (back)  *
26482 *        = 3(-3)    target rest syst. (=Lab)--> nucl.-nucl.cms (back)  *
26483 * This version dated 01.11.95 is written by  S. Roesler.               *
26484 ************************************************************************
26485
26486       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26487       SAVE
26488       PARAMETER ( LINP = 10 ,
26489      &            LOUT = 6 ,
26490      &            LDAT = 9 )
26491       PARAMETER (ZERO=0.0D0)
26492
26493 * Lorentz-parameters of the current interaction
26494       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26495      &                UMO,PPCM,EPROJ,PPROJ
26496
26497       BDUM1 = ZERO
26498       BDUM2 = ZERO
26499       PDUM1 = ZERO
26500       PDUM2 = ZERO
26501       IF (ABS(MODE).EQ.1) THEN
26502          BG = -SIGN(BGLAB,DBLE(MODE))
26503          CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN,
26504      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26505       ELSEIF (ABS(MODE).EQ.2) THEN
26506          BG = SIGN(BGCMS(1),DBLE(MODE))
26507          CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26508      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26509       ELSEIF (ABS(MODE).EQ.3) THEN
26510          BG = -SIGN(BGCMS(2),DBLE(MODE))
26511          CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26512      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26513       ELSE
26514          WRITE(LOUT,1000) MODE
26515  1000    FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
26516          EOUT = EIN
26517          POUT = PIN
26518       ENDIF
26519
26520       RETURN
26521       END
26522
26523 *$ CREATE DT_DALTRA.FOR
26524 *COPY DT_DALTRA
26525 *
26526 *===daltra=============================================================*
26527 *
26528       SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
26529
26530 ************************************************************************
26531 * Arbitrary Lorentz-transformation.                                    *
26532 * Adopted from the original by S. Roesler. This version dated 15.01.95 *
26533 ************************************************************************
26534
26535       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26536       SAVE
26537       PARAMETER (ONE=1.0D0)
26538
26539       EP = PCX*BGX+PCY*BGY+PCZ*BGZ
26540       PE = EP/(GA+ONE)+EC
26541       PX = PCX+BGX*PE
26542       PY = PCY+BGY*PE
26543       PZ = PCZ+BGZ*PE
26544       P  = SQRT(PX*PX+PY*PY+PZ*PZ)
26545       E  = GA*EC+EP
26546
26547       RETURN
26548       END
26549
26550 *$ CREATE DT_DTRAFO.FOR
26551 *COPY DT_DTRAFO
26552 *
26553 *====dtrafo============================================================*
26554 *
26555       SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
26556      &                                    PL,CXL,CYL,CZL,EL)
26557
26558 C     LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
26559
26560       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26561       SAVE
26562
26563       IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
26564       SID  = SQRT(1.D0-COD*COD)
26565       PLX  = P*SID*COF
26566       PLY  = P*SID*SIF
26567       PCMZ = P*COD
26568       PLZ  = GAM*PCMZ+BGAM*ECM
26569       PL   = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
26570       EL   = GAM*ECM+BGAM*PCMZ
26571 C     ROTATION INTO THE ORIGINAL DIRECTION
26572       COZ  = PLZ/PL
26573       SIZ  = SQRT(1.D0-COZ**2)
26574       CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
26575
26576       RETURN
26577       END
26578
26579 *$ CREATE DT_STTRAN.FOR
26580 *COPY DT_STTRAN
26581 *
26582 *====sttran============================================================*
26583 *
26584       SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
26585
26586       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26587       SAVE
26588       DATA ANGLSQ/1.D-30/
26589 ************************************************************************
26590 *     VERSION BY                     J. RANFT                          *
26591 *                                    LEIPZIG                           *
26592 *                                                                      *
26593 *     THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES      *
26594 *                                                                      *
26595 *     INPUT VARIABLES:                                                 *
26596 *        XO,YO,ZO = ORIGINAL DIRECTION COSINES                         *
26597 *        CDE,SDE  = COSINE AND SINE OF THE POLAR (THETA)               *
26598 *                   ANGLE OF "SCATTERING"                              *
26599 *        SDE      = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING"    *
26600 *        SFE,CFE  = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE       *
26601 *                   OF "SCATTERING"                                    *
26602 *                                                                      *
26603 *     OUTPUT VARIABLES:                                                *
26604 *        X,Y,Z     = NEW DIRECTION COSINES                             *
26605 *                                                                      *
26606 *     ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 )                  *
26607 ************************************************************************
26608 *
26609 *
26610 *  Changed by A. Ferrari
26611 *
26612 *     IF (ABS(XO)-0.0001D0) 1,1,2
26613 *   1 IF (ABS(YO)-0.0001D0) 3,3,2
26614 *   3 CONTINUE
26615       A = XO**2 + YO**2
26616       IF ( A .LT. ANGLSQ ) THEN
26617          X=SDE*CFE
26618          Y=SDE*SFE
26619          Z=CDE*ZO
26620       ELSE
26621          XI=SDE*CFE
26622          YI=SDE*SFE
26623          ZI=CDE
26624          A=SQRT(A)
26625          X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
26626          Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
26627          Z=A*YI+ZO*ZI
26628       ENDIF
26629
26630       RETURN
26631       END
26632
26633 *$ CREATE DT_MYTRAN.FOR
26634 *COPY DT_MYTRAN
26635 *
26636 *===mytran=============================================================*
26637 *
26638       SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
26639
26640 ************************************************************************
26641 * This subroutine rotates the coordinate frame                         *
26642 *    a) theta  around y                                                *
26643 *    b) phi    around z      if IMODE = 1                              *
26644 *                                                                      *
26645 *     x'          cos(ph) -sin(ph) 0      cos(th)  0  sin(th)   x      *
26646 *     y' = A B =  sin(ph) cos(ph)  0  .   0        1        0   y      *
26647 *     z'          0       0        1     -sin(th)  0  cos(th)   z      *
26648 *                                                                      *
26649 * and vice versa if IMODE = 0.                                         *
26650 * This version dated 5.4.94 is based on the original version DTRAN     *
26651 * by J. Ranft and is written by S. Roesler.                            *
26652 ************************************************************************
26653
26654       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26655       SAVE
26656       PARAMETER ( LINP = 10 ,
26657      &            LOUT = 6 ,
26658      &            LDAT = 9 )
26659
26660       IF (IMODE.EQ.1) THEN
26661          X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
26662          Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
26663          Z=-SDE    *XO       +CDE    *ZO
26664       ELSE
26665          X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
26666          Y= -SFE*XO+CFE*YO
26667          Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
26668       ENDIF
26669       RETURN
26670       END
26671
26672 *$ CREATE DT_LT2LAO.FOR
26673 *COPY DT_LT2LAO
26674 *
26675 *===lt2lab=============================================================*
26676 *
26677       SUBROUTINE DT_LT2LAO
26678
26679 ************************************************************************
26680 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1   *
26681 * for final state particles/fragments defined in nucleon-nucleon-cms   *
26682 * and transforms them back to the lab.                                 *
26683 * This version dated 16.11.95 is written by S. Roesler                 *
26684 ************************************************************************
26685
26686       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26687       SAVE
26688       PARAMETER ( LINP = 10 ,
26689      &            LOUT = 6 ,
26690      &            LDAT = 9 )
26691
26692 * event history
26693       PARAMETER (NMXHKK=200000)
26694       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26695      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26696      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26697 * extended event history
26698       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26699      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26700      &                IHIST(2,NMXHKK)
26701
26702       NEND      = NHKK
26703       NPOINT(5) = NHKK+1
26704       IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
26705       DO 1 I=NPOINT(4),NEND
26706 C     DO 1 I=1,NEND
26707          IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26708      &                                (ISTHKK(I).EQ.1001)) THEN
26709             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26710             NOB = NOBAM(I)
26711             CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I),
26712      &                            PZ,PE,IDRES(I),IDXRES(I),IDCH(I))
26713             IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN
26714                ISTHKK(I) = 3*ISTHKK(I)
26715                NOBAM(NHKK)  = NOB
26716             ELSE
26717                IF (ISTHKK(I).EQ.-1) NOBAM(NHKK)  = NOB
26718                ISTHKK(I) = SIGN(3,ISTHKK(I))
26719             ENDIF
26720             JDAHKK(1,I) = NHKK
26721          ENDIF
26722     1 CONTINUE
26723
26724       RETURN
26725       END
26726
26727 *$ CREATE DT_LT2LAB.FOR
26728 *COPY DT_LT2LAB
26729 *
26730 *===lt2lab=============================================================*
26731 *
26732       SUBROUTINE DT_LT2LAB
26733
26734 ************************************************************************
26735 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1   *
26736 * for final state particles/fragments defined in nucleon-nucleon-cms   *
26737 * and transforms them to the lab.                                      *
26738 * This version dated 07.01.96 is written by S. Roesler                 *
26739 ************************************************************************
26740
26741       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26742       SAVE
26743       PARAMETER ( LINP = 10 ,
26744      &            LOUT = 6 ,
26745      &            LDAT = 9 )
26746
26747 * event history
26748       PARAMETER (NMXHKK=200000)
26749       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26750      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26751      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26752 * extended event history
26753       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26754      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26755      &                IHIST(2,NMXHKK)
26756
26757       IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
26758       DO 1 I=NPOINT(4),NHKK
26759          IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26760      &                                (ISTHKK(I).EQ.1001)) THEN
26761             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26762             PHKK(3,I) = PZ
26763             PHKK(4,I) = PE
26764          ENDIF
26765     1 CONTINUE
26766
26767       RETURN
26768       END
26769
26770 ************************************************************************
26771 *                                                                      *
26772 *                 5) Sampling from distributions                       *
26773 *                                                                      *
26774 ************************************************************************
26775 *$ CREATE IDT_NPOISS.FOR
26776 *COPY IDT_NPOISS
26777 *
26778 *===npoiss=============================================================*
26779 *
26780       INTEGER FUNCTION IDT_NPOISS(AVN)
26781
26782 ************************************************************************
26783 * Sample according to Poisson distribution with Poisson parameter AVN. *
26784 * The original version written by J. Ranft.                            *
26785 * This version dated 11.1.95 is written by S. Roesler.                 *
26786 ************************************************************************
26787
26788       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26789       SAVE
26790       PARAMETER ( LINP = 10 ,
26791      &            LOUT = 6 ,
26792      &            LDAT = 9 )
26793
26794       EXPAVN = EXP(-AVN)
26795       K = 1
26796       A = 1.0D0
26797
26798    10 CONTINUE
26799       A = DT_RNDM(A)*A
26800       IF (A.GE.EXPAVN) THEN
26801          K = K+1
26802          GOTO 10
26803       ENDIF
26804       IDT_NPOISS = K-1
26805
26806       RETURN
26807       END
26808
26809 *$ CREATE DT_SAMPXB.FOR
26810 *COPY DT_SAMPXB
26811 *
26812 *===sampxb=============================================================*
26813 *
26814       DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
26815
26816 ************************************************************************
26817 * Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2.             *
26818 * Processed by S. Roesler, 6.5.95                                      *
26819 ************************************************************************
26820
26821       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26822       SAVE
26823       PARAMETER (TWO=2.0D0)
26824
26825       A1 = LOG(X1+SQRT(X1**2+B**2))
26826       A2 = LOG(X2+SQRT(X2**2+B**2))
26827       AN = A2-A1
26828       A  = AN*DT_RNDM(A1)+A1
26829       BB = EXP(A)
26830       DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
26831
26832       RETURN
26833       END
26834
26835 *$ CREATE DT_SAMPEX.FOR
26836 *COPY DT_SAMPEX
26837 *
26838 *===sampex=============================================================*
26839 *
26840       DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
26841
26842 ************************************************************************
26843 * Sampling from f(x)=1./x 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 (ONE=1.0D0)
26850
26851       R   = DT_RNDM(X1)
26852       AL1 = LOG(X1)
26853       AL2 = LOG(X2)
26854       DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
26855
26856       RETURN
26857       END
26858
26859 *$ CREATE DT_SAMSQX.FOR
26860 *COPY DT_SAMSQX
26861 *
26862 *===samsqx=============================================================*
26863 *
26864       DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
26865
26866 ************************************************************************
26867 * Sampling from f(x)=1./x^0.5 between x1 and x2.                       *
26868 * Processed by S. Roesler, 6.5.95                                      *
26869 ************************************************************************
26870
26871       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26872       SAVE
26873       PARAMETER (ONE=1.0D0)
26874
26875       R = DT_RNDM(X1)
26876       DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
26877
26878       RETURN
26879       END
26880
26881 *$ CREATE DT_SAMPLW.FOR
26882 *COPY DT_SAMPLW
26883 *
26884 *===samplw=============================================================*
26885 *
26886       DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
26887
26888 ************************************************************************
26889 * Sampling from f(x)=1/x^b between x_min and x_max.                    *
26890 * S. Roesler, 18.4.98                                                  *
26891 ************************************************************************
26892
26893       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26894       SAVE
26895       PARAMETER (ONE=1.0D0)
26896
26897       R = DT_RNDM(B)
26898       IF (B.EQ.ONE) THEN
26899          DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
26900       ELSE
26901          ONEMB  = ONE-B
26902          DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
26903       ENDIF
26904
26905       RETURN
26906       END
26907
26908 *$ CREATE DT_BETREJ.FOR
26909 *COPY DT_BETREJ
26910 *
26911 *===betrej=============================================================*
26912 *
26913       DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
26914
26915       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26916       SAVE
26917
26918       PARAMETER ( LINP = 10 ,
26919      &            LOUT = 6 ,
26920      &            LDAT = 9 )
26921       PARAMETER (ONE=1.0D0)
26922
26923       IF (XMIN.GE.XMAX)THEN
26924          WRITE (LOUT,500) XMIN,XMAX
26925   500    FORMAT(1X,'DT_BETREJ:  XMIN<XMAX execution stopped ',2F10.5)
26926          STOP
26927       ENDIF
26928
26929    10 CONTINUE
26930       XX     = XMIN+(XMAX-XMIN)*DT_RNDM(ETA)
26931       BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE)
26932       YY     = BETMAX*DT_RNDM(XX)
26933       BETXX  = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE)
26934       IF (YY.GT.BETXX) GOTO 10
26935       DT_BETREJ = XX
26936
26937       RETURN
26938       END
26939
26940 *$ CREATE DT_DGAMRN.FOR
26941 *COPY DT_DGAMRN
26942 *
26943 *===dgamrn=============================================================*
26944 *
26945       DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
26946
26947 ************************************************************************
26948 * Sampling from Gamma-distribution.                                    *
26949 *       F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)            *
26950 * Processed by S. Roesler, 6.5.95                                      *
26951 ************************************************************************
26952
26953       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26954       SAVE
26955       PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
26956
26957       NCOU = 0
26958       N    = INT(ETA)
26959       F    = ETA-DBLE(N)
26960       IF (F.EQ.ZERO) GOTO 20
26961    10 R = DT_RNDM(F)
26962       NCOU = NCOU+1
26963       IF (NCOU.GE.11) GOTO 20
26964       IF (R.LT.F/(F+2.71828D0)) GOTO 30
26965       YYY = LOG(DT_RNDM(R)+TINY9)/F
26966       IF (ABS(YYY).GT.50.0D0) GOTO 20
26967       Y = EXP(YYY)
26968       IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
26969       GOTO 40
26970    20 Y = 0.0D0
26971       GOTO 50
26972    30 Y = ONE-LOG(DT_RNDM(Y)+TINY9)
26973       IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10
26974    40 IF (N.EQ.0) GOTO 70
26975    50 Z = 1.0D0
26976       DO 60 I = 1,N
26977    60 Z = Z*DT_RNDM(Z)
26978       Y = Y-LOG(Z+TINY9)
26979    70 DT_DGAMRN = Y/ALAM
26980
26981       RETURN
26982       END
26983
26984 *$ CREATE DT_DBETAR.FOR
26985 *COPY DT_DBETAR
26986 *
26987 *===dbetar=============================================================*
26988 *
26989       DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
26990
26991 ************************************************************************
26992 * Sampling from Beta -distribution between 0.0 and 1.0                 *
26993 *  F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
26994 * Processed by S. Roesler, 6.5.95                                      *
26995 ************************************************************************
26996
26997       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26998       SAVE
26999
27000       Y = DT_DGAMRN(1.0D0,GAM)
27001       Z = DT_DGAMRN(1.0D0,ETA)
27002       DT_DBETAR = Y/(Y+Z)
27003
27004       RETURN
27005       END
27006
27007 *$ CREATE DT_RANNOR.FOR
27008 *COPY DT_RANNOR
27009 *
27010 *===rannor=============================================================*
27011 *
27012       SUBROUTINE DT_RANNOR(X,Y)
27013
27014 ************************************************************************
27015 * Sampling from Gaussian distribution.                                 *
27016 * Processed by S. Roesler, 6.5.95                                      *
27017 ************************************************************************
27018
27019       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27020       SAVE
27021       PARAMETER (TINY10=1.0D-10)
27022
27023       CALL DT_DSFECF(SFE,CFE)
27024       V = MAX(TINY10,DT_RNDM(X))
27025       A = SQRT(-2.D0*LOG(V))
27026       X = A*SFE
27027       Y = A*CFE
27028
27029       RETURN
27030       END
27031
27032 *$ CREATE DT_DPOLI.FOR
27033 *COPY DT_DPOLI
27034 *
27035 *===dpoli==============================================================*
27036 *
27037       SUBROUTINE DT_DPOLI(CS,SI)
27038
27039       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27040       SAVE
27041
27042       U  = DT_RNDM(CS)
27043       CS = DT_RNDM(U)
27044       IF (U.LT.0.5D0) CS=-CS
27045       SI = SQRT(1.0D0-CS*CS+1.0D-10)
27046
27047       RETURN
27048       END
27049
27050 *$ CREATE DT_DSFECF.FOR
27051 *COPY DT_DSFECF
27052 *
27053 *===dsfecf=============================================================*
27054 *
27055       SUBROUTINE DT_DSFECF(SFE,CFE)
27056
27057       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27058       SAVE
27059       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
27060
27061     1 CONTINUE
27062       X  = DT_RNDM(SFE)
27063       Y  = DT_RNDM(X)
27064       XX = X*X
27065       YY = Y*Y
27066       XY = XX+YY
27067       IF (XY.GT.ONE) GOTO 1
27068       CFE = (XX-YY)/XY
27069       SFE = TWO*X*Y/XY
27070       IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
27071       RETURN
27072       END
27073
27074 *$ CREATE DT_RACO.FOR
27075 *COPY DT_RACO
27076 *
27077 *===raco===============================================================*
27078 *
27079       SUBROUTINE DT_RACO(WX,WY,WZ)
27080
27081 ************************************************************************
27082 * Direction cosines of random uniform (isotropic) direction in three   *
27083 * dimensional space                                                    *
27084 * Processed by S. Roesler, 20.11.95                                    *
27085 ************************************************************************
27086
27087       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27088       SAVE
27089       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
27090
27091   10  CONTINUE
27092       X  = TWO*DT_RNDM(WX)-ONE
27093       Y  = DT_RNDM(X)
27094       X2 = X*X
27095       Y2 = Y*Y
27096       IF (X2+Y2.GT.ONE) GOTO 10
27097
27098       CFE = (X2-Y2)/(X2+Y2)
27099       SFE = TWO*X*Y/(X2+Y2)
27100 * z = 1/2 [ 1 + cos (theta) ]
27101       Z   = DT_RNDM(X)
27102 * 1/2 sin (theta)
27103       WZ = SQRT(Z*(ONE-Z))
27104       WX = TWO*WZ*CFE
27105       WY = TWO*WZ*SFE
27106       WZ = TWO*Z-ONE
27107
27108       RETURN
27109       END
27110
27111 ************************************************************************
27112 *                                                                      *
27113 *           6) Special functions, algorithms and service routines      *
27114 *                                                                      *
27115 ************************************************************************
27116 *$ CREATE DT_YLAMB.FOR
27117 *COPY DT_YLAMB
27118 *
27119 *===ylamb==============================================================*
27120 *
27121       DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
27122
27123 ************************************************************************
27124 *                                                                      *
27125 *     auxiliary function for three particle decay mode                 *
27126 *     (standard LAMBDA**(1/2) function)                                *
27127 *                                                                      *
27128 * Adopted from an original version written by R. Engel.                *
27129 * This version dated 12.12.94 is written by S. Roesler.                *
27130 ************************************************************************
27131
27132       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27133       SAVE
27134
27135       YZ   = Y-Z
27136       XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ
27137       IF (XLAM.LE.0.D0) XLAM = ABS(XLAM)
27138       DT_YLAMB = SQRT(XLAM)
27139
27140       RETURN
27141       END
27142
27143 *$ CREATE DT_SORT.FOR
27144 *COPY DT_SORT
27145 *
27146 *===sort1==============================================================*
27147 *
27148       SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
27149
27150 ************************************************************************
27151 * This subroutine sorts entries in A in increasing/decreasing order    *
27152 * of A(3,i).                                                           *
27153 *              MODE  = 1     increasing in A(3,i=1..N)                 *
27154 *                    = 2     decreasing in A(3,i=1..N)                 *
27155 * This version dated 21.04.95 is revised by S. Roesler                 *
27156 ************************************************************************
27157
27158       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27159       SAVE
27160
27161       DIMENSION A(3,N)
27162
27163       M = I1
27164    10 CONTINUE
27165       M = I1-1
27166       IF (M.LE.0) RETURN
27167       L = 0
27168       DO 20 I=I0,M
27169          J = I+1
27170          IF (MODE.EQ.1) THEN
27171             IF (A(3,I).LE.A(3,J)) GOTO 20
27172          ELSE
27173             IF (A(3,I).GE.A(3,J)) GOTO 20
27174          ENDIF
27175          B = A(3,I)
27176          C = A(1,I)
27177          D = A(2,I)
27178          A(3,I) = A(3,J)
27179          A(2,I) = A(2,J)
27180          A(1,I) = A(1,J)
27181          A(3,J) = B
27182          A(1,J) = C
27183          A(2,J) = D
27184          L = 1
27185    20 CONTINUE
27186       IF (L.EQ.1) GOTO 10
27187
27188       RETURN
27189       END
27190
27191 *$ CREATE DT_SORT1.FOR
27192 *COPY DT_SORT1
27193 *
27194 *===sort1==============================================================*
27195 *
27196       SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
27197
27198 ************************************************************************
27199 * This subroutine sorts entries in A in increasing/decreasing order    *
27200 * of A(i).                                                             *
27201 *              MODE  = 1     increasing in A(i=1..N)                   *
27202 *                    = 2     decreasing in A(i=1..N)                   *
27203 * This version dated 21.04.95 is revised by S. Roesler                 *
27204 ************************************************************************
27205
27206       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27207       SAVE
27208
27209       DIMENSION A(N),IDX(N)
27210
27211       M = I1
27212    10 CONTINUE
27213       M = I1-1
27214       IF (M.LE.0) RETURN
27215       L = 0
27216       DO 20 I=I0,M
27217          J = I+1
27218          IF (MODE.EQ.1) THEN
27219             IF (A(I).LE.A(J)) GOTO 20
27220          ELSE
27221             IF (A(I).GE.A(J)) GOTO 20
27222          ENDIF
27223          B    = A(I)
27224          A(I) = A(J)
27225          A(J) = B
27226          IX     = IDX(I)
27227          IDX(I) = IDX(J)
27228          IDX(J) = IX
27229          L = 1
27230    20 CONTINUE
27231       IF (L.EQ.1) GOTO 10
27232
27233       RETURN
27234       END
27235
27236 *$ CREATE DT_XTIME.FOR
27237 *COPY DT_XTIME
27238 *
27239 *===xtime==============================================================*
27240 *
27241       SUBROUTINE DT_XTIME
27242
27243       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27244       SAVE
27245       PARAMETER ( LINP = 10 ,
27246      &            LOUT = 6 ,
27247      &            LDAT = 9 )
27248
27249       CHARACTER DAT*9,TIM*11
27250
27251       DAT = '         '
27252       TIM = '           '
27253 C     CALL GETDAT(IYEAR,IMONTH,IDAY)
27254 C     CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
27255
27256 C     CALL DATE(DAT)
27257 C     CALL TIME(TIM)
27258 C     WRITE(LOUT,1000) DAT,TIM
27259  1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
27260
27261       RETURN
27262       END
27263
27264 ************************************************************************
27265 *                                                                      *
27266 *                 7) Random number generator package                   *
27267 *                                                                      *
27268 *    THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND        *
27269 *    SERVICE ROUTINES.                                                 *
27270 *    THE ALGORITHM IS FROM                                             *
27271 *      'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR'                     *
27272 *      G.MARSAGLIA, A.ZAMAN ;  FSU-SCRI-87-50                          *
27273 *    IMPLEMENTATION BY K. HAHN  DEC. 88,                               *
27274 *    THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS *
27275 *    AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ),        *
27276 *    THE PERIOD IS ABOUT 2**144,                                       *
27277 *    TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS,            *
27278 *    THE PACKAGE CONTAINS                                              *
27279 *      FUNCTION DT_RNDM(I)                  : GENERATOR                *
27280 *      SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION           *
27281 *      SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J)  : PUT SEED TO GENERATOR    *
27282 *      SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J)  : TAKE SEED FROM GENERATOR *
27283 *      SUBROUTINE DT_RNDMTE(IO)             : TEST OF GENERATOR        *
27284 *---                                                                   *
27285 *    FUNCTION DT_RNDM(I)                                               *
27286 *       GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS  IN (0..1)          *
27287 *       I  - DUMMY VARIABLE, NOT USED                                  *
27288 *    SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)                             *
27289 *       INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM *
27290 *       NA1,NA2,NA3,NB1  - VALUES FOR INITIALIZING THE GENERATOR       *
27291 *                          NA? MUST BE IN 1..178 AND NOT ALL 1         *
27292 *                          12,34,56  ARE THE STANDARD VALUES           *
27293 *                          NB1 MUST BE IN 1..168                       *
27294 *                          78  IS THE STANDARD VALUE                   *
27295 *    SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J)                               *
27296 *       PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS   *
27297 *       AS AFTER THE LAST DT_RNDMOU CALL )                             *
27298 *       U(97),C,CD,CM,I,J  - SEED VALUES AS TAKEN FROM DT_RNDMOU       *
27299 *    SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J)                               *
27300 *       TAKES SEED FROM GENERATOR                                      *
27301 *       U(97),C,CD,CM,I,J  - SEED VALUES                               *
27302 *    SUBROUTINE DT_RNDMTE(IO)                                          *
27303 *       TEST OF THE GENERATOR                                          *
27304 *       IO     - DEFINES OUTPUT                                        *
27305 *                  = 0  OUTPUT ONLY IF AN ERROR IS DETECTED            *
27306 *                  = 1  OUTPUT INDEPENDEND ON AN ERROR                 *
27307 *       DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO   *
27308 *       SAME STATUS                                                    *
27309 *       AS BEFORE CALL OF DT_RNDMTE                                    *
27310 ************************************************************************
27311 *$ CREATE DT_RNDM.FOR
27312 *COPY DT_RNDM
27313 *
27314 c$$$*===rndm===============================================================*
27315 c$$$*
27316 c$$$      DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
27317 c$$$
27318 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27319 c$$$      SAVE
27320 c$$$
27321 c$$$* random number generator
27322 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27323 c$$$
27324 c$$$* counter of calls to random number generator
27325 c$$$* uncomment if needed
27326 c$$$C     COMMON /DTRNCT/ IRNCT0,IRNCT1
27327 c$$$C     LOGICAL LFIRST
27328 c$$$C     DATA LFIRST /.TRUE./
27329 c$$$
27330 c$$$* counter of calls to random number generator
27331 c$$$* uncomment if needed
27332 c$$$C     IF (LFIRST) THEN
27333 c$$$C        IRNCT0 = 0
27334 c$$$C        IRNCT1 = 0
27335 c$$$C        LFIRST = .FALSE.
27336 c$$$C     ENDIF
27337 c$$$ 100  CONTINUE
27338 c$$$      DT_RNDM = U(I)-U(J)
27339 c$$$      IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0
27340 c$$$      U(I) = DT_RNDM
27341 c$$$      I    = I-1
27342 c$$$      IF ( I.EQ.0 ) I = 97
27343 c$$$      J    = J-1
27344 c$$$      IF ( J.EQ.0 ) J = 97
27345 c$$$      C    = C-CD
27346 c$$$      IF ( C.LT.0.0D0 ) C = C+CM
27347 c$$$      DT_RNDM = DT_RNDM-C
27348 c$$$      IF ( DT_RNDM.LT.0.0D0 ) DT_RNDM = DT_RNDM+1.0D0
27349 c$$$
27350 c$$$      IF ((DT_RNDM.EQ.0.D0).OR.(DT_RNDM.EQ.1.D0)) GOTO 100
27351 c$$$
27352 c$$$* counter of calls to random number generator
27353 c$$$* uncomment if needed
27354 c$$$C     IRNCT0 = IRNCT0+1
27355 c$$$
27356 c$$$      RETURN
27357 c$$$      END
27358 c$$$
27359 c$$$*$ CREATE DT_RNDMST.FOR
27360 c$$$*COPY DT_RNDMST
27361 c$$$*
27362 c$$$*===rndmst=============================================================*
27363 c$$$*
27364 c$$$      SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
27365 c$$$
27366 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27367 c$$$      SAVE
27368 c$$$
27369 c$$$* random number generator
27370 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27371 c$$$
27372 c$$$      MA1 = NA1
27373 c$$$      MA2 = NA2
27374 c$$$      MA3 = NA3
27375 c$$$      MB1 = NB1
27376 c$$$      I   = 97
27377 c$$$      J   = 33
27378 c$$$      DO 20 II2 = 1,97
27379 c$$$        S = 0
27380 c$$$        T = 0.5D0
27381 c$$$        DO 10 II1 = 1,24
27382 c$$$          MAT  = MOD(MOD(MA1*MA2,179)*MA3,179)
27383 c$$$          MA1  = MA2
27384 c$$$          MA2  = MA3
27385 c$$$          MA3  = MAT
27386 c$$$          MB1  = MOD(53*MB1+1,169)
27387 c$$$          IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
27388 c$$$   10   T = 0.5D0*T
27389 c$$$   20 U(II2) = S
27390 c$$$      C  =   362436.0D0/16777216.0D0
27391 c$$$      CD =  7654321.0D0/16777216.0D0
27392 c$$$      CM = 16777213.0D0/16777216.0D0
27393 c$$$      RETURN
27394 c$$$      END
27395 c$$$
27396 c$$$*$ CREATE DT_RNDMIN.FOR
27397 c$$$*COPY DT_RNDMIN
27398 c$$$*
27399 c$$$*===rndmin=============================================================*
27400 c$$$*
27401 c$$$      SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
27402 c$$$
27403 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27404 c$$$      SAVE
27405 c$$$
27406 c$$$* random number generator
27407 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27408 c$$$
27409 c$$$      DIMENSION UIN(97)
27410 c$$$
27411 c$$$      DO 10 KKK = 1,97
27412 c$$$   10 U(KKK) = UIN(KKK)
27413 c$$$      C  = CIN
27414 c$$$      CD = CDIN
27415 c$$$      CM = CMIN
27416 c$$$      I  = IIN
27417 c$$$      J  = JIN
27418 c$$$
27419 c$$$      RETURN
27420 c$$$      END
27421 c$$$
27422 c$$$*$ CREATE DT_RNDMOU.FOR
27423 c$$$*COPY DT_RNDMOU
27424 c$$$*
27425 c$$$*===rndmou=============================================================*
27426 c$$$*
27427 c$$$      SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
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 UOUT(97)
27436 c$$$
27437 c$$$      DO 10 KKK = 1,97
27438 c$$$   10 UOUT(KKK) = U(KKK)
27439 c$$$      COUT  = C
27440 c$$$      CDOUT = CD
27441 c$$$      CMOUT = CM
27442 c$$$      IOUT  = I
27443 c$$$      JOUT  = J
27444 c$$$
27445 c$$$      RETURN
27446 c$$$      END
27447 c$$$
27448 c$$$*$ CREATE DT_RNDMTE.FOR
27449 c$$$*COPY DT_RNDMTE
27450 c$$$*
27451 c$$$*===rndmte=============================================================*
27452 c$$$*
27453 c$$$      SUBROUTINE DT_RNDMTE(IO)
27454 c$$$
27455 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27456 c$$$      SAVE
27457 c$$$
27458 c$$$      DIMENSION UU(97),U(6),X(6),D(6)
27459 c$$$      DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0,
27460 c$$$     +8354498.D0, 10633180.D0/
27461 c$$$
27462 c$$$      CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ)
27463 c$$$      CALL DT_RNDMST(12,34,56,78)
27464 c$$$      DO 10 II1 = 1,20000
27465 c$$$   10 XX = DT_RNDM(XX)
27466 c$$$      SD        = 0.0D0
27467 c$$$      DO 20 II2 = 1,6
27468 c$$$        X(II2)  = 4096.D0*(4096.D0*DT_RNDM(SD))
27469 c$$$        D(II2)  = X(II2)-U(II2)
27470 c$$$   20 SD = SD+D(II2)
27471 c$$$      CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
27472 c$$$**sr 24.01.95
27473 c$$$C     IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6)
27474 c$$$      IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN
27475 c$$$C        WRITE(6,1000)
27476 c$$$ 1000    FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
27477 c$$$     &          ' passed')
27478 c$$$      ENDIF
27479 c$$$**
27480 c$$$      RETURN
27481 c$$$  500 FORMAT('  === TEST OF THE RANDOM-GENERATOR ===',/,
27482 c$$$     &'    EXPECTED VALUE    CALCULATED VALUE     DIFFERENCE',/, 6(F17.
27483 c$$$     &1,F20.1,F15.3,/), '  === END OF TEST ;',
27484 c$$$     &'  GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE')
27485 c$$$      END
27486 *
27487 *$ CREATE PHO_RNDM.FOR
27488 *COPY PHO_RNDM
27489 *
27490 *===pho_rndm===========================================================*
27491 *
27492       DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
27493
27494       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27495       SAVE
27496
27497       PHO_RNDM = DT_RNDM(DUMMY)
27498
27499       RETURN
27500       END
27501
27502 *$ CREATE PYR.FOR
27503 *COPY PYR
27504 *
27505 *===pyr================================================================*
27506 *
27507       DOUBLE PRECISION FUNCTION PYR(IDUMMY)
27508
27509       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27510       SAVE
27511
27512       DUMMY = DBLE(IDUMMY)
27513       PYR = DT_RNDM(DUMMY)
27514
27515       RETURN
27516       END
27517
27518 *$ CREATE DT_TITLE.FOR
27519 *COPY DT_TITLE
27520 *
27521 *===title==============================================================*
27522 *
27523       SUBROUTINE DT_TITLE
27524
27525       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27526       SAVE
27527       PARAMETER ( LINP = 10 ,
27528      &            LOUT = 6 ,
27529      &            LDAT = 9 )
27530
27531       CHARACTER*6 CVERSI
27532       CHARACTER*11 CCHANG
27533       DATA CVERSI,CCHANG /'3.0-5 ','08 Jan 2007'/
27534
27535       CALL DT_XTIME
27536       WRITE(LOUT,1000) CVERSI,CCHANG
27537  1000 FORMAT(1X,'+-------------------------------------------------',
27538      &                  '----------------------+',/,
27539      &     1X,'|',71X,'|',/,
27540      &     1X,'|',26X,'DPMJET version ',A6,24X,'|',/,
27541      &     1X,'|',71X,'|',/,
27542      &     1X,'|',22X,'(Last change: ',A11,')',23X,'|',/,
27543      &     1X,'|',71X,'|',/,
27544      &     1X,'|',12X,'Authors: Stefan Roesler   (CERN)',27X,'|',/,
27545      &     1X,'|',21X,'Ralph Engel      (FZ Karlsruhe)',19X,'|',/,
27546      &     1X,'|',21X,'Johannes Ranft   (Siegen Univ.)',19X,'|',/,
27547      &     1X,'|',71X,'|',/,
27548      &     1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html',
27549      &                                              17X,'|',/,
27550      &     1X,'|',71X,'|',/,
27551      &     1X,'+-------------------------------------------------',
27552      &                '----------------------+',/,
27553      &     1X,'| Please send suggestions, bug reports, etc. to: ',
27554      &                                  'Stefan.Roesler@cern.ch |',/,
27555      &     1X,'+-------------------------------------------------',
27556      &                '----------------------+',/)
27557
27558       RETURN
27559       END
27560
27561 *$ CREATE DT_EVTINI.FOR
27562 *COPY DT_EVTINI
27563 *
27564 *===evtini=============================================================*
27565 *
27566       SUBROUTINE DT_EVTINI
27567
27568 ************************************************************************
27569 * Initialization of DTEVT1.                                            *
27570 * This version dated 15.01.94 is written by S. Roesler                 *
27571 ************************************************************************
27572
27573       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27574       SAVE
27575       PARAMETER ( LINP = 10 ,
27576      &            LOUT = 6 ,
27577      &            LDAT = 9 )
27578
27579 * event history
27580       PARAMETER (NMXHKK=200000)
27581       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27582      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27583      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27584 * extended event history
27585       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27586      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27587      &                IHIST(2,NMXHKK)
27588 * event flag
27589       COMMON /DTEVNO/ NEVENT,ICASCA
27590       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27591 * emulsion treatment
27592       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
27593      &                NCOMPO,IEMUL
27594
27595 * initialization of DTEVT1/DTEVT2
27596       NEND = NHKK
27597       IF (NEVENT.EQ.1) NEND = NMXHKK
27598       NHKK   = 0
27599       NEVHKK = NEVENT
27600       DO 1 I=1,NEND
27601          ISTHKK(I)   = 0
27602          IDHKK(I)    = 0
27603          JMOHKK(1,I) = 0
27604          JMOHKK(2,I) = 0
27605          JDAHKK(1,I) = 0
27606          JDAHKK(2,I) = 0
27607          IDRES(I)    = 0
27608          IDXRES(I)   = 0
27609          NOBAM(I)    = 0
27610          IDCH(I)     = 0
27611          IHIST(1,I)  = 0
27612          IHIST(2,I)  = 0
27613          DO 2 J=1,4
27614             PHKK(J,I) = 0.0D0
27615             VHKK(J,I) = 0.0D0
27616             WHKK(J,I) = 0.0D0
27617     2    CONTINUE
27618          PHKK(5,I) = 0.0D0
27619     1 CONTINUE
27620       DO 3 I=1,10
27621          NPOINT(I) = 0
27622     3 CONTINUE
27623       CALL DT_CHASTA(-1)
27624
27625 C* initialization of DTLTRA
27626 C      IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
27627
27628       RETURN
27629       END
27630
27631 *$ CREATE DT_STATIS.FOR
27632 *COPY DT_STATIS
27633 *
27634 *===statis=============================================================*
27635 *
27636       SUBROUTINE DT_STATIS(MODE)
27637
27638 ************************************************************************
27639 * Initialization and output of run-statistics.                         *
27640 *              MODE  = 1     initialization                            *
27641 *                    = 2     output                                    *
27642 * This version dated 23.01.94 is written by S. Roesler                 *
27643 ************************************************************************
27644
27645       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27646       SAVE
27647       PARAMETER ( LINP = 10 ,
27648      &            LOUT = 6 ,
27649      &            LDAT = 9 )
27650       PARAMETER (TINY3=1.0D-3)
27651
27652 * statistics
27653       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
27654      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
27655      &                ICEVTG(8,0:30)
27656 * rejection counter
27657       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27658      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27659      &                IREXCI(3),IRDIFF(2),IRINC
27660 * central particle production, impact parameter biasing
27661       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
27662 * various options for treatment of partons (DTUNUC 1.x)
27663 * (chain recombination, Cronin,..)
27664       LOGICAL LCO2CR,LINTPT
27665       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
27666      &                LCO2CR,LINTPT
27667 * nucleon-nucleon event-generator
27668       CHARACTER*8 CMODEL
27669       LOGICAL LPHOIN
27670       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
27671 * flags for particle decays
27672       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
27673      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
27674      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
27675 * diquark-breaking mechanism
27676       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
27677
27678       DIMENSION PP(4),PT(4)
27679
27680       GOTO (1,2) MODE
27681
27682 * initialization
27683     1 CONTINUE
27684
27685 *   initialize statistics counter
27686       ICREQU = 0
27687       ICSAMP = 0
27688       ICCPRO = 0
27689       ICDPR  = 0
27690       ICDTA  = 0
27691       ICRJSS = 0
27692       ICVV2S = 0
27693       DO 10 I=1,9
27694          ICRES(I)    = 0
27695          ICCHAI(1,I) = 0
27696          ICCHAI(2,I) = 0
27697    10 CONTINUE
27698 *   initialize rejection counter
27699       IRPT      = 0
27700       IRHHA     = 0
27701       LOMRES    = 0
27702       LOBRES    = 0
27703       IRFRAG    = 0
27704       IREVT     = 0
27705       IRRES(1)  = 0
27706       IRRES(2)  = 0
27707       IRCHKI(1) = 0
27708       IRCHKI(2) = 0
27709       IRCRON(1) = 0
27710       IRCRON(2) = 0
27711       IRCRON(3) = 0
27712       IRDIFF(1) = 0
27713       IRDIFF(2) = 0
27714       IRINC     = 0
27715       DO 11 I=1,5
27716          ICDIFF(I) = 0
27717    11 CONTINUE
27718       DO 12 I=1,8
27719          DO 13 J=0,30
27720             ICEVTG(I,J) = 0
27721    13    CONTINUE
27722    12 CONTINUE
27723
27724       RETURN
27725
27726 * output
27727     2 CONTINUE
27728
27729 *   statistics counter
27730       WRITE(LOUT,1000)
27731  1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/,
27732      &       28X,'---------------------')
27733       WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
27734  1001 FORMAT(/,1X,'number of events requested / sampled',13X,
27735      &       I8,' / ',I8,/,1X,'number of samp. evts per requested ',
27736      &       'event',11X,F9.1)
27737       IF (ICDIFF(1).NE.0) THEN
27738          WRITE(LOUT,1009) ICDIFF
27739  1009    FORMAT(/,1X,'diffractive events:    total   ',I8,/,49X,
27740      &          'low mass   high mass',/,24X,'single diffraction',
27741      &          7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
27742       ENDIF
27743       IF (ICENTR.GT.0) THEN
27744          WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
27745      &                    DBLE(ICSAMP)/DBLE(ICCPRO)
27746  1002    FORMAT(/,1X,'central production:',/,2X,'mean number',
27747      &          ' of sampled Glauber-events per event',9X,F9.1,/,
27748      &          2X,'fraction of production cross section',21X,F10.6)
27749       ENDIF
27750       WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
27751      &                 DBLE(ICDTA)/DBLE(ICSAMP)
27752  1003 FORMAT(/,54X,'proj.    targ.',/,1X,'average number of wounded',
27753      &       ' nucleons after x-sampling',2(4X,F6.2))
27754
27755       IF (MCGENE.EQ.1) THEN
27756          WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
27757  1004    FORMAT(/,1X,'mean number of sea-sea chain rejections per',
27758      &          ' event',3X,F9.1)
27759          IF (ISICHA.EQ.1) THEN
27760             WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
27761  1005       FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
27762      &             'of single chains  per event',13X,F9.1)
27763          ENDIF
27764          WRITE(LOUT,1006)
27765  1006    FORMAT(/,1X,'chain system statistics:  (per event)',/,
27766      &       23X,'mean number of chains      mean number of chains',/,
27767      &       23X,'sampled    hadronized      having mass of a reso.')
27768          WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
27769      &                     DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
27770      &                     DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
27771      &                  DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
27772  1007    FORMAT(1X,'sea     - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27773      &          1X,'disea   - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27774      &          1X,'sea     - disea   ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27775      &          1X,'sea     - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27776      &          1X,'disea   - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27777      &          1X,'valence - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27778      &          1X,'valence - disea   ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27779      &          1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27780      &          1X,'fused chains      ',18X,F4.1,17X,F4.1,/)
27781          WRITE(LOUT,1008)
27782      &     (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
27783      &     DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
27784      &     DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
27785      &     (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
27786      &     (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
27787      &     DBLE(IRHHA)/DBLE(ICREQU),
27788      &     DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
27789      &     (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
27790  1008    FORMAT(/,1X,'Rejection counter:  (NEVT = no. of events)',/,/,
27791      &       1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
27792      &       F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
27793      &       'Intrins. p_t (GETSPT)',21X,'IRPT     /NEVT = ',F7.2,/,
27794      &       1X,'Chain mass corr. for resonances (EVTRES)',2X,
27795      &       'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES)  IRRES(2) /',
27796      &       'NEVT = ',F7.2,/,43X,'LOMRES   /NEVT = ',F7.2,/,
27797      &       43X,'LOBRES   /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
27798      &       ' 2-chain systems (CHKINE)  IRCHKI(1)/NEVT = ',F7.2,/,
27799      &       43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
27800      &       'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
27801      &       F7.2,/,1X,'Total no. of rej.',
27802      &       ' in chain-systems treatment (GETCSY)',/,43X,
27803      &       'IRHHA    /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
27804      &       ' (not yet used!)',4X,'IRFRAG   /NEVT = ',F7.2,/,
27805      &       1X,'Total no. of rej. in DPM-treatment of one event',
27806      &       ' (EVENTA)',/,43X,'IREVT    /NEVT = ',F7.2,/,1X,
27807      &       'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
27808      &       ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
27809      &       'IREXCI(3) = ',I5,/)
27810       ELSEIF (MCGENE.EQ.2) THEN
27811          WRITE(LOUT,1010) ELOJET
27812  1010    FORMAT(/,/,1X,'PHOJET-treatment of chain systems above  ',
27813      &          F4.1,' GeV')
27814          WRITE(LOUT,1011)
27815  1011    FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
27816      &          30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
27817      &          5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
27818          WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
27819      &                    (INT(ICCHAI(2,I)/2.0D0),I=1,8),
27820      &                    (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
27821      &                    ((ICEVTG(I,J),I=1,8),J=3,7),
27822      &                    ((ICEVTG(I,J),I=1,8),J=19,21),
27823      &                    (ICEVTG(I,8),I=1,8),
27824      &                    ((ICEVTG(I,J),I=1,8),J=22,24),
27825      &                    (ICEVTG(I,9),I=1,8),
27826      &                    ((ICEVTG(I,J),I=1,8),J=25,28),
27827      &                    ((ICEVTG(I,J),I=1,8),J=10,18)
27828  1012    FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
27829      &          8I8,/,/,1X,'PHOJET ',8I8,/,'   sngl ',8I8,/,/,
27830      &          ' no-dif.',8I8,/,
27831      &          ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
27832      &          ' diff-1 ',8I8,/,'  low   ',8I8,/,'  high  ',8I8,/,
27833      &          '  h-diff',8I8,/,' diff-2 ',8I8,/,'  low   ',8I8,/,
27834      &          '  high  ',8I8,/,'  h-diff',8I8,/,' dbl-di.',8I8,/,
27835      &          '  lo-lo ',8I8,/,'  hi-hi ',8I8,/,'  lo-hi ',8I8,/,
27836      &          '  hi-lo ',8I8,/,
27837      &          ' dir-ga.',8I8,/,/,' dir-1  ',8I8,/,' dir-2  ',8I8,/,
27838      &          ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
27839      &          ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
27840          WRITE(LOUT,1013)
27841  1013    FORMAT(/,1X,'2. chain system statistics -',
27842      &          ' mean numbers per evt:',/,30X,'---------------------',
27843      &          /,/,16X,'s-s',7X,'d-s',7X,'s-d')
27844          WRITE(LOUT,1014)
27845      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
27846      &                 (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
27847      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
27848  1014    FORMAT(/,1X,'req.to.    ',3E10.2,/,/,1X,'low rq.    ',3E10.2,/,
27849      &          1X,'low ac.    ',3E10.2,/,/,1X,'PHOJET     ',3E10.2,/,/,
27850      &          ' no-dif.    ',3E10.2,/,' el-sca.    ',3E10.2,/,
27851      &          ' qel-sc.    ',3E10.2,/,' dbl-Po.    ',3E10.2,/,
27852      &          ' diff-1     ',3E10.2,/,' diff-2     ',3E10.2,/,
27853      &          ' dbl-di.    ',3E10.2,/,' dir-ga.    ',3E10.2,/,/,
27854      &          ' dir-1      ',3E10.2,/,' dir-2      ',3E10.2,/,
27855      &          ' dbl-dir    ',3E10.2,/,' s-Pom.     ',3E10.2,/,
27856      &          ' h-Pom.     ',3E10.2,/,' s-Reg.     ',3E10.2,/,
27857      &          ' enh-trg    ',3E10.2,/,' enh-log    ',3E10.2)
27858          WRITE(LOUT,1015)
27859  1015    FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
27860          WRITE(LOUT,1016)
27861      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
27862      &                 (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
27863      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
27864  1016    FORMAT(/,1X,'req.to.    ',5E10.2,/,/,1X,'low rq.    ',5E10.2,/,
27865      &          1X,'low ac.    ',5E10.2,/,/,1X,'PHOJET     ',5E10.2,/,/,
27866      &          ' no-dif.    ',5E10.2,/,' el-sca.    ',5E10.2,/,
27867      &          ' qel-sc.    ',5E10.2,/,' dbl-Po.    ',5E10.2,/,
27868      &          ' diff-1     ',5E10.2,/,' diff-2     ',5E10.2,/,
27869      &          ' dbl-di.    ',5E10.2,/,' dir-ga.    ',5E10.2,/,/,
27870      &          ' dir-1      ',5E10.2,/,' dir-2      ',5E10.2,/,
27871      &          ' dbl-dir    ',5E10.2,/,' s-Pom.     ',5E10.2,/,
27872      &          ' h-Pom.     ',5E10.2,/,' s-Reg.     ',5E10.2,/,
27873      &          ' enh-trg    ',5E10.2,/,' enh-log    ',5E10.2)
27874
27875       ENDIF
27876       CALL DT_CHASTA(1)
27877
27878       IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
27879      &                        .OR.(PDBSEA(3).GT.0.0D0)) THEN
27880          WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
27881      &    DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
27882      &    DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
27883          WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
27884      &    DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
27885      &    DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
27886          WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
27887      &    DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
27888      &    DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
27889          WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
27890      &    DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
27891      &    DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
27892          WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
27893      &    DBRKA(3,1),DBRKA(3,2),
27894      &    DBRKA(3,3),DBRKA(3,4)
27895          WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
27896      &    DBRKR(3,1),DBRKR(3,2),
27897      &    DBRKR(3,3),DBRKR(3,4)
27898          WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
27899      &    DBRKA(3,5),DBRKA(3,6),
27900      &    DBRKA(3,7),DBRKA(3,8)
27901          WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
27902      &    DBRKR(3,5),DBRKR(3,6),
27903      &    DBRKR(3,7),DBRKR(3,8)
27904       ENDIF
27905
27906       FAC = 1.0D0
27907       IF (MCGENE.EQ.2) THEN
27908 C        CALL PHO_PHIST(-2,SIGMAX)
27909          CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
27910       ENDIF
27911
27912       CALL DT_XTIME
27913
27914       RETURN
27915       END
27916
27917 *$ CREATE DT_EVTOUT.FOR
27918 *COPY DT_EVTOUT
27919 *
27920 *===evtout=============================================================*
27921 *
27922       SUBROUTINE DT_EVTOUT(MODE)
27923
27924 ************************************************************************
27925 *            MODE  = 1  plot content of complete DTEVT1 to out. unit   *
27926 *                    3  plot entries of extended DTEVT1 (DTEVT2)       *
27927 *                    4  plot entries of DTEVT1 and DTEVT2              *
27928 * This version dated 11.12.94 is written by S. Roesler                 *
27929 ************************************************************************
27930
27931       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27932       SAVE
27933       PARAMETER ( LINP = 10 ,
27934      &            LOUT = 6 ,
27935      &            LDAT = 9 )
27936 * event history
27937       PARAMETER (NMXHKK=200000)
27938       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27939      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27940      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27941
27942       DIMENSION IRANGE(NMXHKK)
27943
27944       IF (MODE.EQ.2) RETURN
27945
27946       CALL DT_EVTPLO(IRANGE,MODE)
27947
27948       RETURN
27949       END
27950
27951 *$ CREATE DT_EVTPLO.FOR
27952 *COPY DT_EVTPLO
27953 *
27954 *===evtplo=============================================================*
27955 *
27956       SUBROUTINE DT_EVTPLO(IRANGE,MODE)
27957
27958 ************************************************************************
27959 *            MODE  = 1  plot content of complete DTEVT1 to out. unit   *
27960 *                    2  plot entries of DTEVT1 given by IRANGE         *
27961 *                    3  plot entries of extended DTEVT1 (DTEVT2)       *
27962 *                    4  plot entries of DTEVT1 and DTEVT2              *
27963 *                    5  plot rejection counter                         *
27964 * This version dated 11.12.94 is written by S. Roesler                 *
27965 ************************************************************************
27966
27967       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27968       SAVE
27969       PARAMETER ( LINP = 10 ,
27970      &            LOUT = 6 ,
27971      &            LDAT = 9 )
27972
27973       CHARACTER*16 CHAU
27974
27975 * event history
27976       PARAMETER (NMXHKK=200000)
27977       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27978      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27979      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27980 * extended event history
27981       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27982      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27983      &                IHIST(2,NMXHKK)
27984 * rejection counter
27985       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27986      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27987      &                IREXCI(3),IRDIFF(2),IRINC
27988
27989       DIMENSION IRANGE(NMXHKK)
27990
27991       IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
27992          WRITE(LOUT,1000)
27993  1000    FORMAT(/,1X,'EVTPLO:',14X,'    content of COMMON /DTEVT1/',/,
27994      &         15X,'           --------------------------',/,/,
27995      &             '       ST    ID  M1   M2   D1   D2     PX     PY',
27996      &             '     PZ      E       M',/)
27997          DO 1 I=1,NHKK
27998             WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27999      &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28000      &                       PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
28001      &                       PHKK(5,I)
28002 C           WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28003 C    &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28004 C    &                       PHKK(3,I),PHKK(4,I)
28005 C           WRITE(LOUT,'(4E15.4)')
28006 C    &         VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
28007  1001       FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
28008  1011       FORMAT(I5,I5,I6,4I5,2E15.5)
28009     1    CONTINUE
28010          WRITE(LOUT,*)
28011 C        DO 4 I=1,NHKK
28012 C           WRITE(LOUT,1006) I,ISTHKK(I),
28013 C    &                    VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
28014 C    &                    WHKK(2,I),WHKK(3,I)
28015 C1006       FORMAT(1X,I4,I6,6E10.3)
28016 C   4    CONTINUE
28017       ENDIF
28018
28019       IF (MODE.EQ.2) THEN
28020          WRITE(LOUT,1000)
28021          NC = 0
28022     2    CONTINUE
28023          NC = NC+1
28024          IF (IRANGE(NC).EQ.-100) GOTO 9999
28025          I = IRANGE(NC)
28026          WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28027      &                    JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28028      &                    PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
28029      &                    PHKK(5,I)
28030          GOTO 2
28031       ENDIF
28032
28033       IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
28034          WRITE(LOUT,1002)
28035  1002    FORMAT(/,1X,'EVTPLO:',14X,
28036      &         ' content of COMMON /DTEVT1/,/DTEVT2/',/,
28037      &         15X,'        -----------------------------------',/,/,
28038      &             '       ST    ID   M1   M2   D1   D2  IDR  IDXR',
28039      &             ' NOBAM IDCH    M',/)
28040          DO 3 I=1,NHKK
28041 C           IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
28042                KF    = IDHKK(I)
28043                IDCHK = KF/10000
28044                IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28045      &            (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
28046                CALL PYNAME(KF,CHAU)
28047                WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
28048      &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
28049      &                       IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
28050      &                       PHKK(5,I),CHAU
28051  1003          FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
28052 C           ENDIF
28053     3    CONTINUE
28054       ENDIF
28055
28056       IF (MODE.EQ.5) THEN
28057          WRITE(LOUT,1004)
28058  1004    FORMAT(/,1X,'EVTPLO:',14X,'    content of COMMON /DTREJC/',/,
28059      &         15X,'           --------------------------',/)
28060          WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
28061      &                    IRSEA,IRCRON
28062  1005    FORMAT(1X,'IRPT   = ',I5,'  IRHHA = ',I5,/,
28063      &          1X,'IRRES  = ',2I5,'  LOMRES = ',I5,'  LOBRES = ',I5,/,
28064      &          1X,'IREMC  = ',10I5,/,
28065      &          1X,'IRFRAG = ',I5,'  IRSEA = ',I5,' IRCRON = ',I5,/)
28066       ENDIF
28067
28068  9999 RETURN
28069       END
28070
28071 *$ CREATE DT_EVTPUT.FOR
28072 *COPY DT_EVTPUT
28073 *
28074 *===evtput=============================================================*
28075 *
28076       SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
28077
28078       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28079       SAVE
28080       PARAMETER ( LINP = 10 ,
28081      &            LOUT = 6 ,
28082      &            LDAT = 9 )
28083       PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
28084      &           TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0)
28085
28086 * event history
28087       PARAMETER (NMXHKK=200000)
28088       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28089      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28090      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28091 * extended event history
28092       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28093      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28094      &                IHIST(2,NMXHKK)
28095 * Lorentz-parameters of the current interaction
28096       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28097      &                UMO,PPCM,EPROJ,PPROJ
28098 * particle properties (BAMJET index convention)
28099       CHARACTER*8  ANAME
28100       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28101      &                IICH(210),IIBAR(210),K1(210),K2(210)
28102
28103 C     IF (MODE.GT.100) THEN
28104 C        WRITE(LOUT,'(1X,A,I5,A,I5)')
28105 C    &        'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
28106 C        NHKK = NHKK-MODE+100
28107 C        RETURN
28108 C     ENDIF
28109       MO1  = M1
28110       MO2  = M2
28111       NHKK = NHKK+1
28112
28113       IF (NHKK.GT.NMXHKK) THEN
28114          WRITE(LOUT,1000) NHKK
28115  1000    FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
28116      &             '! program execution stopped..')
28117          STOP
28118       ENDIF
28119       IF (M1.LT.0) MO1 = NHKK+M1
28120       IF (M2.LT.0) MO2 = NHKK+M2
28121       ISTHKK(NHKK)   = IST
28122       IDHKK(NHKK)    = ID
28123       JMOHKK(1,NHKK) = MO1
28124       JMOHKK(2,NHKK) = MO2
28125       JDAHKK(1,NHKK) = 0
28126       JDAHKK(2,NHKK) = 0
28127       IDRES(NHKK)    = IDR
28128       IDXRES(NHKK)   = IDXR
28129       IDCH(NHKK)     = IDC
28130 ** here we need to do something..
28131       IF (ID.EQ.88888) THEN
28132          IDMO1 = ABS(IDHKK(MO1))
28133          IDMO2 = ABS(IDHKK(MO2))
28134          IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
28135          IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
28136          IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
28137          IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
28138       ELSE
28139          NOBAM(NHKK) = 0
28140       ENDIF
28141       IDBAM(NHKK) = IDT_ICIHAD(ID)
28142       IF (MO1.GT.0) THEN
28143          IF (JDAHKK(1,MO1).NE.0) THEN
28144             JDAHKK(2,MO1) = NHKK
28145          ELSE
28146             JDAHKK(1,MO1) = NHKK
28147          ENDIF
28148       ENDIF
28149       IF (MO2.GT.0) THEN
28150          IF (JDAHKK(1,MO2).NE.0) THEN
28151             JDAHKK(2,MO2) = NHKK
28152          ELSE
28153             JDAHKK(1,MO2) = NHKK
28154          ENDIF
28155       ENDIF
28156 C      IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
28157 C         PTOT   = SQRT(PX**2+PY**2+PZ**2)
28158 C         AM0    = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
28159 C         AMRQ   = AAM(IDBAM(NHKK))
28160 C         AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
28161 C         IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
28162 C     &       (PTOT.GT.ZERO)) THEN
28163 C            DELTA = -AMDIF2/(2.0D0*(E+PTOT))
28164 CC           DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
28165 C            E     = E+DELTA
28166 C            PTOT1 = PTOT-DELTA
28167 C            PX    = PX*PTOT1/PTOT
28168 C            PY    = PY*PTOT1/PTOT
28169 C            PZ    = PZ*PTOT1/PTOT
28170 C         ENDIF
28171 C      ENDIF
28172       PHKK(1,NHKK) = PX
28173       PHKK(2,NHKK) = PY
28174       PHKK(3,NHKK) = PZ
28175       PHKK(4,NHKK) = E
28176       PTOT = SQRT( PX**2+PY**2+PZ**2 )
28177       IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
28178          PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
28179          PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
28180       ELSE
28181          PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
28182 C        IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
28183 C    &      WRITE(LOUT,'(1X,A,G10.3)')
28184 C    &        'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
28185          PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
28186       ENDIF
28187       IDCHK = ID/10000
28188       IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
28189 * special treatment for chains:
28190 *    z coordinate of chain in Lab  = pos. of target nucleon
28191 *    time of chain-creation in Lab = time of passage of projectile
28192 *                                    nucleus at pos. of taget nucleus
28193 C        VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
28194 C        VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
28195          VHKK(1,NHKK) = VHKK(1,MO2)
28196          VHKK(2,NHKK) = VHKK(2,MO2)
28197          VHKK(3,NHKK) = VHKK(3,MO2)
28198          VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
28199 C        WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
28200 C        WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
28201          WHKK(1,NHKK) = WHKK(1,MO1)
28202          WHKK(2,NHKK) = WHKK(2,MO1)
28203          WHKK(3,NHKK) = WHKK(3,MO1)
28204          WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
28205       ELSE
28206          IF (MO1.GT.0) THEN
28207             DO 1 I=1,4
28208                VHKK(I,NHKK) = VHKK(I,MO1)
28209                WHKK(I,NHKK) = WHKK(I,MO1)
28210     1       CONTINUE
28211          ELSE
28212             DO 2 I=1,4
28213                VHKK(I,NHKK) = ZERO
28214                WHKK(I,NHKK) = ZERO
28215     2       CONTINUE
28216          ENDIF
28217       ENDIF
28218
28219       RETURN
28220       END
28221
28222 *$ CREATE DT_CHASTA.FOR
28223 *COPY DT_CHASTA
28224 *
28225 *===chasta=============================================================*
28226 *
28227       SUBROUTINE DT_CHASTA(MODE)
28228
28229 ************************************************************************
28230 * This subroutine performs CHAin STAtistics and checks sequence of     *
28231 * partons in dtevt1 and sorts them with projectile partons coming      *
28232 * first if necessary.                                                  *
28233 *                                                                      *
28234 * This version dated  8.5.00  is written by S. Roesler.                *
28235 ************************************************************************
28236
28237       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28238       SAVE
28239       PARAMETER ( LINP = 10 ,
28240      &            LOUT = 6 ,
28241      &            LDAT = 9 )
28242
28243       CHARACTER*5 CCHTYP
28244
28245 * event history
28246       PARAMETER (NMXHKK=200000)
28247       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28248      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28249      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28250 * extended event history
28251       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28252      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28253      &                IHIST(2,NMXHKK)
28254 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
28255       PARAMETER (MAXCHN=10000)
28256       COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
28257
28258       DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
28259      &          CCHTYP(9),ICHSTA(10),ITOT(10)
28260       DATA ICHCFG /1800*0/
28261       DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
28262       DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
28263       DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
28264       DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
28265       DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
28266       DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
28267       DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
28268      &              'ad aq',' d ad','ad d ',' g g '/
28269 *
28270 * initialization
28271 *
28272       IF (MODE.EQ.-1) THEN
28273          NCHAIN = 0
28274 *
28275 * loop over DTEVT1 and analyse chain configurations
28276 *
28277       ELSEIF (MODE.EQ.0) THEN
28278          DO 21 IDX=NPOINT(3),NHKK
28279             IDCHK = IDHKK(IDX)/10000
28280             IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28281      &          (IDHKK(IDX).NE.80000).AND.
28282      &          (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
28283                IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
28284                   WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
28285      &                          ' at entry ',IDX
28286                   GOTO 21
28287                ENDIF
28288 *
28289                IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28290                IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28291                IMO1 = IST1/10
28292                IMO1 = IST1-10*IMO1
28293                IMO2 = IST2/10
28294                IMO2 = IST2-10*IMO2
28295 *   swop parton entries if necessary since we need projectile partons
28296 *   to come first in the common
28297                IF (IMO1.GT.IMO2) THEN
28298                   NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
28299                   DO 22 K=1,NPTN/2
28300                      I0 = JMOHKK(1,IDX)-1+K
28301                      I1 = JMOHKK(2,IDX)+1-K
28302                      ITMP = ISTHKK(I0)
28303                      ISTHKK(I0) = ISTHKK(I1)
28304                      ISTHKK(I1) = ITMP
28305                      ITMP = IDHKK(I0)
28306                      IDHKK(I0) = IDHKK(I1)
28307                      IDHKK(I1) = ITMP
28308                      IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
28309      &                  JDAHKK(1,JMOHKK(1,I0)) = I1
28310                      IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
28311      &                  JDAHKK(2,JMOHKK(1,I0)) = I1
28312                      IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
28313      &                  JDAHKK(1,JMOHKK(2,I0)) = I1
28314                      IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
28315      &                  JDAHKK(2,JMOHKK(2,I0)) = I1
28316                      IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
28317      &                  JDAHKK(1,JMOHKK(1,I1)) = I0
28318                      IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
28319      &                  JDAHKK(2,JMOHKK(1,I1)) = I0
28320                      IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
28321      &                  JDAHKK(1,JMOHKK(2,I1)) = I0
28322                      IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
28323      &                  JDAHKK(2,JMOHKK(2,I1)) = I0
28324                      ITMP = JMOHKK(1,I0)
28325                      JMOHKK(1,I0) = JMOHKK(1,I1)
28326                      JMOHKK(1,I1) = ITMP
28327                      ITMP = JMOHKK(2,I0)
28328                      JMOHKK(2,I0) = JMOHKK(2,I1)
28329                      JMOHKK(2,I1) = ITMP
28330                      ITMP = JDAHKK(1,I0)
28331                      JDAHKK(1,I0) = JDAHKK(1,I1)
28332                      JDAHKK(1,I1) = ITMP
28333                      ITMP = JDAHKK(2,I0)
28334                      JDAHKK(2,I0) = JDAHKK(2,I1)
28335                      JDAHKK(2,I1) = ITMP
28336                      DO 23 J=1,4
28337                         RTMP1 = PHKK(J,I0)
28338                         RTMP2 = VHKK(J,I0)
28339                         RTMP3 = WHKK(J,I0)
28340                         PHKK(J,I0) = PHKK(J,I1)
28341                         VHKK(J,I0) = VHKK(J,I1)
28342                         WHKK(J,I0) = WHKK(J,I1)
28343                         PHKK(J,I1) = RTMP1
28344                         VHKK(J,I1) = RTMP2
28345                         WHKK(J,I1) = RTMP3
28346    23                CONTINUE
28347                      RTMP1 = PHKK(5,I0)
28348                      PHKK(5,I0) = PHKK(5,I1)
28349                      PHKK(5,I1) = RTMP1
28350                      ITMP = IDRES(I0)
28351                      IDRES(I0) = IDRES(I1)
28352                      IDRES(I1) = ITMP
28353                      ITMP = IDXRES(I0)
28354                      IDXRES(I0) = IDXRES(I1)
28355                      IDXRES(I1) = ITMP
28356                      ITMP = NOBAM(I0)
28357                      NOBAM(I0) = NOBAM(I1)
28358                      NOBAM(I1) = ITMP
28359                      ITMP = IDBAM(I0)
28360                      IDBAM(I0) = IDBAM(I1)
28361                      IDBAM(I1) = ITMP
28362                      ITMP = IDCH(I0)
28363                      IDCH(I0) = IDCH(I1)
28364                      IDCH(I1) = ITMP
28365                      ITMP = IHIST(1,I0)
28366                      IHIST(1,I0) = IHIST(1,I1)
28367                      IHIST(1,I1) = ITMP
28368                      ITMP = IHIST(2,I0)
28369                      IHIST(2,I0) = IHIST(2,I1)
28370                      IHIST(2,I1) = ITMP
28371    22             CONTINUE
28372                ENDIF
28373                IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28374                IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28375 *
28376 *   parton 1 (projectile side)
28377                IF (IST1.EQ.21) THEN
28378                   IDX1 = 1
28379                ELSEIF (IST1.EQ.22) THEN
28380                   IDX1 = 2
28381                ELSEIF (IST1.EQ.31) THEN
28382                   IDX1 = 3
28383                ELSEIF (IST1.EQ.32) THEN
28384                   IDX1 = 4
28385                ELSEIF (IST1.EQ.41) THEN
28386                   IDX1 = 5
28387                ELSEIF (IST1.EQ.42) THEN
28388                   IDX1 = 6
28389                ELSEIF (IST1.EQ.51) THEN
28390                   IDX1 = 7
28391                ELSEIF (IST1.EQ.52) THEN
28392                   IDX1 = 8
28393                ELSEIF (IST1.EQ.61) THEN
28394                   IDX1 = 9
28395                ELSEIF (IST1.EQ.62) THEN
28396                   IDX1 = 10
28397                ELSE
28398 c                 WRITE(LOUT,*)
28399 c    &               ' CHASTA: unknown parton status flag (',
28400 c    &               IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28401                   GOTO 21
28402                ENDIF
28403                ID = IDHKK(JMOHKK(1,IDX))
28404                IF (ABS(ID).LE.4) THEN
28405                   IF (ID.GT.0) THEN
28406                      ITYP1 = 1
28407                   ELSE
28408                      ITYP1 = 2
28409                   ENDIF
28410                ELSEIF (ABS(ID).GE.1000) THEN
28411                   IF (ID.GT.0) THEN
28412                      ITYP1 = 3
28413                   ELSE
28414                      ITYP1 = 4
28415                   ENDIF
28416                ELSEIF (ID.EQ.21) THEN
28417                   ITYP1 = 5
28418                ELSE
28419                   WRITE(LOUT,*)
28420      &               ' CHASTA: inconsistent parton identity (',
28421      &               ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28422                   GOTO 21
28423                ENDIF
28424 *
28425 *   parton 2 (target side)
28426                IF (IST2.EQ.21) THEN
28427                   IDX2 = 1
28428                ELSEIF (IST2.EQ.22) THEN
28429                   IDX2 = 2
28430                ELSEIF (IST2.EQ.31) THEN
28431                   IDX2 = 3
28432                ELSEIF (IST2.EQ.32) THEN
28433                   IDX2 = 4
28434                ELSEIF (IST2.EQ.41) THEN
28435                   IDX2 = 5
28436                ELSEIF (IST2.EQ.42) THEN
28437                   IDX2 = 6
28438                ELSEIF (IST2.EQ.51) THEN
28439                   IDX2 = 7
28440                ELSEIF (IST2.EQ.52) THEN
28441                   IDX2 = 8
28442                ELSEIF (IST2.EQ.61) THEN
28443                   IDX2 = 9
28444                ELSEIF (IST2.EQ.62) THEN
28445                   IDX2 = 10
28446                ELSE
28447 c                 WRITE(LOUT,*)
28448 c    &               ' CHASTA: unknown parton status flag (',
28449 c    &               IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
28450                   GOTO 21
28451                ENDIF
28452                ID = IDHKK(JMOHKK(2,IDX))
28453                IF (ABS(ID).LE.4) THEN
28454                   IF (ID.GT.0) THEN
28455                      ITYP2 = 1
28456                   ELSE
28457                      ITYP2 = 2
28458                   ENDIF
28459                ELSEIF (ABS(ID).GE.1000) THEN
28460                   IF (ID.GT.0) THEN
28461                      ITYP2 = 3
28462                   ELSE
28463                      ITYP2 = 4
28464                   ENDIF
28465                ELSEIF (ID.EQ.21) THEN
28466                   ITYP2 = 5
28467                ELSE
28468                   WRITE(LOUT,*)
28469      &               ' CHASTA: inconsistent parton identity (',
28470      &               ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28471                   GOTO 21
28472                ENDIF
28473 *
28474 *   fill counter
28475                ITYPE = ICHTYP(ITYP1,ITYP2)
28476                IF (ITYPE.NE.0) THEN
28477                   ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
28478                   NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
28479                   ICHCFG(IDX1,IDX2,ITYPE,2) =
28480      &               ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
28481
28482                   NCHAIN = NCHAIN+1
28483                   IF (NCHAIN.GT.MAXCHN) THEN
28484                      WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
28485      &                  NCHAIN,MAXCHN
28486                      STOP
28487                   ENDIF
28488                   IDXCHN(1,NCHAIN) = IDX
28489                   IDXCHN(2,NCHAIN) = ITYPE
28490                ELSE
28491                   WRITE(LOUT,*)
28492      &               ' CHASTA: inconsistent chain at entry ',IDX
28493                   GOTO 21
28494                ENDIF
28495             ENDIF
28496    21    CONTINUE
28497 *
28498 * write statistics to output unit
28499 *
28500       ELSEIF (MODE.EQ.1) THEN
28501          WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
28502          DO 31 I=1,10
28503             WRITE(LOUT,'(/,2A)')
28504      &         ' -----------------------------------------',
28505      &         '------------------------------------'
28506             WRITE(LOUT,'(2A)')
28507      &         ' p\\t         21     22     31     32     41',
28508      &         '     42     51     52     61     62'
28509             WRITE(LOUT,'(2A)')
28510      &         ' -----------------------------------------',
28511      &         '------------------------------------'
28512             DO 32 J=1,10
28513                ITOT(J) = 0
28514                DO 33 K=1,9
28515                   ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
28516    33          CONTINUE
28517    32       CONTINUE
28518             WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
28519             DO 34 K=1,9
28520                ISUM = 0
28521                DO 35 J=1,10
28522                   ISUM = ISUM+ICHCFG(I,J,K,1)
28523    35          CONTINUE
28524                IF (ISUM.GT.0)
28525      &            WRITE(LOUT,'(1X,A5,2X,10I7)')
28526      &               CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
28527    34       CONTINUE
28528 C           WRITE(LOUT,'(2A)')
28529 C    &         ' -----------------------------------------',
28530 C    &         '-------------------------------'
28531    31    CONTINUE
28532 *
28533       ELSE
28534          WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
28535          STOP
28536       ENDIF
28537
28538       RETURN
28539       END
28540 *$ CREATE PHO_PHIST.FOR
28541 *COPY PHO_PHIST
28542 *
28543 *===pohist=============================================================*
28544 *
28545       SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
28546
28547       IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28548       SAVE
28549
28550       PARAMETER ( LINP = 10 ,
28551      &            LOUT = 6 ,
28552      &            LDAT = 9 )
28553       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
28554 * Glauber formalism: cross sections
28555       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
28556      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
28557      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
28558      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
28559      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
28560      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
28561      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
28562      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
28563      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
28564      &                BSLOPE,NEBINI,NQBINI
28565
28566       ILAB = 0
28567       IF (IMODE.EQ.10) THEN
28568          IMODE = 1
28569          ILAB  = 1
28570       ENDIF
28571       IF (ABS(IMODE).LT.1000) THEN
28572 * PHOJET-statistics
28573 C        CALL POHISX(IMODE,WEIGHT)
28574          IF (IMODE.EQ.-1) THEN
28575             MODE = 1
28576             XSTOT(1,1,1) = WEIGHT
28577          ENDIF
28578          IF (IMODE.EQ. 1) MODE = 2
28579          IF (IMODE.EQ.-2) MODE = 3
28580          IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
28581 C        IF (MODE.EQ.3) WRITE(LOUT,*)
28582 C    &      ' Sigma = ',XSPRO(1,1,1),' mb   used for normalization'
28583          CALL DT_HISTOG(MODE)
28584          CALL DT_USRHIS(MODE)
28585       ELSE
28586 * DTUNUC-statistics
28587          MODE = IMODE/1000
28588 C        IF (MODE.EQ.3) WRITE(LOUT,*)
28589 C    &      ' Sigma = ',XSPRO(1,1,1),' mb   used for normalization'
28590          CALL DT_HISTOG(MODE)
28591          CALL DT_USRHIS(MODE)
28592       ENDIF
28593
28594       RETURN
28595       END
28596
28597 *$ CREATE DT_SWPPHO.FOR
28598 *COPY DT_SWPPHO
28599 *
28600 *===swppho=============================================================*
28601 *
28602       SUBROUTINE DT_SWPPHO(ILAB)
28603
28604       IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28605       SAVE
28606       PARAMETER ( LINP = 10 ,
28607      &            LOUT = 6 ,
28608      &            LDAT = 9 )
28609       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28610
28611       LOGICAL LSTART
28612
28613 * event history
28614       PARAMETER (NMXHKK=200000)
28615       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28616      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28617      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28618 * extended event history
28619       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28620      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28621      &                IHIST(2,NMXHKK)
28622 * flags for input different options
28623       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28624       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28625      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28626 * properties of photon/lepton projectiles
28627       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
28628
28629 **PHOJET105a
28630 C     PARAMETER (NMXHEP=2000)
28631 C     COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28632 C    &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
28633 C     COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28634 C     COMMON /PLASAV/ PLAB
28635 **PHOJET110
28636 C  standard particle data interface
28637       INTEGER NMXHEP
28638       PARAMETER (NMXHEP=4000)
28639       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28640       DOUBLE PRECISION PHEP,VHEP
28641       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28642      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28643      &                VHEP(4,NMXHEP)
28644 C  extension to standard particle data interface (PHOJET specific)
28645       INTEGER IMPART,IPHIST,ICOLOR
28646       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28647 C  global event kinematics and particle IDs
28648       INTEGER IFPAP,IFPAB
28649       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28650       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28651 **
28652       DATA ICOUNT/0/
28653
28654       DATA LSTART /.TRUE./
28655
28656 C     IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
28657       IF ((IFRAME.EQ.1).AND.LSTART) THEN
28658          UMO  = ECM
28659          ELA  = ZERO
28660          PLA  = ZERO
28661          IDP  = IDT_ICIHAD(IFPAP(1))
28662          IDT  = IDT_ICIHAD(IFPAP(2))
28663          VIRT = PVIRT(1)
28664          CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
28665          PLAB = PLA
28666          LSTART = .FALSE.
28667       ENDIF
28668
28669       NHKK   = 0
28670       ICOUNT = ICOUNT+1
28671 C     NEVHKK = NEVHEP
28672       NEVHKK = ICOUNT
28673       IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
28674       DO 1 I=3,NHEP
28675          IF (ISTHEP(I).EQ.1) THEN
28676             NHKK = NHKK+1
28677             ISTHKK(NHKK) = 1
28678             IDHKK(NHKK)  = IDHEP(I)
28679             JMOHKK(1,NHKK) = 0
28680             JMOHKK(2,NHKK) = 0
28681             JDAHKK(1,NHKK) = 0
28682             JDAHKK(2,NHKK) = 0
28683             DO 2 K=1,4
28684                PHKK(K,NHKK) = PHEP(K,I)
28685                VHKK(K,NHKK) = ZERO
28686                WHKK(K,NHKK) = ZERO
28687     2       CONTINUE
28688             IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
28689      &         CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
28690      &                    PHKK(3,NHKK),PHKK(4,NHKK),-3)
28691             PHKK(5,NHKK) = PHEP(5,I)
28692             IDRES(NHKK)  = 0
28693             IDXRES(NHKK) = 0
28694             NOBAM(NHKK)  = 0
28695             IDBAM(NHKK)  = IDT_ICIHAD(IDHEP(I))
28696             IDCH(NHKK)   = 0
28697          ENDIF
28698     1 CONTINUE
28699
28700       RETURN
28701       END
28702
28703 *$ CREATE DT_HISTOG.FOR
28704 *COPY DT_HISTOG
28705 *
28706 *===histog=============================================================*
28707 *
28708       SUBROUTINE DT_HISTOG(MODE)
28709
28710 ************************************************************************
28711 * This version dated 25.03.96 is written by S. Roesler                 *
28712 ************************************************************************
28713
28714       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28715       SAVE
28716       PARAMETER ( LINP = 10 ,
28717      &            LOUT = 6 ,
28718      &            LDAT = 9 )
28719
28720       LOGICAL LFSP,LRNL
28721
28722 * event history
28723       PARAMETER (NMXHKK=200000)
28724       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28725      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28726      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28727 * extended event history
28728       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28729      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28730      &                IHIST(2,NMXHKK)
28731 * event flag used for histograms
28732       COMMON /DTNORM/ ICEVT,IEVHKK
28733 * flags for activated histograms
28734       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
28735
28736       IEVHKK = NEVHKK
28737       GOTO (1,2,3) MODE
28738
28739 *------------------------------------------------------------------
28740 * initialization
28741     1 CONTINUE
28742       ICEVT = 0
28743       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
28744       IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
28745
28746       RETURN
28747 *------------------------------------------------------------------
28748 * filling of histogram with event-record
28749     2 CONTINUE
28750       ICEVT = ICEVT+1
28751
28752       DO 20 I=1,NHKK
28753          CALL DT_SWPFSP(I,LFSP,LRNL)
28754          IF (LFSP) THEN
28755             IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
28756             IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
28757          ENDIF
28758          IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
28759    20 CONTINUE
28760       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
28761
28762       RETURN
28763 *------------------------------------------------------------------
28764 * output
28765     3 CONTINUE
28766       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
28767       IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
28768
28769       RETURN
28770       END
28771
28772 *$ CREATE DT_SWPFSP.FOR
28773 *COPY DT_SWPFSP
28774 *
28775 *===swpfsp=============================================================*
28776 *
28777       SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
28778
28779       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28780       SAVE
28781       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28782       PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
28783      &           PI   =TWOPI/TWO,
28784      &           BOG  =TWOPI/360.0D0)
28785
28786 * event history
28787       PARAMETER (NMXHKK=200000)
28788       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28789      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28790      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28791 * extended event history
28792       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28793      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28794      &                IHIST(2,NMXHKK)
28795 * particle properties (BAMJET index convention)
28796       CHARACTER*8  ANAME
28797       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28798      &                IICH(210),IIBAR(210),K1(210),K2(210)
28799 * Lorentz-parameters of the current interaction
28800       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28801      &                UMO,PPCM,EPROJ,PPROJ
28802 * flags for input different options
28803       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28804       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28805      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28806 * (original name: PAREVT)
28807       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
28808      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
28809       PARAMETER ( NALLWP = 39   )
28810       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
28811      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
28812      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
28813      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
28814 * temporary storage for one final state particle
28815       LOGICAL LFRAG,LGREY,LBLACK
28816       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28817      &                SINTHE,COSTHE,THETA,THECMS,
28818      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28819      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28820      &                LFRAG,LGREY,LBLACK
28821
28822       LOGICAL LFSP,LRNL
28823
28824       LFSP = .FALSE.
28825       LRNL = .FALSE.
28826       ISTRNL = 1000
28827       MULDEF = 1
28828       IF (LEVPRT) ISTRNL = 1001
28829
28830       IF (ABS(ISTHKK(IDX)).EQ.1) THEN
28831          IST    = ISTHKK(IDX)
28832          IDPDG  = IDHKK(IDX)
28833          LFRAG  = .FALSE.
28834          IF (IDHKK(IDX).LT.80000) THEN
28835             IDBJT  = IDBAM(IDX)
28836             IBARY  = IIBAR(IDBJT)
28837             ICHAR  = IICH(IDBJT)
28838             AMASS  = AAM(IDBJT)
28839          ELSEIF (IDHKK(IDX).EQ.80000) THEN
28840             IDBJT  = 0
28841             IBARY  = IDRES(IDX)
28842             ICHAR  = IDXRES(IDX)
28843             AMASS  = PHKK(5,IDX)
28844             INUT   = IBARY-ICHAR
28845             IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
28846             IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
28847             IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
28848             IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
28849             IF (IDBJT.EQ.0) LFRAG = .TRUE.
28850          ELSE
28851             GOTO 9999
28852          ENDIF
28853          PE     = PHKK(4,IDX)
28854          PX     = PHKK(1,IDX)
28855          PY     = PHKK(2,IDX)
28856          PZ     = PHKK(3,IDX)
28857          PT2    = PX**2+PY**2
28858          PT     = SQRT(PT2)
28859          PTOT   = SQRT(PT2+PZ**2)
28860          SINTHE = PT/MAX(PTOT,TINY14)
28861          COSTHE = PZ/MAX(PTOT,TINY14)
28862          IF (COSTHE.GT.ONE) THEN
28863             THETA = ZERO
28864          ELSEIF (COSTHE.LT.-ONE) THEN
28865             THETA = TWOPI/2.0D0
28866          ELSE
28867             THETA = ACOS(COSTHE)
28868          ENDIF
28869          EKIN   = PE-AMASS
28870 **sr 15.4.96 new E_t-definition
28871          IF (IBARY.GT.0) THEN
28872             ET = EKIN*SINTHE
28873          ELSEIF (IBARY.LT.0) THEN
28874             ET = (EKIN+TWO*AMASS)*SINTHE
28875          ELSE
28876             ET = PE*SINTHE
28877          ENDIF
28878 **
28879          XLAB   = PZ/MAX(PPROJ,TINY14)
28880 C        XLAB   = PE/MAX(EPROJ,TINY14)
28881          BETA   = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
28882      &                     *(ONE+AMASS/MAX(PE,TINY14)) ))
28883          PPLUS  = PE+PZ
28884          PMINUS = PE-PZ
28885          IF (PMINUS.GT.TINY14) THEN
28886             YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28887          ELSE
28888             YY = 100.0D0
28889          ENDIF
28890          IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28891             ETA = -LOG(TAN(THETA/TWO))
28892          ELSE
28893             ETA = 100.0D0
28894          ENDIF
28895          IF (IFRAME.EQ.1) THEN
28896             CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
28897             PPLUS  = EECMS+PZCMS
28898             PMINUS = EECMS-PZCMS
28899             IF ((PPLUS*PMINUS).GT.TINY14) THEN
28900                YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28901             ELSE
28902                YYCMS = 100.0D0
28903             ENDIF
28904             PTOTCM = SQRT(PT2+PZCMS**2)
28905             COSTH = PZCMS/MAX(PTOTCM,TINY14)
28906             IF (COSTH.GT.ONE) THEN
28907                THECMS = ZERO
28908             ELSEIF (COSTH.LT.-ONE) THEN
28909                THECMS = TWOPI/2.0D0
28910             ELSE
28911                THECMS = ACOS(COSTH)
28912             ENDIF
28913             IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
28914                ETACMS = -LOG(TAN(THECMS/TWO))
28915             ELSE
28916                ETACMS = 100.0D0
28917             ENDIF
28918             XF = PZCMS/MAX(PPCM,TINY14)
28919             THECMS = THECMS/BOG
28920          ELSE
28921             PZCMS  = PZ
28922             EECMS  = PE
28923             YYCMS  = YY
28924             ETACMS = ETA
28925             XF     = XLAB
28926             THECMS = THETA/BOG
28927          ENDIF
28928          THETA  = THETA/BOG
28929
28930 * set flag for "grey/black"
28931          LGREY  = .FALSE.
28932          LBLACK = .FALSE.
28933          EK     = EKIN
28934          IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
28935          IF (MULDEF.EQ.1) THEN
28936 *  EMU01-Def.
28937             IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
28938      &                              (EK.LE.375.0D-3)      ).OR.
28939      &           ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
28940      &                              (EK.LE. 56.0D-3)      ).OR.
28941      &           ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
28942      &                              (EK.LE. 56.0D-3)      ).OR.
28943      &           ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
28944      &                              (EK.LE.198.0D-3)      ).OR.
28945      &           ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
28946      &                              (EK.LE.198.0D-3)      ).OR.
28947      &           ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28948      &             (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28949      &             (IDBJT.NE.16).AND.
28950      &             (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)    ) )
28951      &         LGREY = .TRUE.
28952             IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
28953      &           ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
28954      &           ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
28955      &           ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
28956      &           ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
28957      &           ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28958      &             (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28959      &             (IDBJT.NE.16).AND.(BETA.LE.0.23D0)  ) )
28960      &         LBLACK = .TRUE.
28961          ELSE
28962 *  common Def.
28963             IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
28964             IF (BETA.LE.0.23D0) LBLACK=.TRUE.
28965          ENDIF
28966          LFSP = .TRUE.
28967       ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
28968          IST    = ISTHKK(IDX)
28969          IDPDG  = IDHKK(IDX)
28970          LFRAG  = .TRUE.
28971          IDBJT  = 0
28972          IBARY  = IDRES(IDX)
28973          ICHAR  = IDXRES(IDX)
28974          AMASS  = PHKK(5,IDX)
28975          PE     = PHKK(4,IDX)
28976          PX     = PHKK(1,IDX)
28977          PY     = PHKK(2,IDX)
28978          PZ     = PHKK(3,IDX)
28979          PT2    = PX**2+PY**2
28980          PT     = SQRT(PT2)
28981          PTOT   = SQRT(PT2+PZ**2)
28982          SINTHE = PT/MAX(PTOT,TINY14)
28983          COSTHE = PZ/MAX(PTOT,TINY14)
28984          IF (COSTHE.GT.ONE) THEN
28985             THETA = ZERO
28986          ELSEIF (COSTHE.LT.-ONE) THEN
28987             THETA = TWOPI/2.0D0
28988          ELSE
28989             THETA  = ACOS(COSTHE)
28990          ENDIF
28991          EKIN   = PE-AMASS
28992 **sr 15.4.96 new E_t-definition
28993 C        ET     = PE*SINTHE
28994          ET     = EKIN*SINTHE
28995 **
28996          IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28997             ETA = -LOG(TAN(THETA/TWO))
28998          ELSE
28999             ETA = 100.0D0
29000          ENDIF
29001          THETA  = THETA/BOG
29002          LRNL   = .TRUE.
29003       ENDIF
29004
29005  9999 CONTINUE
29006       RETURN
29007       END
29008
29009 *$ CREATE DT_HIMULT.FOR
29010 *COPY DT_HIMULT
29011 *
29012 *===himult=============================================================*
29013 *
29014       SUBROUTINE DT_HIMULT(MODE)
29015
29016 ************************************************************************
29017 * Tables of average energies/multiplicities.                           *
29018 * This version dated 30.08.2000 is written by S. Roesler               *
29019 ************************************************************************
29020
29021       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29022       SAVE
29023       PARAMETER ( LINP = 10 ,
29024      &            LOUT = 6 ,
29025      &            LDAT = 9 )
29026       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29027
29028       PARAMETER (SWMEXP=1.7D0)
29029
29030       CHARACTER*8 ANAMEH(4)
29031
29032 * particle properties (BAMJET index convention)
29033       CHARACTER*8  ANAME
29034       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29035      &                IICH(210),IIBAR(210),K1(210),K2(210)
29036 * temporary storage for one final state particle
29037       LOGICAL LFRAG,LGREY,LBLACK
29038       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29039      &                SINTHE,COSTHE,THETA,THECMS,
29040      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29041      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29042      &                LFRAG,LGREY,LBLACK
29043 * event flag used for histograms
29044       COMMON /DTNORM/ ICEVT,IEVHKK
29045 * Lorentz-parameters of the current interaction
29046       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
29047      &                UMO,PPCM,EPROJ,PPROJ
29048
29049       PARAMETER (NOPART=210)
29050       DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
29051      &          AVPT(4,NOPART),IAVPT(4,NOPART)
29052       DATA ANAMEH /'DEUTERON','3-H     ','3-HE    ','4-HE    '/
29053
29054       GOTO (1,2,3) MODE
29055
29056 *------------------------------------------------------------------
29057 * initialization
29058     1 CONTINUE
29059       DO 10 I=1,NOPART
29060          DO 11 J=1,4
29061             AVMULT(J,I) = ZERO
29062             AVE(J,I)    = ZERO
29063             AVSWM(J,I)  = ZERO
29064             AVPT(J,I)   = ZERO
29065             IAVPT(J,I)  = 0
29066    11    CONTINUE
29067    10 CONTINUE
29068
29069       RETURN
29070
29071 *------------------------------------------------------------------
29072 * filling of histogram with event-record
29073     2 CONTINUE
29074       IF (PE.LT.0.0D0) THEN
29075          WRITE(LOUT,*) ' HIMULT:  PE < 0 ! ',PE
29076          RETURN
29077       ENDIF
29078       IF (.NOT.LFRAG) THEN
29079          IVEL = 2
29080          IF (LGREY)  IVEL = 3
29081          IF (LBLACK) IVEL = 4
29082          AVE(1,IDBJT)       = AVE(1,IDBJT)   +PE
29083          AVE(IVEL,IDBJT)    = AVE(IVEL,IDBJT)+PE
29084          AVPT(1,IDBJT)     = AVPT(1,IDBJT)   +PT
29085          AVPT(IVEL,IDBJT)  = AVPT(IVEL,IDBJT)+PT
29086          IAVPT(1,IDBJT)    = IAVPT(1,IDBJT)   +1
29087          IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
29088          AVSWM(1,IDBJT)     = AVSWM(1,IDBJT)   +PE**SWMEXP
29089          AVSWM(IVEL,IDBJT)  = AVSWM(IVEL,IDBJT)+PE**SWMEXP
29090          AVMULT(1,IDBJT)    = AVMULT(1,IDBJT)   +ONE
29091          AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
29092          IF (IDBJT.LT.116) THEN
29093 *   total energy, multiplicity
29094             AVE(1,30)       = AVE(1,30)   +PE
29095             AVE(IVEL,30)    = AVE(IVEL,30)+PE
29096             AVPT(1,30)     = AVPT(1,30)   +PT
29097             AVPT(IVEL,30)  = AVPT(IVEL,30)+PT
29098             IAVPT(1,30)    = IAVPT(1,30)   +1
29099             IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
29100             AVSWM(1,30)     = AVSWM(1,30)+PE**SWMEXP
29101             AVSWM(IVEL,30)  = AVSWM(IVEL,30)+PE**SWMEXP
29102             AVMULT(1,30)    = AVMULT(1,30)   +ONE
29103             AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
29104 *   charged energy, multiplicity
29105             IF (ICHAR.LT.0) THEN
29106                AVE(1,26)       = AVE(1,26)   +PE
29107                AVE(IVEL,26)    = AVE(IVEL,26)+PE
29108                AVPT(1,26)     = AVPT(1,26)   +PT
29109                AVPT(IVEL,26)  = AVPT(IVEL,26)+PT
29110                IAVPT(1,26)    = IAVPT(1,26)   +1
29111                IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
29112                AVSWM(1,26)     = AVSWM(1,26)   +PE**SWMEXP
29113                AVSWM(IVEL,26)  = AVSWM(IVEL,26)+PE**SWMEXP
29114                AVMULT(1,26)    = AVMULT(1,26)   +ONE
29115                AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
29116             ENDIF
29117             IF (ICHAR.NE.0) THEN
29118                AVE(1,27)       = AVE(1,27)   +PE
29119                AVE(IVEL,27)    = AVE(IVEL,27)+PE
29120                AVPT(1,27)     = AVPT(1,27)   +PT
29121                AVPT(IVEL,27)  = AVPT(IVEL,27)+PT
29122                IAVPT(1,27)    = IAVPT(1,27)   +1
29123                IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
29124                AVSWM(1,27)     = AVSWM(1,27)   +PE**SWMEXP
29125                AVSWM(IVEL,27)  = AVSWM(IVEL,27)+PE**SWMEXP
29126                AVMULT(1,27)    = AVMULT(1,27)   +ONE
29127                AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
29128             ENDIF
29129          ENDIF
29130       ENDIF
29131
29132       RETURN
29133
29134 *------------------------------------------------------------------
29135 * output
29136     3 CONTINUE
29137       WRITE(LOUT,3000)
29138  3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
29139      &       29X,'---------------------',/)
29140       IF (MULDEF.EQ.1) THEN
29141          WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
29142       ELSE
29143          BETGRE = 0.7D0
29144          BETBLC = 0.23D0
29145          WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
29146  3002    FORMAT(1X,'fast:  beta > ',F4.2,'    grey:  ',F4.2,' > beta > '
29147      &          ,F4.2,'    black:  beta < ',F4.2,/)
29148       ENDIF
29149       WRITE(LOUT,3003) SWMEXP
29150  3003 FORMAT(1X,'particle    |',12X,'average multiplicity',/,
29151      &      13X,'|     total         fast',
29152 C    &      '       grey     black      K      f(',F3.1,')',/,1X,
29153      &      '       grey     black    <pt>     f(',F3.1,')',/,1X,
29154      &      '------------+--------------',
29155      &      '-------------------------------------------------')
29156       DO 30 I=1,NOPART
29157          DO 31 J=1,4
29158             AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
29159             AVE(J,I)    = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
29160             AVPT(J,I)   = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
29161             AVSWM(J,I)  = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
29162    31    CONTINUE
29163          IF (I.LE.115) THEN
29164             WRITE(LOUT,3004) ANAME(I),I,
29165      &                       AVMULT(1,I),AVMULT(2,I),
29166      &                       AVMULT(3,I),AVMULT(4,I),
29167 C    &                       AVE(1,I),AVSWM(1,I)
29168      &                       AVPT(1,I),AVSWM(1,I)
29169          ELSEIF (I.LE.119) THEN
29170             WRITE(LOUT,3004) ANAMEH(I-115),I,
29171      &                       AVMULT(1,I),AVMULT(2,I),
29172      &                       AVMULT(3,I),AVMULT(4,I),
29173 C    &                       AVE(1,I),AVSWM(1,I)
29174      &                       AVPT(1,I),AVSWM(1,I)
29175          ENDIF
29176  3004    FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
29177    30 CONTINUE
29178 **temporary
29179 C     WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
29180 C    &               AVMULT(3,27)+AVMULT(4,27)
29181 **
29182
29183       RETURN
29184       END
29185
29186 *$ CREATE DT_HISTAT.FOR
29187 *COPY DT_HISTAT
29188 *
29189 *===histat=============================================================*
29190 *
29191       SUBROUTINE DT_HISTAT(IDX,MODE)
29192
29193 ************************************************************************
29194 * This version dated 26.02.96 is written by S. Roesler                 *
29195 *                                                                      *
29196 * Last change 27.12.2006 by S. Roesler.                                *
29197 ************************************************************************
29198
29199       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29200       SAVE
29201       PARAMETER ( LINP = 10 ,
29202      &            LOUT = 6 ,
29203      &            LDAT = 9 )
29204       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29205       PARAMETER (NDIM=199)
29206
29207 * event history
29208       PARAMETER (NMXHKK=200000)
29209       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
29210      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
29211      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
29212 * extended event history
29213       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
29214      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
29215      &                IHIST(2,NMXHKK)
29216 * particle properties (BAMJET index convention)
29217       CHARACTER*8  ANAME
29218       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29219      &                IICH(210),IIBAR(210),K1(210),K2(210)
29220       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
29221 * Glauber formalism: cross sections
29222       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
29223      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
29224      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
29225      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
29226      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
29227      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
29228      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
29229      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
29230      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
29231      &                BSLOPE,NEBINI,NQBINI
29232 * emulsion treatment
29233       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
29234      &                NCOMPO,IEMUL
29235 * properties of interacting particles
29236       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
29237 * rejection counter
29238       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
29239      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
29240      &                IREXCI(3),IRDIFF(2),IRINC
29241 * statistics: residual nuclei
29242       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
29243      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
29244      &                NINCST(2,4),NINCEV(2),
29245      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
29246      &                NRESPB(2),NRESCH(2),NRESEV(4),
29247      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
29248      &                NEVAFI(2,2)
29249 * parameter for intranuclear cascade
29250       LOGICAL LPAULI
29251       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
29252 * (original name: PAREVT)
29253       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
29254      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
29255       PARAMETER ( NALLWP = 39   )
29256       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
29257      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
29258      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
29259      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
29260 * (original name: FRBKCM)
29261       PARAMETER ( MXFFBK =     6 )
29262       PARAMETER ( MXZFBK =     9 )
29263       PARAMETER ( MXNFBK =    10 )
29264       PARAMETER ( MXAFBK =    16 )
29265       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
29266       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
29267       PARAMETER ( NXAFBK = MXAFBK + 1 )
29268       PARAMETER ( MXPSST =   300 )
29269       PARAMETER ( MXPSFB = 41000 )
29270       LOGICAL LFRMBK, LNCMSS
29271       COMMON /FKFRBK/  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
29272      &          EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
29273      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
29274      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
29275      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
29276      &          IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
29277      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
29278      &          IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
29279      &          IFBFRB, NBUFBK, LFRMBK, LNCMSS
29280 * (original name: INPFLG)
29281       COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
29282 * temporary storage for one final state particle
29283       LOGICAL LFRAG,LGREY,LBLACK
29284       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29285      &                SINTHE,COSTHE,THETA,THECMS,
29286      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29287      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29288      &                LFRAG,LGREY,LBLACK
29289 * event flag used for histograms
29290       COMMON /DTNORM/ ICEVT,IEVHKK
29291 * statistics: double-Pomeron exchange
29292       COMMON /DTFLG2/ INTFLG,IPOPO
29293
29294       DIMENSION EMUSAM(NCOMPX)
29295
29296       CHARACTER*13 CMSG(3)
29297       DATA CMSG /'not requested','not requested','not requested'/
29298
29299       GOTO (1,2,3,4,5) MODE
29300
29301 *------------------------------------------------------------------
29302 * initialization
29303     1 CONTINUE
29304 *  emulsion treatment
29305       IF (NCOMPO.GT.0) THEN
29306          DO 10 I=1,NCOMPX
29307             EMUSAM(I) = ZERO
29308    10    CONTINUE
29309       ENDIF
29310 * common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
29311       NINCGE = 0
29312       DO 11 I=1,2
29313          EXCDPM(I)   = ZERO
29314          EXCDPM(I+2) = ZERO
29315          EXCEVA(I)   = ZERO
29316          NINCWO(I)   = 0
29317          NINCEV(I)   = 0
29318          NRESTO(I)   = 0
29319          NRESPR(I)   = 0
29320          NRESNU(I)   = 0
29321          NRESBA(I)   = 0
29322          NRESPB(I)   = 0
29323          NRESCH(I)   = 0
29324          NRESEV(I)   = 0
29325          NRESEV(I+2) = 0
29326          NEVAGA(I)   = 0
29327          NEVAHT(I)   = 0
29328          NEVAFI(1,I) = 0
29329          NEVAFI(2,I) = 0
29330          DO 12 J=1,6
29331             IF (J.LE.2) NINCHR(I,J) = 0
29332             IF (J.LE.3) NINCCO(I,J) = 0
29333             IF (J.LE.4) NINCST(I,J) = 0
29334             NEVA(I,J) = 0
29335    12    CONTINUE
29336          DO 13 J=1,210
29337             NEVAHY(1,I,J) = 0
29338             NEVAHY(2,I,J) = 0
29339    13    CONTINUE
29340    11 CONTINUE
29341       MAXGEN = 0
29342 **dble Po statistics.
29343       KPOPO = 0
29344
29345       RETURN
29346 *------------------------------------------------------------------
29347 * filling of histogram with event-record
29348     2 CONTINUE
29349       IF (IST.EQ.-1) THEN
29350          IF (.NOT.LFRAG) THEN
29351             IF (IDPDG.EQ.2212) THEN
29352                NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
29353             ELSEIF (IDPDG.EQ.2112) THEN
29354                NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
29355             ELSEIF (IDPDG.EQ.22) THEN
29356                NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
29357             ELSEIF (IDPDG.EQ.80000) THEN
29358                IF (IDBJT.EQ.116) THEN
29359                   NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
29360                ELSEIF (IDBJT.EQ.117) THEN
29361                   NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
29362                ELSEIF (IDBJT.EQ.118) THEN
29363                   NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
29364                ELSEIF (IDBJT.EQ.119) THEN
29365                   NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
29366                ENDIF
29367             ENDIF
29368          ELSE
29369 *   heavy fragments (here: fission products only)
29370             NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
29371             NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
29372             NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29373          ENDIF
29374       ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
29375          IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
29376       ENDIF
29377
29378       RETURN
29379 *------------------------------------------------------------------
29380 * output
29381     3 CONTINUE
29382
29383 **dble Po statistics.
29384 C     WRITE(LOUT,'(1X,A,2I7,2E12.4)')
29385 C    &   '# evts. / # dble-Po. evts / s_in / s_popo :',
29386 C    & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
29387
29388 *  emulsion treatment
29389       IF (NCOMPO.GT.0) THEN
29390          WRITE(LOUT,3000)
29391  3000    FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
29392      &          22X,'----------------------------',/,/,19X,
29393      &          'mass    charge          fraction',/,39X,
29394      &          'input     treated',/)
29395          DO 30 I=1,NCOMPO
29396             WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
29397      &                       EMUSAM(I)/DBLE(ICEVT)
29398  3013       FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
29399    30    CONTINUE
29400       ENDIF
29401
29402 *  i.n.c. statistics: output
29403       WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
29404  3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
29405      &       22X,'---------------------------------',/,/,1X,
29406      &       'no. of events for normalization: (accepted final events,',
29407      &       ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
29408      &       /,1X,'no. of rejected events due to intranuclear',
29409      &       ' cascade',15X,I6,/)
29410       ICEV  = MAX(ICEVT,1)
29411       ICEV1 = ICEV
29412       IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
29413       WRITE(LOUT,3002)
29414      &     (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
29415      &     ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
29416      &     KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
29417      &    (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29418      &     (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
29419      &     (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29420      &     (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
29421  3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
29422      &       5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
29423      &       ' proj./ target (mean per evt)',/,8X,'baryons:  pos. ',
29424      &       F7.3,' /',F7.3,'   neg. ',F7.3,' /',F7.3,/,8X,
29425      &       'mesons:   pos. ',F7.3,' /',F7.3,'   neg. ',F7.3,' /',F7.3,
29426      &       /,1X,'maximum no. of generations treated (maximum allowed:'
29427      &       ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
29428      &       ' interactions in proj./ target (mean per evt1)',
29429      &       F7.3,' /',F7.3,/,8X,'out of which by inelastic',
29430      &       ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
29431      &       'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
29432      &       '(ap, K-, pi- only)     ',F7.3,' /',F7.3,/)
29433       WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
29434      &                 IREXCI(1)+IREXCI(2)+IREXCI(3)
29435  3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
29436      &       'evaporation',/,22X,'-----------------------------',
29437      &       '------------',/,/,1X,'no. of events for normal.: ',
29438      &       '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
29439      &       ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
29440      &       ' rejected events     (',I4,',',I4,',',I4,')',22X,I6,/)
29441
29442       WRITE(LOUT,3004)
29443  3004 FORMAT(/,22X,'1) before evaporation-step:',/)
29444       ICEV  = MAX(NRESEV(2),1)
29445       WRITE(LOUT,3005)
29446      &     (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
29447      &     (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
29448      &     (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
29449      &     (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
29450      &     (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
29451      &     (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
29452      &     (EXCDPM(I)/DBLE(ICEV),I=1,2),
29453      &     (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
29454  3005    FORMAT(1X,'residual nuclei:  (mean values per evt)',12X,
29455      &       'proj. / target',/,/,8X,'total number of particles',15X,
29456      &       2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29457      &       'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
29458      &       'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
29459      &       /,8X,'excitation energy (bef. evap.-step)   ',2E11.3,/,
29460      &       8X,'excitation energy per nucleon         ',2E11.3,/,/)
29461
29462 * evaporation / fission / fragmentation statistics: output
29463       ICEV  = MAX(NRESEV(2),1)
29464       ICEV1 = MAX(NRESEV(4),1)
29465       NTEVA1 =
29466      &   NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
29467       NTEVA2 =
29468      &   NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
29469       IF (LEVPRT) THEN
29470          IF (IFISS.EQ.1) CMSG(1) = 'requested    '
29471          IF (LFRMBK)     CMSG(2) = 'requested    '
29472          IF (LDEEXG)     CMSG(3) = 'requested    '
29473          WRITE(LOUT,3006)
29474      &        CMSG,
29475      &        DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
29476      &        (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
29477      &        (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
29478      &        (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
29479      &        (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
29480      &        (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
29481      &        (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
29482      &        (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
29483      &        (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
29484  3006    FORMAT(22X,'2) after  evaporation-step:',/,/,1X,'Fission:',
29485      &       13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
29486      &       'deexcitation:',2X,A13,/,/,
29487      &       1X,'evaporation/deexcitation:  (mean values per evt1)  ',
29488      &       'proj. / target',/,/,8X,'total number of evap. particles',
29489      &       9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29490      &       'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
29491      &       '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
29492      &       2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
29493      &       'heavy fragments',25X,2F9.3,/)
29494          IF (IFISS.EQ.1) THEN
29495             WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
29496      &                       NEVAFI(2,1),NEVAFI(2,2),
29497      &             DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
29498      &             DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
29499  3007       FORMAT(1X,'Fission:   total number of events',14X,2I9,/
29500      &             12X,'out of which fission occured',8X,2I9,/,
29501      &             50X,'(',F5.2,'%) (',F5.2,'%)',/)
29502          ENDIF
29503 C        IF ((LFRMBK).OR.(IFISS.EQ.1)) THEN
29504 C           WRITE(LOUT,3008)
29505 C3008       FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
29506 C    &             '       proj.   / target',/)
29507 C           DO 31 I=1,210
29508 C              IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
29509 C                 WRITE(LOUT,3009) I,
29510 C    &            (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29511 C3009             FORMAT(38X,I3,3X,2E12.3)
29512 C              ENDIF
29513 C  31       CONTINUE
29514 C           WRITE(LOUT,3010)
29515 C3010       FORMAT(1X,'heavy fragments - statistics:',7X,'mass  ',
29516 C    &             '       proj.   / target',/)
29517 C           DO 32 I=1,210
29518 C              IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
29519 C                 WRITE(LOUT,3011) I,
29520 C    &            (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29521 C3011             FORMAT(38X,I3,3X,2E12.3)
29522 C              ENDIF
29523 C  32       CONTINUE
29524 C           WRITE(LOUT,*)
29525 C        ENDIF
29526       ELSE
29527          WRITE(LOUT,3012)
29528  3012    FORMAT(22X,'2) after  evaporation-step:',/,/,1X,
29529      &       'Evaporation:         not requested',/)
29530       ENDIF
29531
29532       RETURN
29533 *------------------------------------------------------------------
29534 * filling of histogram with event-record
29535     4 CONTINUE
29536 *  emulsion treatment
29537       IF (NCOMPO.GT.0) THEN
29538          DO 40 I=1,NCOMPO
29539             IF (IT.EQ.IEMUMA(I)) THEN
29540                EMUSAM(I) = EMUSAM(I)+ONE
29541             ENDIF
29542    40    CONTINUE
29543       ENDIF
29544       NINCGE = NINCGE+MAXGEN
29545       MAXGEN = 0
29546 **dble Po statistics.
29547       IF (IPOPO.EQ.1) KPOPO = KPOPO+1
29548
29549       RETURN
29550 *------------------------------------------------------------------
29551 * filling of histogram with event-record
29552     5 CONTINUE
29553       IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
29554          IB = IIBAR(IDBAM(IDX))
29555          IC = IICH(IDBAM(IDX))
29556          J  = ISTHKK(IDX)-14
29557          IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
29558             NINCST(J,1) = NINCST(J,1)+1
29559          ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
29560             NINCST(J,2) = NINCST(J,2)+1
29561          ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
29562             NINCST(J,3) = NINCST(J,3)+1
29563          ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
29564             NINCST(J,4) = NINCST(J,4)+1
29565          ENDIF
29566       ELSEIF (ISTHKK(IDX).EQ.17) THEN
29567          NINCWO(1) = NINCWO(1)+1
29568       ELSEIF (ISTHKK(IDX).EQ.18) THEN
29569          NINCWO(2) = NINCWO(2)+1
29570       ELSEIF (ISTHKK(IDX).EQ.1001) THEN
29571          IB = IDRES(IDX)
29572          IC = IDXRES(IDX)
29573          IF (IC.GT.0) THEN
29574             NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
29575             NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
29576          ENDIF
29577          NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29578       ENDIF
29579
29580       RETURN
29581       END
29582
29583 *$ CREATE DT_NEWHGR.FOR
29584 *COPY DT_NEWHGR
29585 *
29586 *===newhgr=============================================================*
29587 *
29588       SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
29589
29590 ************************************************************************
29591 *                                                                      *
29592 *     Histogram initialization.                                        *
29593 *                                                                      *
29594 *     input:  XLIM1/XLIM2  lower/upper edge of histogram-window        *
29595 *             XLIM3        bin size                                    *
29596 *             IBIN    > 0  number of bins in equidistant lin. binning  *
29597 *                     = -1 reset histograms                            *
29598 *                     < -1 |IBIN| number of bins in equidistant log.   *
29599 *                          binning or log. binning in user def. struc. *
29600 *             XLIMB(*)     user defined bin structure                  *
29601 *                                                                      *
29602 *     The bin structure is sensitive to                                *
29603 *             XLIM1, XLIM3, IBIN     if     XLIM3 > 0   (lin.)         *
29604 *             XLIM1, XLIM2, IBIN     if     XLIM3 = 0   (lin. & log.)  *
29605 *             XLIMB, IBIN            if     XLIM3 < 0                  *
29606 *                                                                      *
29607 *                                                                      *
29608 *     output: IREFN        histogram index                             *
29609 *                          (= -1 for inconsistent histogr. request)    *
29610 *                                                                      *
29611 * This subroutine is based on a original version by R. Engel.          *
29612 * This version dated 22.4.95 is written  by S. Roesler.                *
29613 ************************************************************************
29614
29615       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29616       SAVE
29617       PARAMETER ( LINP = 10 ,
29618      &            LOUT = 6 ,
29619      &            LDAT = 9 )
29620
29621       LOGICAL LSTART
29622
29623       PARAMETER (ZERO   =  0.0D0,
29624      &           TINY   =  1.0D-10)
29625
29626       DIMENSION XLIMB(*)
29627
29628 * histograms
29629       PARAMETER (NHIS=150, NDIM=250)
29630       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29631      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29632 * auxiliary common for histograms
29633       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29634
29635       DATA LSTART /.TRUE./
29636
29637 * reset histogram counter
29638       IF (LSTART.OR.(IBIN.EQ.-1)) THEN
29639          IHISL  = 0
29640          IF (IBIN.EQ.-1) RETURN
29641          LSTART = .FALSE.
29642       ENDIF
29643
29644       IHIS  = IHISL+1
29645 * check for maximum number of allowed histograms
29646       IF (IHIS.GT.NHIS) THEN
29647          WRITE(LOUT,1003) IHIS,NHIS,IHIS
29648  1003    FORMAT(1X,'NEWHGR:   warning!  number of histograms (',
29649      &          I4,') exceeds array size (',I4,')',/,21X,
29650      &          'histogram',I3,' skipped!')
29651          GOTO 9999
29652       ENDIF
29653
29654       IREFN = IHIS
29655       IBINS(IHIS) = ABS(IBIN)
29656 * check requested number of bins
29657       IF (IBINS(IHIS).GE.NDIM) THEN
29658          WRITE(LOUT,1000) IBIN,NDIM,NDIM
29659  1000    FORMAT(1X,'NEWHGR:   warning!  number of bins (',
29660      &          I3,') exceeds array size (',I3,')',/,21X,
29661      &          'and will be reset to ',I3)
29662          IBINS(IHIS) = NDIM
29663       ENDIF
29664       IF (IBINS(IHIS).EQ.0) THEN
29665          WRITE(LOUT,1001) IBIN,IHIS
29666  1001    FORMAT(1X,'NEWHGR:   warning!  inconsistent number of',
29667      &          ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
29668          GOTO 9999
29669       ENDIF
29670
29671 * initialize arrays
29672       DO 1 I=1,NDIM
29673          DO 2 K=1,3
29674             HIST(K,IHIS,I)   = ZERO
29675             HIST(K+3,IHIS,I) = ZERO
29676             TMPHIS(K,IHIS,I) = ZERO
29677     2    CONTINUE
29678          HIST(7,IHIS,I)   = ZERO
29679     1 CONTINUE
29680       DENTRY(1,IHIS)= ZERO
29681       DENTRY(2,IHIS)= ZERO
29682       OVERF(IHIS)   = ZERO
29683       UNDERF(IHIS)  = ZERO
29684       TMPUFL(IHIS)  = ZERO
29685       TMPOFL(IHIS)  = ZERO
29686
29687 * bin str. sensitive to lower edge, bin size, and numb. of bins
29688       IF (XLIM3.GT.ZERO) THEN
29689          DO 3 K=1,IBINS(IHIS)+1
29690             HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
29691     3    CONTINUE
29692          ISWI(IHIS) = 1
29693 * bin str. sensitive to lower/upper edge and numb. of bins
29694       ELSEIF (XLIM3.EQ.ZERO) THEN
29695 *   linear binning
29696          IF (IBIN.GT.0) THEN
29697             XLOW = XLIM1
29698             XHI  = XLIM2
29699             IF (XLIM2.LE.XLIM1) THEN
29700                WRITE(LOUT,1002) XLIM1,XLIM2
29701  1002          FORMAT(1X,'NEWHGR:   warning!  inconsistent x-range',
29702      &                /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29703                GOTO 9999
29704             ENDIF
29705             ISWI(IHIS) = 1
29706          ELSEIF (IBIN.LT.-1) THEN
29707 *   logarithmic binning
29708             IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
29709                WRITE(LOUT,1004) XLIM1,XLIM2
29710  1004          FORMAT(1X,'NEWHGR:   warning!  inconsistent log. ',
29711      &                'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29712                GOTO 9999
29713             ENDIF
29714             IF (XLIM2.LE.XLIM1) THEN
29715                WRITE(LOUT,1005) XLIM1,XLIM2
29716  1005          FORMAT(1X,'NEWHGR:   warning!  inconsistent x-range',
29717      &                /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29718                GOTO 9999
29719             ENDIF
29720             XLOW = LOG10(XLIM1)
29721             XHI  = LOG10(XLIM2)
29722             ISWI(IHIS) = 3
29723          ENDIF
29724          DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
29725          DO 4 K=1,IBINS(IHIS)+1
29726             HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
29727     4    CONTINUE
29728       ELSE
29729 * user defined bin structure
29730          DO 5 K=1,IBINS(IHIS)+1
29731             IF (IBIN.GT.0) THEN
29732                HIST(1,IHIS,K) = XLIMB(K)
29733                ISWI(IHIS) = 2
29734             ELSEIF (IBIN.LT.-1) THEN
29735                HIST(1,IHIS,K) = LOG10(XLIMB(K))
29736                ISWI(IHIS) = 4
29737             ENDIF
29738     5    CONTINUE
29739       ENDIF
29740
29741 * histogram accepted
29742       IHISL = IHIS
29743
29744       RETURN
29745
29746  9999 CONTINUE
29747       IREFN = -1
29748       RETURN
29749       END
29750
29751 *$ CREATE DT_FILHGR.FOR
29752 *COPY DT_FILHGR
29753 *
29754 *===filhgr=============================================================*
29755 *
29756       SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
29757
29758 ************************************************************************
29759 *                                                                      *
29760 *     Scoring for histogram IHIS.                                      *
29761 *                                                                      *
29762 * This subroutine is based on a original version by R. Engel.          *
29763 * This version dated 23.4.95 is written  by S. Roesler.                *
29764 ************************************************************************
29765
29766       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29767       SAVE
29768       PARAMETER ( LINP = 10 ,
29769      &            LOUT = 6 ,
29770      &            LDAT = 9 )
29771
29772       PARAMETER (ZERO = 0.0D0,
29773      &           ONE  = 1.0D0,
29774      &           TINY = 1.0D-10)
29775
29776 * histograms
29777       PARAMETER (NHIS=150, NDIM=250)
29778       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29779      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29780 * auxiliary common for histograms
29781       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29782
29783       DATA NCEVT /1/
29784
29785       X = XI
29786       Y = YI
29787
29788 * dump content of temorary arrays into histograms
29789       IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
29790          CALL DT_EVTHIS(IDUM)
29791          NCEVT = NEVT
29792       ENDIF
29793
29794 * check histogram index
29795       IF (IHIS.EQ.-1) RETURN
29796       IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
29797 C        WRITE(LOUT,1000) IHIS,IHISL
29798  1000    FORMAT(1X,'FILHGR:   warning!  histogram index',I4,
29799      &          ' out of range (1..',I3,')')
29800          RETURN
29801       ENDIF
29802
29803       IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
29804 * bin structure not explicitly given
29805          IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
29806          DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
29807          IF (X.LT.HIST(1,IHIS,1)) THEN
29808             I1 = 0
29809          ELSE
29810             I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
29811          ENDIF
29812
29813       ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
29814 * user defined bin structure
29815          IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
29816          IF (X.LT.HIST(1,IHIS,1)) THEN
29817             I1 = 0
29818          ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
29819             I1 = IBINS(IHIS)+1
29820          ELSE
29821 *   binary sort algorithm
29822             KMIN = 0
29823             KMAX = IBINS(IHIS)+1
29824     1       CONTINUE
29825             IF ((KMAX-KMIN).EQ.1) GOTO 2
29826             KK = (KMAX+KMIN)/2
29827             IF (X.LE.HIST(1,IHIS,KK)) THEN
29828                KMAX=KK
29829             ELSE
29830                KMIN=KK
29831             ENDIF
29832             GOTO 1
29833     2       CONTINUE
29834             I1 = KMIN
29835          ENDIF
29836
29837       ELSE
29838          WRITE(LOUT,1001)
29839  1001    FORMAT(1X,'FILHGR:   warning!  histogram not initialized')
29840          RETURN
29841       ENDIF
29842
29843 * scoring
29844       IF (I1.LE.0) THEN
29845          TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
29846       ELSEIF (I1.LE.IBINS(IHIS)) THEN
29847          TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
29848          IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
29849             TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
29850          ELSE
29851             TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
29852          ENDIF
29853          TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
29854       ELSE
29855          TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
29856       ENDIF
29857
29858       RETURN
29859       END
29860
29861 *$ CREATE DT_EVTHIS.FOR
29862 *COPY DT_EVTHIS
29863 *
29864 *===evthis=============================================================*
29865 *
29866       SUBROUTINE DT_EVTHIS(NEVT)
29867
29868 ************************************************************************
29869 * Dump content of temorary histograms into /DTHIS1/. This subroutine   *
29870 * is called after each event and for the last event before any call    *
29871 * to OUTHGR.                                                           *
29872 *         NEVT   number of events dumped, this is only needed to       *
29873 *                get the normalization after the last event            *
29874 * This version dated 23.4.95 is written  by S. Roesler.                *
29875 ************************************************************************
29876
29877       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29878       SAVE
29879       PARAMETER ( LINP = 10 ,
29880      &            LOUT = 6 ,
29881      &            LDAT = 9 )
29882
29883       LOGICAL LNOETY
29884
29885       PARAMETER (ZERO = 0.0D0,
29886      &           ONE  = 1.0D0,
29887      &           TINY = 1.0D-10)
29888
29889 * histograms
29890       PARAMETER (NHIS=150, NDIM=250)
29891       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29892      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29893 * auxiliary common for histograms
29894       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29895
29896       DATA NCEVT /0/
29897
29898       NCEVT = NCEVT+1
29899       NEVT  = NCEVT
29900
29901       DO 1 I=1,IHISL
29902          LNOETY = .TRUE.
29903          DO 2 J=1,IBINS(I)
29904             IF (TMPHIS(1,I,J).GT.ZERO) THEN
29905                LNOETY = .FALSE.
29906                HIST(2,I,J)   = HIST(2,I,J)+ONE
29907                HIST(7,I,J)   = HIST(7,I,J)+TMPHIS(1,I,J)
29908                DENTRY(2,I)   = DENTRY(2,I)+TMPHIS(1,I,J)
29909                AVX           = TMPHIS(2,I,J)/TMPHIS(1,I,J)
29910                HIST(3,I,J)   = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
29911                HIST(4,I,J)   = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
29912                HIST(5,I,J)   = HIST(5,I,J)+TMPHIS(3,I,J)
29913                HIST(6,I,J)   = HIST(6,I,J)+TMPHIS(3,I,J)**2
29914                TMPHIS(1,I,J) = ZERO
29915                TMPHIS(2,I,J) = ZERO
29916                TMPHIS(3,I,J) = ZERO
29917             ENDIF
29918     2    CONTINUE
29919          IF (LNOETY) THEN
29920             IF (TMPUFL(I).GT.ZERO) THEN
29921                UNDERF(I) = UNDERF(I)+ONE
29922                TMPUFL(I) = ZERO
29923             ELSEIF (TMPOFL(I).GT.ZERO) THEN
29924                OVERF(I)  = OVERF(I)+ONE
29925                TMPOFL(I) = ZERO
29926             ENDIF
29927          ELSE
29928             DENTRY(1,I) = DENTRY(1,I)+ONE
29929          ENDIF
29930     1 CONTINUE
29931
29932       RETURN
29933       END
29934
29935 *$ CREATE DT_OUTHGR.FOR
29936 *COPY DT_OUTHGR
29937 *
29938 *===outhgr=============================================================*
29939 *
29940       SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
29941      &                  ILOGY,INORM,NMODE)
29942
29943 ************************************************************************
29944 *                                                                      *
29945 *     Plot histogram(s) to standard output unit                        *
29946 *                                                                      *
29947 *         I1..6         indices of histograms to be plotted            *
29948 *         CHEAD,IHEAD   header string,integer                          *
29949 *         NEVTS         number of events                               *
29950 *         FAC           scaling factor                                 *
29951 *         ILOGY   = 1   logarithmic y-axis                             *
29952 *         INORM         normalization                                  *
29953 *                 = 0   no further normalization (FAC is obsolete)     *
29954 *                 = 1   per event and bin width                        *
29955 *                 = 2   per entry and bin width                        *
29956 *                 = 3   per bin entry                                  *
29957 *                 = 4   per event and "bin width" x1^2...x2^2          *
29958 *                 = 5   per event and "log. bin width" ln x1..ln x2    *
29959 *                 = 6   per event                                      *
29960 *         MODE    = 0   no output but normalization applied            *
29961 *                 = 1   all valid histograms separately (small frame)  *
29962 *                       all valid histograms separately (small frame)  *
29963 *                 = -1  and tables as histograms                       *
29964 *                 = 2   all valid histograms (one plot, wide frame)    *
29965 *                       all valid histograms (one plot, wide frame)    *
29966 *                 = -2  and tables as histograms                       *
29967 *                                                                      *
29968 *                                                                      *
29969 *     Note: All histograms to be plotted with one call to this         *
29970 *           subroutine and |MODE|=2 must have the same bin structure!  *
29971 *           There is no test included ensuring this fact.              *
29972 *                                                                      *
29973 * This version dated 23.4.95 is written  by S. Roesler.                *
29974 ************************************************************************
29975
29976       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29977       SAVE
29978       PARAMETER ( LINP = 10 ,
29979      &            LOUT = 6 ,
29980      &            LDAT = 9 )
29981
29982       CHARACTER*72 CHEAD
29983
29984       PARAMETER (ZERO   =  0.0D0,
29985      &           IZERO  =  0,
29986      &           ONE    =  1.0D0,
29987      &           TWO    =  2.0D0,
29988      &           OHALF  =  0.5D0,
29989      &           EPS    =  1.0D-5,
29990      &           TINY   =  1.0D-8,
29991      &           SMALL  =  -1.0D8,
29992      &           RLARGE =  1.0D8 )
29993
29994 * histograms
29995       PARAMETER (NHIS=150, NDIM=250)
29996       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29997      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29998
29999       PARAMETER (NDIM2 = 2*NDIM)
30000       DIMENSION XX(NDIM2),YY(NDIM2)
30001
30002       PARAMETER (NHISTO = 6)
30003       DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
30004      &          IDX(NHISTO)
30005
30006       CHARACTER*43 CNORM(0:8)
30007       DATA CNORM /'no further normalization                   ',
30008      &            'per event and bin width                    ',
30009      &            'per entry1 and bin width                   ',
30010      &            'per bin entry                              ',
30011      &            'per event and "bin width" x1^2...x2^2      ',
30012      &            'per event and "log. bin width" ln x1..ln x2',
30013      &            'per event                                  ',
30014      &            'per bin entry1                             ',
30015      &            'per entry2 and bin width                   '/
30016
30017       IDX1(1) = I1
30018       IDX1(2) = I2
30019       IDX1(3) = I3
30020       IDX1(4) = I4
30021       IDX1(5) = I5
30022       IDX1(6) = I6
30023
30024       MODE = NMODE
30025
30026 * initialization if "wide frame" is requested
30027       IF (ABS(MODE).EQ.2) THEN
30028          DO 1 I=1,NHISTO
30029             DO 2 J=1,NDIM
30030                XX1(J,I) = ZERO
30031                YY1(J,I) = ZERO
30032     2       CONTINUE
30033     1    CONTINUE
30034       ENDIF
30035
30036 * plot header
30037       WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
30038
30039 * check histogram indices
30040       NHI = 0
30041       DO 3 I=1,NHISTO
30042          IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
30043             IF (ISWI(IDX1(I)).NE.0) THEN
30044                IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
30045                   WRITE(LOUT,1000)
30046      &                 IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
30047  1000             FORMAT(/,1X,'OUTHGR:   warning!  no entries in',
30048      &                   ' histogram ',I3,/,21X,'underflows:',F10.0,
30049      &                   '   overflows:  ',F10.0)
30050                ELSE
30051                   NHI = NHI+1
30052                   IDX(NHI) = IDX1(I)
30053                ENDIF
30054             ENDIF
30055          ENDIF
30056     3 CONTINUE
30057       IF (NHI.EQ.0) THEN
30058          WRITE(LOUT,1001)
30059  1001    FORMAT(/,1X,'OUTHGR:   warning!  histogram indices not valid')
30060          RETURN
30061       ENDIF
30062
30063 * check normalization request
30064       IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
30065      &     ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
30066      &                        (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
30067      &     (INORM.LT.0).OR.(INORM.GT.8) ) THEN
30068          WRITE(LOUT,1002) NEVTS,INORM,FAC
30069  1002    FORMAT(/,1X,'OUTHGR:   warning!  normalization request not ',
30070      &          'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
30071      &          'FAC = ',E11.4)
30072          RETURN
30073       ENDIF
30074
30075       WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
30076
30077 * apply normalization
30078       DO 4 N=1,NHI
30079
30080          I = IDX(N)
30081
30082          IF (ISWI(I).EQ.1) THEN
30083             WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30084  1003       FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
30085      &             ' to',2X,E10.4,',',2X,I3,' bins')
30086          ELSEIF (ISWI(I).EQ.2) THEN
30087             WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30088             WRITE(LOUT,1007)
30089  1007       FORMAT(1X,'user defined bin structure')
30090          ELSEIF (ISWI(I).EQ.3) THEN
30091             WRITE(LOUT,1004)
30092      &         I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30093  1004       FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
30094      &             ' to',2X,E10.4,',',2X,I3,' bins')
30095          ELSEIF (ISWI(I).EQ.4) THEN
30096             WRITE(LOUT,1004)
30097      &         I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30098             WRITE(LOUT,1007)
30099          ELSE
30100             WRITE(LOUT,1008) ISWI(I)
30101  1008       FORMAT(/,1X,'warning!  inconsistent bin structure flag ',I4)
30102          ENDIF
30103          WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
30104  1005    FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
30105      &          ' overfl.:',F8.0)
30106          WRITE(LOUT,1009) CNORM(INORM)
30107  1009    FORMAT(1X,'normalization: ',A,/)
30108
30109          DO 5 K=1,IBINS(I)
30110             CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
30111             YMEAN = FAC*YMEAN
30112             YERR  = FAC*YERR
30113             WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
30114             WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
30115  1006       FORMAT(1X,5E11.3)
30116 *    small frame
30117             II = 2*K
30118             XX(II-1) = HIST(1,I,K)
30119             XX(II)   = HIST(1,I,K+1)
30120             YY(II-1) = YMEAN
30121             YY(II)   = YMEAN
30122 *    wide frame
30123             XX1(K,N) = XMEAN
30124             IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
30125      &         XX1(K,N) = LOG10(XMEAN)
30126             YY1(K,N) = YMEAN
30127     5    CONTINUE
30128
30129 * plot small frame
30130          IF (ABS(MODE).EQ.1) THEN
30131             IBIN2 = 2*IBINS(I)
30132             WRITE(LOUT,'(/,1X,A)') 'Preview:'
30133             IF(ILOGY.EQ.1) THEN
30134               CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30135             ELSE
30136               CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30137             ENDIF
30138          ENDIF
30139
30140     4 CONTINUE
30141
30142 * plot wide frame
30143       IF (ABS(MODE).EQ.2) THEN
30144          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30145          NSIZE = NDIM*NHISTO
30146          DXLOW = HIST(1,IDX(1),1)
30147          DDX   = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
30148          YLOW  = RLARGE
30149          YHI   = SMALL
30150          DO 6 I=1,NHISTO
30151             DO 7 J=1,NDIM
30152                IF (YY1(J,I).LT.YLOW) THEN
30153                   IF (ILOGY.EQ.1) THEN
30154                      IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
30155                   ELSE
30156                      YLOW = YY1(J,I)
30157                   ENDIF
30158                ENDIF
30159                IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
30160     7       CONTINUE
30161     6    CONTINUE
30162          DY = (YHI-YLOW)/DBLE(NDIM)
30163          IF (DY.LE.ZERO) THEN
30164             WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
30165      &         'OUTHGR:   warning! zero bin width for histograms ',
30166      &         IDX,': ',YLOW,YHI
30167             RETURN
30168          ENDIF
30169          IF (ILOGY.EQ.1) THEN
30170             YLOW = LOG10(YLOW)
30171             DY   = (LOG10(YHI)-YLOW)/100.0D0
30172             DO 8 I=1,NHISTO
30173                DO 9 J=1,NDIM
30174                   IF (YY1(J,I).LE.ZERO) THEN
30175                      YY1(J,I) = YLOW
30176                   ELSE
30177                      YY1(J,I) = LOG10(YY1(J,I))
30178                   ENDIF
30179     9          CONTINUE
30180     8       CONTINUE
30181          ENDIF
30182          CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
30183       ENDIF
30184
30185       RETURN
30186       END
30187
30188 *$ CREATE DT_GETBIN.FOR
30189 *COPY DT_GETBIN
30190 *
30191 *===getbin=============================================================*
30192 *
30193       SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
30194      &                  XMEAN,YMEAN,YERR)
30195
30196 ************************************************************************
30197 * This version dated 23.4.95 is written  by S. Roesler.                *
30198 ************************************************************************
30199
30200       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30201       SAVE
30202       PARAMETER ( LINP = 10 ,
30203      &            LOUT = 6 ,
30204      &            LDAT = 9 )
30205
30206       PARAMETER (ZERO   = 0.0D0,
30207      &           ONE    = 1.0D0,
30208      &           TINY35 = 1.0D-35)
30209
30210 * histograms
30211       PARAMETER (NHIS=150, NDIM=250)
30212       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30213      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30214
30215       XLOW = HIST(1,IHIS,IBIN)
30216       XHI  = HIST(1,IHIS,IBIN+1)
30217       IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
30218          XLOW = 10**XLOW
30219          XHI  = 10**XHI
30220       ENDIF
30221       IF (NORM.EQ.2) THEN
30222          DX   = XHI-XLOW
30223          NEVT = INT(DENTRY(1,IHIS))
30224       ELSEIF (NORM.EQ.3) THEN
30225          DX   = ONE
30226          NEVT = INT(HIST(2,IHIS,IBIN))
30227       ELSEIF (NORM.EQ.4) THEN
30228          DX   = XHI**2-XLOW**2
30229          NEVT = KEVT
30230       ELSEIF (NORM.EQ.5) THEN
30231          DX   = LOG(ABS(XHI))-LOG(ABS(XLOW))
30232          NEVT = KEVT
30233       ELSEIF (NORM.EQ.6) THEN
30234          DX   = ONE
30235          NEVT = KEVT
30236       ELSEIF (NORM.EQ.7) THEN
30237          DX   = ONE
30238          NEVT = INT(HIST(7,IHIS,IBIN))
30239       ELSEIF (NORM.EQ.8) THEN
30240          DX   = XHI-XLOW
30241          NEVT = INT(DENTRY(2,IHIS))
30242       ELSE
30243          DX   = ABS(XHI-XLOW)
30244          NEVT = KEVT
30245       ENDIF
30246       IF (ABS(DX).LT.TINY35) DX = ONE
30247       NEVT   = MAX(NEVT,1)
30248       YMEAN  = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
30249       YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
30250       YERR   = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
30251       YSUM   = HIST(5,IHIS,IBIN)
30252       IF (ABS(YSUM).LT.TINY35) YSUM = ONE
30253 C     XMEAN  = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
30254       XMEAN  = HIST(3,IHIS,IBIN)/YSUM
30255       IF (XMEAN.EQ.ZERO) XMEAN = XLOW
30256
30257       RETURN
30258       END
30259
30260 *$ CREATE DT_JOIHIS.FOR
30261 *COPY DT_JOIHIS
30262 *
30263 *===joihis=============================================================*
30264 *
30265       SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
30266
30267 ************************************************************************
30268 *                                                                      *
30269 *     Operation on histograms.                                         *
30270 *                                                                      *
30271 *     input:  IH1,IH2      histogram indices to be joined              *
30272 *             COPER        character defining the requested operation, *
30273 *                          i.e. '+', '-', '*', '/'                     *
30274 *             FAC1,FAC2    factors for joining, i.e.                   *
30275 *                          FAC1*histo1 COPER FAC2*histo2               *
30276 *                                                                      *
30277 * This version dated 23.4.95 is written  by S. Roesler.                *
30278 ************************************************************************
30279
30280       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30281       SAVE
30282       PARAMETER ( LINP = 10 ,
30283      &            LOUT = 6 ,
30284      &            LDAT = 9 )
30285
30286       CHARACTER COPER*1
30287
30288       PARAMETER (ZERO   =  0.0D0,
30289      &           ONE    =  1.0D0,
30290      &           OHALF  =  0.5D0,
30291      &           TINY8  =  1.0D-8,
30292      &           SMALL  =  -1.0D8,
30293      &           RLARGE =  1.0D8 )
30294
30295 * histograms
30296       PARAMETER (NHIS=150, NDIM=250)
30297       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30298      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30299
30300       PARAMETER (NDIM2 = 2*NDIM)
30301       DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
30302
30303       CHARACTER*43 CNORM(0:6)
30304       DATA CNORM /'no further normalization                   ',
30305      &            'per event and bin width                    ',
30306      &            'per entry and bin width                    ',
30307      &            'per bin entry                              ',
30308      &            'per event and "bin width" x1^2...x2^2      ',
30309      &            'per event and "log. bin width" ln x1..ln x2',
30310      &            'per event                                  '/
30311
30312 * check histogram indices
30313       IF ((IH1.LT.    1).OR.(IH2.LT.    1).OR.
30314      &    (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
30315          WRITE(LOUT,1000) IH1,IH2,IHISL
30316  1000    FORMAT(1X,'JOIHIS:   warning!  inconsistent histogram ',
30317      &          'indices (',I3,',',I3,'),',/,21X,'valid range:  1,',I3)
30318          GOTO 9999
30319       ENDIF
30320
30321 * check bin structure of histograms to be joined
30322       IF (IBINS(IH1).NE.IBINS(IH2)) THEN
30323          WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
30324  1001    FORMAT(1X,'JOIHIS:   warning!  joining histograms ',I3,
30325      &          ' and ',I3,' failed',/,21X,
30326      &          'due to different numbers of bins (',I3,',',I3,')')
30327          GOTO 9999
30328       ENDIF
30329       DO 1 K=1,IBINS(IH1)+1
30330          IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
30331             WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
30332  1002       FORMAT(1X,'JOIHIS:   warning!  joining histograms ',I3,
30333      &             ' and ',I3,' failed at bin edge ',I3,/,21X,
30334      &             'X1,X2 = ',2E11.4)
30335             GOTO 9999
30336          ENDIF
30337     1 CONTINUE
30338
30339       WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
30340  1003 FORMAT(1X,'JOIHIS:   joining histograms ',I3,',',I3,' with ',
30341      &       'operation ',A,/,11X,'and factors ',2E11.4)
30342       WRITE(LOUT,1004) CNORM(NORM)
30343  1004 FORMAT(1X,'normalization: ',A,/)
30344
30345       DO 2 K=1,IBINS(IH1)
30346          CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
30347          CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
30348          XLOW  = XLOW1
30349          XHI   = XHI1
30350          XMEAN = OHALF*(XMEAN1+XMEAN2)
30351          IF (COPER.EQ.'+') THEN
30352             YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
30353          ELSEIF (COPER.EQ.'*') THEN
30354             YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
30355          ELSEIF (COPER.EQ.'/') THEN
30356             IF (YMEAN2.EQ.ZERO) THEN
30357                YMEAN = ZERO
30358             ELSE
30359                IF (FAC2.EQ.ZERO) FAC2 = ONE
30360                YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
30361             ENDIF
30362          ELSE
30363             GOTO 9998
30364          ENDIF
30365          WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30366          WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30367  1006    FORMAT(1X,5E11.3)
30368 *    small frame
30369          II = 2*K
30370          XX(II-1) = HIST(1,IH1,K)
30371          XX(II)   = HIST(1,IH1,K+1)
30372          YY(II-1) = YMEAN
30373          YY(II)   = YMEAN
30374 *    wide frame
30375          XX1(K) = XMEAN
30376          IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
30377          YY1(K) = YMEAN
30378     2 CONTINUE
30379
30380 * plot small frame
30381       IF (ABS(MODE).EQ.1) THEN
30382          IBIN2 = 2*IBINS(IH1)
30383          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30384          IF(ILOGY.EQ.1) THEN
30385            CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30386          ELSE
30387            CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30388          ENDIF
30389       ENDIF
30390
30391 * plot wide frame
30392       IF (ABS(MODE).EQ.2) THEN
30393          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30394          NSIZE = NDIM
30395          DXLOW = HIST(1,IH1,1)
30396          DDX   = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
30397          YLOW  = RLARGE
30398          YHI   = SMALL
30399          DO 3 I=1,NDIM
30400             IF (YY1(I).LT.YLOW) THEN
30401                IF (ILOGY.EQ.1) THEN
30402                   IF (YY1(I).GT.ZERO) YLOW = YY1(I)
30403                ELSE
30404                   YLOW = YY1(I)
30405                ENDIF
30406             ENDIF
30407             IF (YY1(I).GT.YHI) YHI = YY1(I)
30408     3    CONTINUE
30409          DY = (YHI-YLOW)/DBLE(NDIM)
30410          IF (DY.LE.ZERO) THEN
30411             WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
30412      &         'JOIHIS:   warning! zero bin width for histograms ',
30413      &         IH1,IH2,': ',YLOW,YHI
30414             RETURN
30415          ENDIF
30416          IF (ILOGY.EQ.1) THEN
30417             YLOW = LOG10(YLOW)
30418             DY   = (LOG10(YHI)-YLOW)/100.0D0
30419             DO 4 I=1,NDIM
30420                IF (YY1(I).LE.ZERO) THEN
30421                   YY1(I) = YLOW
30422                ELSE
30423                   YY1(I) = LOG10(YY1(I))
30424                ENDIF
30425     4       CONTINUE
30426          ENDIF
30427          CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
30428       ENDIF
30429
30430       RETURN
30431
30432  9998 CONTINUE
30433       WRITE(LOUT,1005) COPER
30434  1005 FORMAT(1X,'JOIHIS:   unknown operation ',A)
30435
30436  9999 CONTINUE
30437       RETURN
30438       END
30439
30440 *$ CREATE DT_XGRAPH.FOR
30441 *COPY DT_XGRAPH
30442 *
30443 *===qgraph=============================================================*
30444 *
30445       SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
30446 C***********************************************************************
30447 C
30448 C     calculate quasi graphic picture with 25 lines and 79 columns
30449 C     ranges will be chosen automatically
30450 C
30451 C     input     N          dimension of input fields
30452 C               IARG       number of curves (fields) to plot
30453 C               X          field of X
30454 C               Y1         field of Y1
30455 C               Y2         field of Y2
30456 C
30457 C This subroutine is written by R. Engel.
30458 C***********************************************************************
30459       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30460       SAVE
30461
30462       PARAMETER ( LINP = 10 ,
30463      &            LOUT = 6 ,
30464      &            LDAT = 9 )
30465 C
30466       DIMENSION X(N),Y1(N),Y2(N)
30467       PARAMETER (EPS=1.D-30)
30468       PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30469       CHARACTER SYMB(5)
30470       CHARACTER COL(0:149,0:49)
30471 C
30472       DATA SYMB /'0','e','z','#','x'/
30473 C
30474       ISPALT=IBREIT-10
30475 C
30476 C***  automatic range fitting
30477 C
30478       XMAX=X(1)
30479       XMIN=X(1)
30480       DO 600 I=1,N
30481          XMAX=MAX(X(I),XMAX)
30482          XMIN=MIN(X(I),XMIN)
30483  600  CONTINUE
30484       XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30485 C
30486       ITEST=0
30487       DO 1100 K=0,IZEIL-1
30488          ITEST=ITEST+1
30489          IF (ITEST.EQ.IYRAST) THEN
30490             DO 1010 L=1,ISPALT-1
30491                COL(L,K)='-'
30492 1010        CONTINUE
30493             COL(ISPALT,K)='+'
30494             ITEST=0
30495             DO 1020 L=0,ISPALT-1,IXRAST
30496                COL(L,K)='+'
30497 1020        CONTINUE
30498          ELSE
30499             DO 1030 L=1,ISPALT-1
30500                COL(L,K)=' '
30501 1030        CONTINUE
30502             DO 1040 L=0,ISPALT-1,IXRAST
30503                COL(L,K)='|'
30504 1040        CONTINUE
30505             COL(ISPALT,K)='|'
30506          ENDIF
30507 1100  CONTINUE
30508 C
30509 C***  plot curve Y1
30510 C
30511       YMAX=Y1(1)
30512       YMIN=Y1(1)
30513       DO 500 I=1,N
30514          YMAX=MAX(Y1(I),YMAX)
30515          YMIN=MIN(Y1(I),YMIN)
30516 500   CONTINUE
30517       IF(IARG.GT.1) THEN
30518         DO 550 I=1,N
30519            YMAX=MAX(Y2(I),YMAX)
30520            YMIN=MIN(Y2(I),YMIN)
30521 550     CONTINUE
30522       ENDIF
30523       YMAX=(YMAX-YMIN)/40.0D0+YMAX
30524       YMIN=YMIN-(YMAX-YMIN)/40.0D0
30525       YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
30526       IF(YZOOM.LT.EPS) THEN
30527         WRITE(LOUT,'(1X,A)')
30528      &    'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30529         RETURN
30530       ENDIF
30531 C
30532 C***  plot curve Y1
30533 C
30534       ILAST=-1
30535       LLAST=-1
30536       DO 1200 K=1,N
30537          L=NINT((X(K)-XMIN)/XZOOM)
30538          I=NINT((YMAX-Y1(K))/YZOOM)
30539          IF(ILAST.GE.0) THEN
30540            LD = L-LLAST
30541            ID = I-ILAST
30542            DO 55 II=0,LD,SIGN(1,LD)
30543              DO 66 KK=0,ID,SIGN(1,ID)
30544                COL(II+LLAST,KK+ILAST)=SYMB(1)
30545  66          CONTINUE
30546  55        CONTINUE
30547          ELSE
30548            COL(L,I)=SYMB(1)
30549          ENDIF
30550          ILAST = I
30551          LLAST = L
30552 1200  CONTINUE
30553 C
30554       IF(IARG.GT.1) THEN
30555 C
30556 C***  plot curve Y2
30557 C
30558         DO 1250 K=1,N
30559            L=NINT((X(K)-XMIN)/XZOOM)
30560            I=NINT((YMAX-Y2(K))/YZOOM)
30561            COL(L,I)=SYMB(2)
30562 1250    CONTINUE
30563       ENDIF
30564 C
30565 C***  write it
30566 C
30567       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30568 C
30569 C***  write range of X
30570 C
30571       XZOOM = (XMAX-XMIN)/DBLE(7)
30572       WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30573 C
30574       DO 1300 K=0,IZEIL-1
30575          YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
30576          WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30577  110     FORMAT(1X,1PE9.2,70A1)
30578 1300  CONTINUE
30579 C
30580 C***  write range of X
30581 C
30582       XZOOM = (XMAX-XMIN)/DBLE(7)
30583       WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30584       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30585  120  FORMAT(6X,7(1PE10.3))
30586       END
30587
30588 *$ CREATE DT_XGLOGY.FOR
30589 *COPY DT_XGLOGY
30590 *
30591 *===qglogy=============================================================*
30592 *
30593       SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
30594 C***********************************************************************
30595 C
30596 C     calculate quasi graphic picture with 25 lines and 79 columns
30597 C     logarithmic y axis
30598 C     ranges will be chosen automatically
30599 C
30600 C     input     N          dimension of input fields
30601 C               IARG       number of curves (fields) to plot
30602 C               X          field of X
30603 C               Y1         field of Y1
30604 C               Y2         field of Y2
30605 C
30606 C This subroutine is written by R. Engel.
30607 C***********************************************************************
30608 C
30609       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30610       SAVE
30611
30612       PARAMETER ( LINP = 10 ,
30613      &            LOUT = 6 ,
30614      &            LDAT = 9 )
30615       DIMENSION X(N),Y1(N),Y2(N)
30616       PARAMETER (EPS=1.D-30)
30617       PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30618       CHARACTER SYMB(5)
30619       CHARACTER COL(0:149,0:49)
30620       PARAMETER (DEPS = 1.D-10)
30621 C
30622       DATA SYMB /'0','e','z','#','x'/
30623 C
30624       ISPALT=IBREIT-10
30625 C
30626 C***  automatic range fitting
30627 C
30628       XMAX=X(1)
30629       XMIN=X(1)
30630       DO 600 I=1,N
30631          XMAX=MAX(X(I),XMAX)
30632          XMIN=MIN(X(I),XMIN)
30633  600  CONTINUE
30634       XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30635 C
30636       ITEST=0
30637       DO 1100 K=0,IZEIL-1
30638          ITEST=ITEST+1
30639          IF (ITEST.EQ.IYRAST) THEN
30640             DO 1010 L=1,ISPALT-1
30641                COL(L,K)='-'
30642 1010        CONTINUE
30643             COL(ISPALT,K)='+'
30644             ITEST=0
30645             DO 1020 L=0,ISPALT-1,IXRAST
30646                COL(L,K)='+'
30647 1020        CONTINUE
30648          ELSE
30649             DO 1030 L=1,ISPALT-1
30650                COL(L,K)=' '
30651 1030        CONTINUE
30652             DO 1040 L=0,ISPALT-1,IXRAST
30653                COL(L,K)='|'
30654 1040        CONTINUE
30655             COL(ISPALT,K)='|'
30656          ENDIF
30657 1100  CONTINUE
30658 C
30659 C***  plot curve Y1
30660 C
30661       YMAX=Y1(1)
30662       YMIN=MAX(Y1(1),EPS)
30663       DO 500 I=1,N
30664          YMAX =MAX(Y1(I),YMAX)
30665          IF(Y1(I).GT.EPS) THEN
30666            IF(YMIN.EQ.EPS) THEN
30667              YMIN = Y1(I)/10.D0
30668            ELSE
30669              YMIN = MIN(Y1(I),YMIN)
30670            ENDIF
30671          ENDIF
30672 500   CONTINUE
30673       IF(IARG.GT.1) THEN
30674         DO 550 I=1,N
30675            YMAX=MAX(Y2(I),YMAX)
30676            IF(Y2(I).GT.EPS) THEN
30677              IF(YMIN.EQ.EPS) THEN
30678                YMIN = Y2(I)
30679              ELSE
30680                YMIN = MIN(Y2(I),YMIN)
30681              ENDIF
30682            ENDIF
30683 550     CONTINUE
30684       ENDIF
30685 C
30686       DO 560 I=1,N
30687         Y1(I) = MAX(Y1(I),YMIN)
30688  560  CONTINUE
30689       IF(IARG.GT.1) THEN
30690         DO 570 I=1,N
30691           Y2(I) = MAX(Y2(I),YMIN)
30692  570    CONTINUE
30693       ENDIF
30694 C
30695       IF(YMAX.LE.YMIN) THEN
30696         WRITE(LOUT,'(/1X,A,2E12.3,/)')
30697      &     'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
30698         WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
30699         RETURN
30700       ENDIF
30701 C
30702       YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
30703       YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
30704       YZOOM=(YMA-YMI)/DBLE(IZEIL)
30705       IF(YZOOM.LT.EPS) THEN
30706         WRITE(LOUT,'(1X,A)')
30707      &    'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30708         RETURN
30709       ENDIF
30710 C
30711 C***  plot curve Y1
30712 C
30713       ILAST=-1
30714       LLAST=-1
30715       DO 1200 K=1,N
30716          L=NINT((X(K)-XMIN)/XZOOM)
30717          I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
30718          IF(ILAST.GE.0) THEN
30719            LD = L-LLAST
30720            ID = I-ILAST
30721            DO 55 II=0,LD,SIGN(1,LD)
30722              DO 66 KK=0,ID,SIGN(1,ID)
30723                COL(II+LLAST,KK+ILAST)=SYMB(1)
30724  66          CONTINUE
30725  55        CONTINUE
30726          ELSE
30727            COL(L,I)=SYMB(1)
30728          ENDIF
30729          ILAST = I
30730          LLAST = L
30731 1200  CONTINUE
30732 C
30733       IF(IARG.GT.1) THEN
30734 C
30735 C***  plot curve Y2
30736 C
30737         DO 1250 K=1,N
30738            L=NINT((X(K)-XMIN)/XZOOM)
30739            I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
30740            COL(L,I)=SYMB(2)
30741 1250    CONTINUE
30742       ENDIF
30743 C
30744 C***  write it
30745 C
30746       WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
30747       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30748 C
30749 C***  write range of X
30750 C
30751       XZOOM1 = (XMAX-XMIN)/DBLE(7)
30752       WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30753 C
30754       DO 1300 K=0,IZEIL-1
30755          YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
30756          WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30757  110     FORMAT(1X,1PE9.2,70A1)
30758 1300  CONTINUE
30759 C
30760 C***  write range of X
30761 C
30762       WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30763       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30764  120  FORMAT(6X,7(1PE10.3))
30765 C
30766       END
30767
30768 *$ CREATE DT_SRPLOT.FOR
30769 *COPY DT_SRPLOT
30770 *
30771 *===plot===============================================================*
30772 *
30773       SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
30774
30775       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30776       SAVE
30777
30778       PARAMETER ( LINP = 10 ,
30779      &            LOUT = 6 ,
30780      &            LDAT = 9 )
30781 *
30782 *     initial version
30783 *     J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
30784 *     This is a subroutine of fluka to plot Y across the page
30785 *     as a function of X down the page. Up to 37 curves can be
30786 *     plotted in the same picture with different plotting characters.
30787 *     Output of first 10 overprinted characters addad by FB 88
30788 *  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
30789 *
30790 *     Input Variables:
30791 *        X   = array containing the values of X
30792 *        Y   = array containing the values of Y
30793 *        N   = number of values in X and in Y
30794 *              can exceed the fixed number of lines
30795 *        M   = number of different curves X,Y are containing
30796 *        MM  = number of points in each curve i.e. N=M*MM
30797 *        XO  = smallest value of X to be plotted
30798 *        DX  = increment of X between subsequent lines
30799 *        YO  = smallest value of Y to be plotted
30800 *        DY  = increment of Y between subsequent character spaces
30801 *
30802 *        other variables used inside:
30803 *        XX  = numbers along the X-coordinate axis
30804 *        YY  = numbers along the Y-coordinate axis
30805 *        LL  = ten lines temporary storage for the plot
30806 *        L   = character set used to plot different curves
30807 *        LOV = memorizes overprinted symbols
30808 *              the first 10 overprinted symbols are printed on
30809 *              the end of the line to avoid ambiguities
30810 *              (added by FB as considered quite helpful)
30811 *
30812 *********************************************************************
30813 *
30814       DIMENSION XX(61),YY(61),LL(101,10)
30815       DIMENSION X(N),Y(N),L(40),LOV(40,10)
30816       INTEGER*4 LL, L, LOV
30817       DATA  L/
30818      11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
30819      21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
30820      31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
30821      41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H  /
30822 *
30823 *
30824       MN=51
30825       DO 10 I=1,MN
30826         AI=I-1
30827    10 XX(I)=XO+AI*DX
30828       DO 20 I=1,11
30829         AI=I-1
30830    20 YY(I)=YO+10.0D0*AI*DY
30831       WRITE(LOUT, 500) (YY(I),I=1,11)
30832       MMN=MN-1
30833 *
30834 *
30835       DO 90 JJ=1,MMN,10
30836         JJJ=JJ-1
30837         DO 30 I=1,101
30838           DO 30 J=1,10
30839    30   LL(I,J)=L(40)
30840         DO 40 I=1,101
30841    40   LL(I,1)=L(39)
30842         DO 50 I=1,101,10
30843           DO 50 J=1,10
30844    50   LL(I,J)=L(38)
30845         DO 60 I=1,40
30846           DO 60 J=1,10
30847    60   LOV(I,J)=L(40)
30848 *
30849 *
30850         DO 70 I=1,M
30851           DO 70 J=1,MM
30852             II=J+(I-1)*MM
30853             AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
30854             AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
30855             AIX=AIX-DBLE(JJJ)
30856 *           changed Sept.88 by FB to avoid INTEGER OVERFLOW
30857             IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
30858      +      . AIY .LT. 102.D0) THEN
30859               IX=INT(AIX)
30860               IY=INT(AIY)
30861               IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
30862      +        THEN
30863                 IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
30864      +          =LL(IY,IX)
30865                 LL(IY,IX)=L(I)
30866               ENDIF
30867             ENDIF
30868    70   CONTINUE
30869 *
30870 *
30871         DO 80 I=1,10
30872           II=I+JJJ
30873           III=II+1
30874           WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
30875      &                    (LOV(J,I),J=1,10)
30876    80   CONTINUE
30877    90 CONTINUE
30878 *
30879 *
30880       WRITE(LOUT, 520)
30881       WRITE(LOUT, 500) (YY(I),I=1,11)
30882       RETURN
30883 *
30884   500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
30885   510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
30886   520 FORMAT(20X,10('1---------'),'1')
30887       END
30888
30889 *$ CREATE DT_DEFSET.FOR
30890 *COPY DT_DEFSET
30891 *
30892 *===defset=============================================================*
30893 *
30894       BLOCK DATA DT_DEFSET
30895
30896       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30897       SAVE
30898
30899 * flags for input different options
30900       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
30901       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
30902      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
30903       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
30904 * emulsion treatment
30905       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
30906      &                NCOMPO,IEMUL
30907
30908 * / DTFLG1 /
30909       DATA IFRAG  / 2, 1 /
30910       DATA IRESCO / 1 /
30911       DATA IMSHL  / 1 /
30912       DATA IRESRJ / 0 /
30913       DATA IOULEV / -1, -1, -1, -1, -1, -1 /
30914       DATA LEMCCK / .FALSE. /
30915       DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
30916      &              .TRUE.,.TRUE.,.TRUE./
30917       DATA LSEADI / .TRUE. /
30918       DATA LEVAPO / .TRUE. /
30919       DATA IFRAME / 1 /
30920       DATA ITRSPT / 0 /
30921
30922 * / DTCOMP /
30923       DATA EMUFRA / NCOMPX*0.0D0 /
30924       DATA IEMUMA / NCOMPX*1 /
30925       DATA IEMUCH / NCOMPX*1 /
30926       DATA NCOMPO / 0 /
30927       DATA IEMUL  / 0 /
30928
30929       END
30930
30931 *$ CREATE DT_HADPRP.FOR
30932 *COPY DT_HADPRP
30933 *
30934 *===hadprp=============================================================*
30935 *
30936       BLOCK DATA DT_HADPRP
30937
30938       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30939       SAVE
30940
30941 * auxiliary common for reggeon exchange (DTUNUC 1.x)
30942       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
30943      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
30944      &                IQTCHR(-6:6),MQUARK(3,39)
30945 * hadron index conversion (BAMJET <--> PDG)
30946       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
30947      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
30948      &                IAMCIN(210)
30949 * names of hadrons used in input-cards
30950       CHARACTER*8 BTYPE
30951       COMMON /DTPAIN/ BTYPE(30)
30952
30953 * / DTQUAR /
30954 *----------------------------------------------------------------------*
30955 *                                                                      *
30956 *     Quark content of particles:                                      *
30957 *          index   quark   el. charge  bar. charge  isospin  isospin3  *
30958 *              1 = u          2/3          1/3        1/2       1/2    *
30959 *             -1 = ubar      -2/3         -1/3        1/2      -1/2    *
30960 *              2 = d         -1/3          1/3        1/2      -1/2    *
30961 *             -2 = dbar       1/3         -1/3        1/2       1/2    *
30962 *              3 = s         -1/3          1/3         0         0     *
30963 *             -3 = sbar       1/3         -1/3         0         0     *
30964 *              4 = c          2/3          1/3         0         0     *
30965 *             -4 = cbar      -2/3         -1/3         0         0     *
30966 *              5 = b         -1/3          1/3         0         0     *
30967 *             -5 = bbar       1/3         -1/3         0         0     *
30968 *              6 = t          2/3          1/3         0         0     *
30969 *             -6 = tbar      -2/3         -1/3         0         0     *
30970 *                                                                      *
30971 *         Mquark = particle quark composition (Paprop numbering)       *
30972 *         Iqechr = electric charge ( in 1/3 unit )                     *
30973 *         Iqbchr = baryonic charge ( in 1/3 unit )                     *
30974 *         Iqichr = isospin ( in 1/2 unit ), z component                *
30975 *         Iqschr = strangeness                                         *
30976 *         Iqcchr = charm                                               *
30977 *         Iquchr = beauty                                              *
30978 *         Iqtchr = ......                                              *
30979 *                                                                      *
30980 *----------------------------------------------------------------------*
30981       DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
30982       DATA IQBCHR / 6*-1, 0, 6*1 /
30983       DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
30984       DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
30985       DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
30986       DATA IQUCHR / 0, 1, 9*0, -1, 0 /
30987       DATA IQTCHR / -1, 11*0, 1 /
30988       DATA MQUARK /
30989      &   2, 1, 1,   -2,-1,-1,    0, 0, 0,    0, 0, 0,    0, 0, 0,
30990      &   0, 0, 0,    0, 0, 0,    2, 2, 1,   -2,-2,-1,    0, 0, 0,
30991      &   0, 0, 0,    0, 0, 0,    1,-2, 0,    2,-1, 0,    1,-3, 0,
30992      &   3,-1, 0,    1, 2, 3,   -1,-2,-3,    0, 0, 0,    2, 2, 3,
30993      &   1, 1, 3,    1, 2, 3,    1,-1, 0,    2,-3, 0,    3,-2, 0,
30994      &   2,-2, 0,    3,-3, 0,    0, 0, 0,    0, 0, 0,    0, 0, 0,
30995      &  -1,-1,-3,   -1,-2,-3,   -2,-2,-3,    1, 3, 3,   -1,-3,-3,
30996      &   2, 3, 3,   -2,-3,-3,    3, 3, 3,   -3,-3,-3 /
30997
30998 * / DTHAIC /
30999 * (renamed) (HAdron InDex COnversion)
31000 * translation table version filled up by r.e. 25.01.94                 *
31001       DATA IAMCIN /
31002      &2212,-2212,11,-11,12,              -12,22,2112,-2112,-13,
31003      &13,130,211,-211,321,               -321,3122,-3122,310,3112,
31004      &3222,3212,111,311,-311,            0,0,0,0,0,
31005      &221,213,113,-213,223,              323,313,-323,-313,10323,
31006      &10313,-10323,-10313,30323,30313,   -30323,-30313,3224,3214,3114,
31007      &3216,3218,2224,2214,2114,          1114,12224,12214,12114,11114,
31008      &99999,99999,22212,22112,32124,     31214,-2224,-2214,-2114,-1114,
31009      &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
31010      &5*99999,                           5*99999,
31011      &4*99999,331,                       333,3322,3312,-3222,-3212,
31012      &-3112,-3322,-3312,3224,3214,       3114,3324,3314,3334,-3224,
31013      &-3214,-3114,-3324,-3314,-3334,     421,411,-411,-421,431,
31014      &-431,441,423,413,-413,             -423,433,-433,20443,443,
31015      &-15,15,16,-16,14,                  -14,4122,4232,4132,4222,
31016      &4212,4112,3*99999,                 3*99999,-4122,-4232,
31017      &-4132,-4222,-4212,-4112,99999,     5*99999,
31018      &5*99999,                           5*99999,
31019      &10*99999,
31020      &5*99999 , 20211,20111,-20211,99999,20321,
31021      &-20321,20311,-20311,7*99999 ,
31022      &7*99999,12212,12112,99999/
31023
31024 * / DTHAIC /
31025 * (HAdron InDex COnversion)
31026       DATA (IPDG2(1,K),K=1,7)
31027      &   /   -11,   -12,   -13,   -15,   -16,   -14,     0/
31028       DATA (IBAM2(1,K),K=1,7)
31029      &   /     4,     6,    10,   131,   134,   136,     0/
31030       DATA (IPDG2(2,K),K=1,7)
31031      &   /    11,    12,    22,    13,    15,    16,    14/
31032       DATA (IBAM2(2,K),K=1,7)
31033      &   /     3,     5,     7,    11,   132,   133,   135/
31034       DATA (IPDG3(1,K),K=1,22)
31035      &   /  -211,  -321,  -311,  -213,  -323,  -313,  -411,  -421,
31036      &      -431,  -413,  -423,  -433,     0,     0,     0,     0,
31037      &         0,     0,     0,     0,     0,     0/
31038       DATA (IBAM3(1,K),K=1,22)
31039      &   /    14,    16,    25,    34,    38,    39,   118,   119,
31040      &       121,   125,   126,   128,     0,     0,     0,     0,
31041      &         0,     0,     0,     0,     0,     0/
31042       DATA (IPDG3(2,K),K=1,22)
31043      &   /   130,   211,   321,   310,   111,   311,   221,   213,
31044      &       113,   223,   323,   313,   331,   333,   421,   411,
31045      &       431,   441,   423,   413,   433,   443/
31046       DATA (IBAM3(2,K),K=1,22)
31047      &   /    12,    13,    15,    19,    23,    24,    31,    32,
31048      &        33,    35,    36,    37,    95,    96,   116,   117,
31049      &       120,   122,   123,   124,   127,   130/
31050       DATA (IPDG4(1,K),K=1,29)
31051      &   / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
31052      &     -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
31053      &     -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
31054      &     -4212, -4112,     0,     0,     0/
31055       DATA (IBAM4(1,K),K=1,29)
31056      &   /     2,     9,    18,    67,    68,    69,    70,    75,
31057      &        76,    99,   100,   101,   102,   103,   110,   111,
31058      &       112,   113,   114,   115,   149,   150,   151,   152,
31059      &       153,   154,     0,     0,     0/
31060       DATA (IPDG4(2,K),K=1,29)
31061      &   /  2212,  2112,  3122,  3112,  3222,  3212,  3224,  3214,
31062      &      3114,  3216,  3218,  2224,  2214,  2114,  1114,  3322,
31063      &      3312,  3224,  3214,  3114,  3324,  3314,  3334,  4122,
31064      &      4232,  4132,  4222,  4212,  4112/
31065       DATA (IBAM4(2,K),K=1,29)
31066      &   /     1,     8,    17,    20,    21,    22,    48,    49,
31067      &        50,    51,    52,    53,    54,    55,    56,    97,
31068      &        98,   104,   105,   106,   107,   108,   109,   137,
31069      &       138,   139,   140,   141,   142/
31070       DATA (IPDG5(1,K),K=1,19)
31071      &   /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
31072      &    -20211,-20321,-20311,     0,     0,     0,     0,     0,
31073      &         0,     0,     0/
31074       DATA (IBAM5(1,K),K=1,19)
31075      &   /    42,    43,    46,    47,    71,    72,    73,    74,
31076      &       188,   191,   193,     0,     0,     0,     0,     0,
31077      &         0,     0,     0/
31078       DATA (IPDG5(2,K),K=1,19)
31079      &   / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
31080      &     22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
31081      &     20311, 12212, 12112/
31082       DATA (IBAM5(2,K),K=1,19)
31083      &   /    40,    41,    44,    45,    57,    58,    59,    60,
31084      &        63,    64,    65,    66,   129,   186,   187,   190,
31085      &       192,   208,   209/
31086
31087 * / DTPAIN /
31088 * internal particle names
31089       DATA BTYPE / 'PROTON  ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
31090      &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON  ' , 'NEUTRON ' , 'ANEUTRON' ,
31091      &'MUON+   ' , 'MUON-   ' , 'KAONLONG' , 'PION+   ' , 'PION-   ' ,
31092      &'KAON+   ' , 'KAON-   ' , 'LAMBDA  ' , 'ALAMBDA ' , 'KAONSHRT' ,
31093      &'SIGMA-  ' , 'SIGMA+  ' , 'SIGMAZER' , 'PIZERO  ' , 'KAONZERO' ,
31094      &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
31095      &'BLANK   ' /
31096
31097       END
31098
31099 *$ CREATE DT_BLKD46.FOR
31100 *COPY DT_BLKD46
31101 *
31102 *===blkd46=============================================================*
31103 *
31104       BLOCK DATA DT_BLKD46
31105
31106       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31107       SAVE
31108
31109       PARAMETER ( AMELCT = 0.51099906         D-03 )
31110       PARAMETER ( AMMUON = 0.105658389        D+00 )
31111
31112 * particle properties (BAMJET index convention)
31113       CHARACTER*8  ANAME
31114       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31115      &                IICH(210),IIBAR(210),K1(210),K2(210)
31116
31117 * / DTPART /
31118 * Particle  masses Engel version JETSET compatible
31119 C     DATA (AAM(K),K=1,85) /
31120 C    &   .9383D+00, .9383D+00,  AMELCT  ,  AMELCT  , .0000D+00,
31121 C    &   .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON   ,
31122 C    &   AMMUON   , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
31123 C    &   .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
31124 C    &   .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
31125 C    &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31126 C    &   .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
31127 C    &   .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
31128 C    &   .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
31129 C    &   .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
31130 C    &   .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31131 C    &   .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31132 C    &   .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31133 C    &   .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31134 C    &   .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31135 C    &   .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31136 C    &   .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01  /
31137 C     DATA (AAM(K),K=86,183) /
31138 C    &   .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31139 C    &   .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
31140 C    &   .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
31141 C    &   .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
31142 C    &   .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
31143 C    &   .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
31144 C    &   .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
31145 C    &   .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
31146 C    &   .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
31147 C    &   .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
31148 C    &   .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
31149 C    &   .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
31150 C    &   .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
31151 C    &   .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
31152 C    &   .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31153 C    &   .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31154 C    &   .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31155 C    &   .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31156 C    &   .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31157 C    &   .1250D+01, .1250D+01, .1250D+01  /
31158 C     DATA (AAM ( I ), I = 184,210 ) /
31159 C    & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31160 C    & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31161 C    & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31162 C    & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31163 C    & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31164 C    & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31165 C    & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31166 C    & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31167 C    & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31168 * sr 25.1.06: particle masses adjusted to Pythia
31169       DATA (AAM(K),K=1,85) /
31170      &   .938270E+00,.938270E+00, AMELCT    , AMELCT    ,.000000E+00,
31171      &   .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON    ,
31172      &    AMMUON    ,.497670E+00,.139570E+00,.139570E+00,.493600E+00,
31173      &   .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01,
31174      &   .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00,
31175      &     .0000D+00,  .0000D+00,  .0000D+00 , .0000D+00,  .0000D+00,
31176      &   .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00,
31177      &   .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01,
31178      &   .129000E+01,.129000E+01,.129000E+01,  .1421D+01,  .1421D+01,
31179      &     .1421D+01,  .1421D+01,.138280E+01,.138370E+01,.138720E+01,
31180      &     .1820D+01,  .2030D+01,  .1231D+01,  .1232D+01,  .1233D+01,
31181      &     .1234D+01,  .1675D+01,  .1675D+01,  .1675D+01,  .1675D+01,
31182      &     .1500D+01,  .1500D+01,  .1515D+01,  .1515D+01,  .1775D+01,
31183      &     .1775D+01,  .1231D+01,  .1232D+01,  .1233D+01,  .1234D+01,
31184      &     .1675D+01,  .1675D+01,  .1675D+01,  .1675D+01,  .1515D+01,
31185      &     .1515D+01,  .2500D+01,  .4890D+00,  .4890D+00,  .4890D+00,
31186      &     .1300D+01,  .1300D+01,  .1300D+01,  .1300D+01,  .2200D+01  /
31187       DATA (AAM(K),K=86,183) /
31188      &     .2200D+01,  .2200D+01,  .2200D+01,  .1700D+01,  .1700D+01,
31189      &     .1700D+01,  .1700D+01,  .1820D+01,  .2030D+01,.957770E+00,
31190      &   .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01,
31191      &   .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01,
31192      &   .138720E+01,.153180E+01,  .1535D+01,.167245E+01,.138280E+01,
31193      &   .138370E+01,.138720E+01,.153180E+01,  .1535D+01,.167245E+01,
31194      &   .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01,
31195      &   .196850E+01,.297980E+01,.200670E+01,  .2010D+01,  .2010D+01,
31196      &   .200670E+01,.211240E+01,.211240E+01,  .3686D+01,.309688E+01,
31197      &   .177700E+01,.177700E+01,  .0000D+00,  .0000D+00,  .0000D+00,
31198      &     .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01,
31199      &   .245350E+01,.245210E+01,  .2560D+01,  .2560D+01,  .2730D+01,
31200      &     .3610D+01,  .3610D+01,  .3790D+01,.228490E+01,.246560E+01,
31201      &     .2460D+01,.245290E+01,.245350E+01,.245210E+01,  .2560D+01,
31202      &     .2560D+01,  .2730D+01,  .3610D+01,  .3610D+01,  .3790D+01,
31203      &     .2490D+01,  .2490D+01,  .2490D+01,  .2610D+01,  .2610D+01,
31204      &     .2770D+01,  .3670D+01,  .3670D+01,  .3850D+01,  .4890D+01,
31205      &     .2490D+01,  .2490D+01,  .2490D+01,  .2610D+01,  .2610D+01,
31206      &     .2770D+01,  .3670D+01,  .3670D+01,  .3850D+01,  .4890D+01,
31207      &     .1250D+01,  .1250D+01,  .1250D+01  /
31208       DATA (AAM ( I ), I = 184,210 ) /
31209      & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31210      & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31211      & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31212      & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31213      & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31214      & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31215      & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31216      & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31217      & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31218 * Particle  mean lives
31219       DATA (TAU(K),K=1,183) /
31220      &   .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
31221      &   .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
31222      &   .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
31223      &   .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
31224      &   .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
31225      &   70*.0000D+00,
31226      &   .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
31227      &   .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
31228      &   .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
31229      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
31230      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31231      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31232      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31233      &   .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
31234      &   .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31235      &   40*.0000D+00,
31236      &   .0000D+00, .0000D+00, .0000D+00  /
31237       DATA ( TAU ( I ), I = 184,210 ) /
31238      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31239      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31240      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31241      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31242      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31243      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31244      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31245      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31246      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/
31247 * Resonance width Gamma in GeV
31248       DATA (GA(K),K=  1,85) /
31249      &    30*.0000D+00,
31250      &   .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
31251      &   .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
31252      &   .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
31253      &   .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
31254      &   .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
31255      &   .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
31256      &   .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
31257      &   .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
31258      &   .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
31259      &   .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
31260      &   .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00  /
31261       DATA (GA(K),K= 86,183) /
31262      &   .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
31263      &   .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
31264      &   .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31265      &   .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
31266      &   .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
31267      &   .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
31268      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31269      &   .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
31270      &   .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
31271      &   50*.0000D+00,
31272      &   .3000D+00, .3000D+00, .3000D+00  /
31273       DATA ( GA ( I ), I = 184,210 ) /
31274      & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
31275      & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
31276      & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
31277      & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
31278      & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31279      & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31280      & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
31281      & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
31282      & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
31283 * Particle  names
31284 * S+1385+Sigma+(1385)    L02030+Lambda0(2030)
31285 * Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
31286 * designation N*@@ means N*@1(@2)
31287       DATA (ANAME(K),K=1,85) /
31288      &  'P       ','AP      ','E-      ','E+      ','NUE     ',
31289      &  'ANUE    ','GAM     ','NEU     ','ANEU    ','MUE+    ',
31290      &  'MUE-    ','K0L     ','PI+     ','PI-     ','K+      ',
31291      &  'K-      ','LAM     ','ALAM    ','K0S     ','SIGM-   ',
31292      &  'SIGM+   ','SIGM0   ','PI0     ','K0      ','AK0     ',
31293      &  'BLANK   ','BLANK   ','BLANK   ','BLANK   ','BLANK   ',
31294      &  'ETA550  ','RHO+77  ','RHO077  ','RHO-77  ','OM0783  ',
31295      &  'K*+892  ','K*0892  ','K*-892  ','AK*089  ','KA+125  ',
31296      &  'KA0125  ','KA-125  ','AKA012  ','K*+142  ','K*0142  ',
31297      &  'K*-142  ','AK*014  ','S+1385  ','S01385  ','S-1385  ',
31298      &  'L01820  ','L02030  ','N*++12  ','N*+ 12  ','N*012   ',
31299      &  'N*-12   ','N*++16  ','N*+16   ','N*016   ','N*-16   ',
31300      &  'N*+14   ','N*014   ','N*+15   ','N*015   ','N*+18   ',
31301      &  'N*018   ','AN--12  ','AN*-12  ','AN*012  ','AN*+12  ',
31302      &  'AN--16  ','AN*-16  ','AN*016  ','AN*+16  ','AN*-15  ',
31303      &  'AN*015  ','DE*=24  ','RPI+49  ','RPI049  ','RPI-49  ',
31304      &  'PIN++   ','PIN+0   ','PIN+-   ','PIN-0   ','PPPI    ' /
31305       DATA (ANAME(K),K=86,183) /
31306      &  'PNPI    ','APPPI   ','APNPI   ','K+PPI   ','K-PPI   ',
31307      &  'K+NPI   ','K-NPI   ','S+1820  ','S-2030  ','ETA*    ',
31308      &  'PHI     ','TETA0   ','TETA-   ','ASIG-   ','ASIG0   ',
31309      &  'ASIG+   ','ATETA0  ','ATETA+  ','SIG*+   ','SIG*0   ',
31310      &  'SIG*-   ','TETA*0  ','TETA*   ','OMEGA-  ','ASIG*-  ',
31311      &  'ASIG*0  ','ASIG*+  ','ATET*0  ','ATET*+  ','OMEGA+  ',
31312      &  'D0      ','D+      ','D-      ','AD0     ','F+      ',
31313      &  'F-      ','ETAC    ','D*0     ','D*+     ','D*-     ',
31314      &  'AD*0    ','F*+     ','F*-     ','PSI     ','JPSI    ',
31315      &  'TAU+    ','TAU-    ','NUET    ','ANUET   ','NUEM    ',
31316      &  'ANUEM   ','C0+     ','A+      ','A0      ','C1++    ',
31317      &  'C1+     ','C10     ','S+      ','S0      ','T0      ',
31318      &  'XU++    ','XD+     ','XS+     ','AC0-    ','AA-     ',
31319      &  'AA0     ','AC1--   ','AC1-    ','AC10    ','AS-     ',
31320      &  'AS0     ','AT0     ','AXU--   ','AXD-    ','AXS     ',
31321      &  'C1*++   ','C1*+    ','C1*0    ','S*+     ','S*0     ',
31322      &  'T*0     ','XU*++   ','XD*+    ','XS*+    ','TETA++  ',
31323      &  'AC1*--  ','AC1*-   ','AC1*0   ','AS*-    ','AS*0    ',
31324      &  'AT*0    ','AXU*--  ','AXD*-   ','AXS*-   ','ATET--  ',
31325      &  'RO      ','R+      ','R-      '  /
31326       DATA (    ANAME ( I ), I = 184,210 ) /
31327      &'AN*-14  ','AN*014  ','PI+130  ','PI0130  ','PI-130  ','F01400  ',
31328      &'K*+146  ','K*-146  ','K*0146  ','AK0146  ','L01600  ','AL0160  ',
31329      &'S+1660  ','S01660  ','S-1660  ','AS-166  ','AS0166  ','AS+166  ',
31330      &'X01950  ','X-1950  ','AX0195  ','AX+195  ','OM-225  ','AOM+22  ',
31331      &'N*+14   ','N*014   ','BLANK   '/
31332 * Charge of particles and resonances
31333       DATA (IICH ( I ), I =   1,210 ) /
31334      &  1, -1, -1,  1,  0,  0,  0,  0,  0,  1, -1,  0,  1, -1,  1,
31335      & -1,  0,  0,  0, -1,  1,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31336      &  0,  1,  0, -1,  0,  1,  0, -1,  0,  1,  0, -1,  0,  1,  0,
31337      & -1,  0,  1,  0, -1,  0,  0,  2,  1,  0, -1,  2,  1,  0, -1,
31338      &  1,  0,  1,  0,  1,  0, -2, -1,  0,  1, -2, -1,  0,  1, -1,
31339      &  0,  1,  1,  0, -1,  2,  1,  0, -1,  2,  1,  0, -1,  2,  0,
31340      &  1, -1,  1, -1,  0,  0,  0, -1, -1,  0,  1,  0,  1,  1,  0,
31341      & -1,  0, -1, -1, -1,  0,  1,  0,  1,  1,  0,  1, -1,  0,  1,
31342      & -1,  0,  0,  1, -1,  0,  1, -1,  0,  0,  1, -1,  0,  0,  0,
31343      &  0,  1,  1,  0,  2,  1,  0,  1,  0,  0,  2,  1,  1, -1, -1,
31344      &  0, -2, -1,  0, -1,  0,  0, -2, -1, -1,  2,  1,  0,  1,  0,
31345      &  0,  2,  1,  1,  2, -2, -1,  0, -1,  0,  0, -2, -1, -1, -2,
31346      &  0,  1, -1, -1,  0,  1,  0, -1,  0,  1, -1,  0,  0,  0,  0,
31347      &  1,  0, -1, -1,  0,  1,  0, -1,  0,  1, -1,  1,  1,  0,  0/
31348 * Particle  baryonic charges
31349       DATA (IIBAR ( I ), I =   1,210 ) /
31350      &  1, -1,  0,  0,  0,  0,  0,  1, -1,  0,  0,  0,  0,  0,  0,
31351      &  0,  1, -1,  0,  1,  1,  1,  0,  0,  0,  0,  0,  0,  0,  0,
31352      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31353      &  0,  0,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,
31354      &  1,  1,  1,  1,  1,  1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31355      & -1,  2,  0,  0,  0,  1,  1,  1,  1,  2,  2,  0,  0,  1,  1,
31356      &  1,  1,  1,  1,  0,  0,  1,  1, -1, -1, -1, -1, -1,  1,  1,
31357      &  1,  1,  1,  1, -1, -1, -1, -1, -1, -1,  0,  0,  0,  0,  0,
31358      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31359      &  0,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1, -1, -1,
31360      & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,  1,  1,  1,  1,  1,
31361      &  1,  1,  1,  1,  1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31362      &  0,  0,  0, -1, -1,  0,  0,  0,  0,  0,  0,  0,  0,  1, -1,
31363      &  1,  1,  1, -1, -1, -1,  1,  1, -1, -1,  1, -1,  1,  1,  0/
31364 * First number of decay channels used for resonances
31365 * and decaying particles
31366       DATA K1/   1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 16, 17,
31367      &  18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
31368      &   2*330, 46, 51, 52, 54, 55, 58,
31369 *                                                             50
31370      &  60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
31371      & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
31372      & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
31373 *                                         85
31374      & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
31375      & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
31376      & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
31377      & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
31378      & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
31379      & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
31380      & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
31381      & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
31382      & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
31383      & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
31384      & 590, 596, 602 /
31385 * Last number of decay channels used for resonances
31386 * and decaying particles
31387       DATA K2/   1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 15, 16, 17,
31388      & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
31389      & 2* 330, 50, 51, 53, 54, 57,
31390 *                                                                 50
31391      & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
31392      & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
31393      & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
31394 *                                              85
31395      & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
31396      & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
31397      & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
31398      & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
31399      & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
31400      & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
31401      & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
31402      & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
31403      & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
31404      & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
31405      & 589, 595, 601, 602 /
31406
31407        END
31408
31409 *$ CREATE DT_BLKD47.FOR
31410 *COPY DT_BLKD47
31411 *
31412 *===blkd47=============================================================*
31413 *
31414       BLOCK DATA DT_BLKD47
31415
31416       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31417       SAVE
31418
31419 * HADRIN: decay channel information
31420       PARAMETER (IDMAX9=602)
31421       CHARACTER*8 ZKNAME
31422       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
31423
31424 * Name of decay channel
31425 * Designation N*@ means N*@1(1236)
31426 * @1=# means ++,  @1 = = means --
31427 * Designation  P+/0/- means Pi+/Pi0/Pi- , respectively
31428       DATA (ZKNAME(K),K=  1, 85) /
31429      &  'P       ','AP      ','E-      ','E+      ','NUE     ',
31430      &  'ANUE    ','GAM     ','PE-NUE  ','APEANU  ','EANUNU  ',
31431      &  'E-NUAN  ','3PI0    ','PI+-0   ','PIMUNU  ','PIE-NU  ',
31432      &  'MU+NUE  ','MU-NUE  ','MU+NUE  ','PI+PI0  ','PI++-   ',
31433      &  'PI+00   ','M+P0NU  ','E+P0NU  ','MU-NU   ','PI-0    ',
31434      &  'PI+--   ','PI-00   ','M-P0NU  ','E-P0NU  ','PPI-    ',
31435      &  'NPI0    ','PD-NUE  ','PM-NUE  ','APPI+   ','ANPI0   ',
31436      &  'APE+NU  ','APM+NU  ','PI+PI-  ','PI0PI0  ','NPI-    ',
31437      &  'PPI0    ','NPI+    ','LAGA    ','GAGA    ','GAE+E-  ',
31438      &  'GAGA    ','GAGAP0  ','PI000   ','PI+-0   ','PI+-GA  ',
31439      &  'PI+0    ','PI+-    ','PI00    ','PI-0    ','PI+-0   ',
31440      &  'PI+-    ','PI0GA   ','K+PI0   ','K0PI+   ','KOPI0   ',
31441      &  'K+PI-   ','K-PI0   ','AK0PI-  ','AK0PI0  ','K-PI+   ',
31442      &  'K+PI0   ','K0PI+   ','K0PI0   ','K+PI-   ','K-PI0   ',
31443      &  'K0PI-   ','AK0PI0  ','K-PI+   ','K+PI0   ','K0PI+   ',
31444      &  'K+89P0  ','K08PI+  ','K+RO77  ','K0RO+7  ','K+OM07  ',
31445      &  'K+E055  ','K0PI0   ','K+PI+   ','K089P0  ','K+8PI-  '  /
31446       DATA (ZKNAME(K),K= 86,170) /
31447      &  'K0R077  ','K+R-77  ','K+R-77  ','K0OM07  ','K0E055  ',
31448      &  'K-PI0   ','K0PI-   ','K-89P0  ','AK08P-  ','K-R077  ',
31449      &  'AK0R-7  ','K-OM07  ','K-E055  ','AK0PI0  ','K-PI+   ',
31450      &  'AK08P0  ','K-8PI+  ','AK0R07  ','AK0OM7  ','AK0E05  ',
31451      &  'LA0PI+  ','SI0PI+  ','SI+PI0  ','LA0PI0  ','SI+PI-  ',
31452      &  'SI-PI+  ','LA0PI-  ','SI0PI-  ','NEUAK0  ','PK-     ',
31453      &  'SI+PI-  ','SI0PI0  ','SI-PI+  ','LA0ET0  ','S+1PI-  ',
31454      &  'S-1PI+  ','SO1PI0  ','NEUAK0  ','PK-     ','LA0PI0  ',
31455      &  'LA0OM0  ','LA0RO0  ','SI+RO-  ','SI-RO+  ','SI0RO0  ',
31456      &  'LA0ET0  ','SI0ET0  ','SI+PI-  ','SI-PI+  ','SI0PI0  ',
31457      &  'K0S     ','K0L     ','K0S     ','K0L     ','P PI+   ',
31458      &  'P PI0   ','N PI+   ','P PI-   ','N PI0   ','N PI-   ',
31459      &  'P PI+   ','N*#PI0  ','N*+PI+  ','PRHO+   ','P PI0   ',
31460      &  'N PI+   ','N*#PI-  ','N*+PI0  ','N*0PI+  ','PRHO0   ',
31461      &  'NRHO+   ','P PI-   ','N PI0   ','N*+PI-  ','N*0PI0  ',
31462      &  'N*-PI+  ','PRHO-   ','NRHO0   ','N PI-   ','N*0PI-  ',
31463      &  'N*-PI0  ','NRHO-   ','PETA0   ','N*#PI-  ','N*+PI0  '  /
31464       DATA (ZKNAME(K),K=171,255) /
31465      &  'N*0PI+  ','PRHO0   ','NRHO+   ','NETA0   ','N*+PI-  ',
31466      &  'N*0PI0  ','N*-PI+  ','PRHO-   ','NRHO0   ','P PI0   ',
31467      &  'N PI+   ','N*#PI-  ','N*+PI0  ','N*0PI+  ','PRHO0   ',
31468      &  'NRHO+   ','P PI-   ','N PI0   ','N*+PI-  ','N*0PI0  ',
31469      &  'N*-PI+  ','PRHO-   ','NRHO0   ','P PI0   ','N PI+   ',
31470      &  'PRHO0   ','NRHO+   ','LAMK+   ','S+ K0   ','S0 K+   ',
31471      &  'PETA0   ','P PI-   ','N PI0   ','PRHO-   ','NRHO0   ',
31472      &  'LAMK0   ','S0 K0   ','S- K+   ','NETA/   ','APPI-   ',
31473      &  'APPI0   ','ANPI-   ','APPI+   ','ANPI0   ','ANPI+   ',
31474      &  'APPI-   ','AN*=P0  ','AN*-P-  ','APRHO-  ','APPI0   ',
31475      &  'ANPI-   ','AN*=P+  ','AN*-P0  ','AN*0P-  ','APRHO0  ',
31476      &  'ANRHO-  ','APPI+   ','ANPI0   ','AN*-P+  ','AN*0P0  ',
31477      &  'AN*+P-  ','APRHO+  ','ANRHO0  ','ANPI+   ','AN*0P+  ',
31478      &  'AN*+P0  ','ANRHO+  ','APPI0   ','ANPI-   ','AN*=P+  ',
31479      &  'AN*-P0  ','AN*0P-  ','APRHO0  ','ANRHO-  ','APPI+,  ',
31480      &  'ANPI0   ','AN*-P+  ','AN*0P0  ','AN*+P-  ','APRHO+  ',
31481      &  'ANRHO0  ','PN*014  ','NN*=14  ','PI+0    ','PI+-    '  /
31482       DATA (ZKNAME(K),K=256,340) /
31483      &  'PI-0    ','P+0     ','N++     ','P+-     ','P00     ',
31484      &  'N+0     ','N+-     ','N00     ','P-0     ','N-0     ',
31485      &  'P--     ','PPPI0   ','PNPI+   ','PNPI0   ','PPPI-   ',
31486      &  'NNPI+   ','APPPI0  ','APNPI+  ','ANNPI0  ','ANPPI-  ',
31487      &  'APNPI0  ','APPPI-  ','ANNPI-  ','K+PPI0  ','K+NPI+  ',
31488      &  'K0PPI0  ','K-PPI0  ','K-NPI+  ','AKPPI-  ','AKNPI0  ',
31489      &  'K+NPI0  ','K+PPI-  ','K0PPI0  ','K0NPI+  ','K-NPI0  ',
31490      &  'K-PPI-  ','AKNPI-  ','PAK0    ','SI+PI0  ','SI0PI+  ',
31491      &  'SI+ETA  ','S+1PI0  ','S01PI+  ','NEUK-   ','LA0PI-  ',
31492      &  'SI-OM0  ','LA0RO-  ','SI0RO-  ','SI-RO0  ','SI-ET0  ',
31493      &  'SI0PI-  ','SI-0    ','BLANC   ','BLANC   ','BLANC   ',
31494      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31495      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31496      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31497      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31498      &  'EPI+-   ','EPI00   ','GAPI+-  ','GAGA*   ','K+-     ',
31499      &  'KLKS    ','PI+-0   ','EGA     ','LPI0    ','LPI     '  /
31500       DATA (ZKNAME(K),K=341,425) /
31501      &  'APPI0   ','ANPI-   ','ALAGA   ','ANPI    ','ALPI0   ',
31502      &  'ALPI+   ','LAPI+   ','SI+PI0  ','SI0PI+  ','LAPI0   ',
31503      &  'SI+PI-  ','SI-PI+  ','LAPI-   ','SI-PI0  ','SI0PI-  ',
31504      &  'TE0PI0  ','TE-PI+  ','TE0PI-  ','TE-PI0  ','TE0PI   ',
31505      &  'TE-PI   ','LAK-    ','ALPI-   ','AS-PI0  ','AS0PI-  ',
31506      &  'ALPI0   ','AS+PI-  ','AS-PI+  ','ALPI+   ','AS+PI0  ',
31507      &  'AS0PI+  ','AT0PI0  ','AT+PI-  ','AT0PI+  ','AT+PI0  ',
31508      &  'AT0PI   ','AT+PI   ','ALK+    ','K-PI+   ','K-PI+0  ',
31509      &  'K0PI+-  ','K0PI0   ','K-PI++  ','AK0PI+  ','K+PI--  ',
31510      &  'K0PI-   ','K+PI-   ','K+PI-0  ','AKPI-+  ','AK0PI0  ',
31511      &  'ETAPIF  ','K++-    ','K+AK0   ','ETAPI-  ','K--+    ',
31512      &  'K-K0    ','PI00    ','PI+-    ','GAGA    ','D0PI0   ',
31513      &  'D0GA    ','D0PI+   ','D+PI0   ','DFGA    ','AD0PI-  ',
31514      &  'D-PI0   ','D-GA    ','AD0PI0  ','AD0GA   ','F+GA    ',
31515      &  'F+GA    ','F-GA    ','F-GA    ','PSPI+-  ','PSPI00  ',
31516      &  'PSETA   ','E+E-    ','MUE+-   ','PI+-0   ','M+NN    ',
31517      &  'E+NN    ','RHO+NT  ','PI+ANT  ','K*+ANT  ','M-NN    '  /
31518       DATA (ZKNAME(K),K=426,510) /
31519      &  'E-NN    ','RHO-NT  ','PI-NT   ','K*-NT   ','NUET    ',
31520      &  'ANUET   ','NUEM    ','ANUEM   ','SI+ETA  ','SI+ET*  ',
31521      &  'PAK0    ','TET0K+  ','SI*+ET  ','N*+AK0  ','N*++K-  ',
31522      &  'LAMRO+  ','SI0RO+  ','SI+RO0  ','SI+OME  ','PAK*0   ',
31523      &  'N*+AK*  ','N*++K*  ','SI+AK0  ','TET0PI  ','SI+AK*  ',
31524      &  'TET0RO  ','SI0AK*  ','SI+K*-  ','TET0OM  ','TET-RO  ',
31525      &  'SI*0AK  ','C0+PI+  ','C0+PI0  ','C0+PI-  ','A+GAM   ',
31526      &  'A0GAM   ','TET0AK  ','TET0K*  ','OM-RO+  ','OM-PI+  ',
31527      &  'C1++AK  ','A+PI+   ','C0+AK0  ','A0PI+   ','A+AK0   ',
31528      &  'T0PI+   ','ASI-ET  ','ASI-E*  ','APK0    ','ATET0K  ',
31529      &  'ASI*-E  ','AN*-K0  ','AN*--K  ','ALAMRO  ','ASI0RO  ',
31530      &  'ASI-RO  ','ASI-OM  ','APK*0   ','AN*-K*  ','AN*--K  ',
31531      &  'ASI-K0  ','ATETPI  ','ASI-K*  ','ATETRO  ','ASI0K*  ',
31532      &  'ASI-K*  ','ATE0OM  ','ATE+RO  ','ASI*0K  ','AC-PI-  ',
31533      &  'AC-PI0  ','AC-PI+  ','AA-GAM  ','AA0GAM  ','ATET0K  ',
31534      &  'ATE0K*  ','AOM+RO  ','AOM+PI  ','AC1--K  ','AA-PI-  ',
31535      &  'AC0-K0  ','AA0PI-  ','AA-K0   ','AT0PI-  ','C1++GA  '  /
31536       DATA (ZKNAME(K),K=511,540) /
31537      &  'C1++GA  ','C10GAM  ','S+GAM   ','S0GAM   ','T0GAM   ',
31538      &  'XU++GA  ','XD+GAM  ','XS+GAM  ','A+AKPI  ','T02PI+  ',
31539      &  'C1++2K  ','AC1--G  ','AC1-GA  ','AC10GA  ','AS-GAM  ',
31540      &  'AS0GAM  ','AT0GAM  ','AXU--G  ','AXD-GA  ','AXS-GA  ',
31541      &  'AA-KPI  ','AT02PI  ','AC1--K  ','RH-PI+  ','RH+PI-  ',
31542      &  'RH3PI0  ','RH0PI+  ','RH+PI0  ','RH0PI-  ','RH-PI0  '  /
31543       DATA (ZKNAME(I),I=541,602)/
31544      & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
31545      & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
31546      & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
31547      & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
31548      & 'PI+PI-','K+K-  ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
31549      & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
31550      & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
31551      & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
31552      & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
31553 * Weight of decay channel
31554       DATA (WT(K),K=  1, 85) /
31555      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31556      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31557      &   .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
31558      &   .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
31559      &   .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
31560      &   .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
31561      &   .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
31562      &   .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
31563      &   .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
31564      &   .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
31565      &   .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
31566      &   .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
31567      &   .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
31568      &   .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
31569      &   .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
31570      &   .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
31571      &   .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00  /
31572       DATA (WT(K),K= 86,170) /
31573      &   .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
31574      &   .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
31575      &   .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
31576      &   .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
31577      &   .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
31578      &   .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
31579      &   .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
31580      &   .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
31581      &   .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
31582      &   .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
31583      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
31584      &   .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31585      &   .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31586      &   .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31587      &   .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31588      &   .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31589      &   .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00  /
31590       DATA (WT(K),K=171,255) /
31591      &   .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
31592      &   .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
31593      &   .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
31594      &   .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
31595      &   .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
31596      &   .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
31597      &   .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
31598      &   .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
31599      &   .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31600      &   .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31601      &   .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31602      &   .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31603      &   .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31604      &   .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
31605      &   .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
31606      &   .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
31607      &   .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01  /
31608       DATA (WT(K),K=256,340) /
31609      &   .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
31610      &   .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
31611      &   .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
31612      &   .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
31613      &   .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
31614      &   .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
31615      &   .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
31616      &   .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
31617      &   .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
31618      &   .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
31619      &   .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01,
31620      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31621      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31622      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31623      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31624      &   .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
31625      &   .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01  /
31626       DATA (WT(K),K=341,425) /
31627      &   .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
31628      &   .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
31629      &   .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
31630      &   .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
31631      &   .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
31632      &   .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
31633      &   .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
31634      &   .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
31635      &   .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
31636      &   .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
31637      &   .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
31638      &   .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
31639      &   .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
31640      &   .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
31641      &   .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
31642      &   .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
31643      &   .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00  /
31644       DATA (WT(K),K=426,510) /
31645      &   .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
31646      &   .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
31647      &   .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
31648      &   .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
31649      &   .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
31650      &   .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
31651      &   .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31652      &   .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
31653      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
31654      &   .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
31655      &   .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
31656      &   .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
31657      &   .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
31658      &   .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
31659      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
31660      &   .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
31661      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01  /
31662       DATA (WT(K),K=511,540) /
31663      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31664      &   .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
31665      &   .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31666      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31667      &   .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
31668      &   .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00  /
31669 C
31670       DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
31671      & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
31672      & .125D+00,  0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
31673      & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
31674      & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
31675      & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
31676      & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
31677 * Particle numbers in decay channel
31678       DATA (NZK(K,1),K=  1,170) /
31679      &     1,   2,   3,   4,   5,   6,   7,   1,   2,   4,
31680      &     3,  23,  13,  13,  13,  10,  11,  10,  13,  13,
31681      &    13,  10,   4,  11,  14,  14,  14,  11,   3,   1,
31682      &     8,   1,   1,   2,   9,   2,   2,  13,  23,   8,
31683      &     1,   8,  17,   7,   7,   7,  23,  23,  13,  13,
31684      &    13,  13,  23,  14,  13,  13,  23,  15,  24,  24,
31685      &    15,  16,  25,  25,  16,  15,  24,  24,  15,  16,
31686      &    24,  25,  16,  15,  24,  36,  37,  15,  24,  15,
31687      &    15,  24,  15,  37,  36,  24,  15,  24,  24,  16,
31688      &    24,  38,  39,  16,  25,  16,  16,  25,  16,  39,
31689      &    38,  25,  16,  25,  25,  17,  22,  21,  17,  21,
31690      &    20,  17,  22,   8,   1,  21,  22,  20,  17,  48,
31691      &    50,  49,   8,   1,  17,  17,  17,  21,  20,  22,
31692      &    17,  22,  21,  20,  22,  19,  12,  19,  12,   1,
31693      &     1,   8,   1,   8,   8,   1,  53,  54,   1,   1,
31694      &     8,  53,  54,  55,   1,   8,   1,   8,  54,  55,
31695      &    56,   1,   8,   8,  55,  56,   8,   1,  53,  54  /
31696       DATA (NZK(K,1),K=171,340) /
31697      &    55,   1,   8,   8,  54,  55,  56,   1,   8,   1,
31698      &     8,  53,  54,  55,   1,   8,   1,   8,  54,  55,
31699      &    56,   1,   8,   1,   8,   1,   8,  17,  21,  22,
31700      &     1,   1,   8,   1,   8,  17,  22,  20,   8,   2,
31701      &     2,   9,   2,   9,   9,   2,  67,  68,   2,   2,
31702      &     9,  67,  68,  69,   2,   9,   2,   9,  68,  69,
31703      &    70,   2,   9,   9,  69,  70,   9,   2,   9,  67,
31704      &    68,  69,   2,   9,   2,   9,  68,  69,  70,   2,
31705      &     9,   1,   8,  13,  13,  14,   1,   8,   1,   1,
31706      &     8,   8,   8,   1,   8,   1,   1,   1,   1,   1,
31707      &     8,   2,   2,   9,   9,   2,   2,   9,  15,  15,
31708      &    24,  16,  16,  25,  25,  15,  15,  24,  24,  16,
31709      &    16,  25,   1,  21,  22,  21,  48,  49,   8,  17,
31710      &    20,  17,  22,  20,  20,  22,  20,   0,   0,   0,
31711      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31712      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31713      &    31,  31,  13,   7,  15,  12,  13,  31,  17,  17  /
31714       DATA (NZK(K,1),K=341,510) /
31715      &     2,   9,  18,   9,  18,  18,  17,  21,  22,  17,
31716      &    21,  20,  17,  20,  22,  97,  98,  97,  98,  97,
31717      &    98,  17,  18,  99, 100,  18, 101,  99,  18, 101,
31718      &   100, 102, 103, 102, 103, 102, 103,  18,  16,  16,
31719      &    24,  24,  16,  25,  15,  24,  15,  15,  25,  25,
31720      &    31,  15,  15,  31,  16,  16,  23,  13,   7, 116,
31721      &   116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
31722      &   120, 121, 121, 130, 130, 130,   4,  10,  13,  10,
31723      &     4,  32,  13,  36,  11,   3,  34,  14,  38, 133,
31724      &   134, 135, 136,  21,  21,   1,  97, 104,  54,  53,
31725      &    17,  22,  21,  21,   1,  54,  53,  21,  97,  21,
31726      &    97,  22,  21,  97,  98, 105, 137, 137, 137, 138,
31727      &   139,  97,  97, 109, 109, 140, 138, 137, 139, 138,
31728      &   145,  99,  99,   2, 102, 110,  68,  67,  18, 100,
31729      &    99,  99,   2,  68,  67,  99, 102,  99, 102, 100,
31730      &    99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
31731      &   113, 115, 115, 152, 150, 149, 151, 150, 157, 140  /
31732       DATA (NZK(K,1),K=511,540) /
31733      &   141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
31734      &   140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
31735      &   150, 157, 152,  34,  32,  33,  33,  32,  33,  34  /
31736       DATA (NZK(I,1),I=541,602) /  2, 67, 68, 69,  2,  9,  9, 68, 69,
31737      & 70,  2,  9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
31738      & 14, 189, 23, 13, 15, 24,  36,  38,  37,  39, 194, 195, 196, 197,
31739      & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
31740      & 55, 8, 1, 8, 8, 54, 55, 210/
31741       DATA (NZK(K,2),K=  1,170) /
31742      &     0,   0,   0,   0,   0,   0,   0,   3,   4,   6,
31743      &     5,  23,  14,  11,   3,   5,   5,   5,  23,  13,
31744      &    23,  23,  23,   5,  23,  13,  23,  23,  23,  14,
31745      &    23,   3,  11,  13,  23,   4,  10,  14,  23,  14,
31746      &    23,  13,   7,   7,   4,   7,   7,  23,  14,  14,
31747      &    23,  14,  23,  23,  14,  14,   7,  23,  13,  23,
31748      &    14,  23,  14,  23,  13,  23,  13,  23,  14,  23,
31749      &    14,  23,  13,  23,  13,  23,  13,  33,  32,  35,
31750      &    31,  23,  14,  23,  14,  33,  34,  35,  31,  23,
31751      &    14,  23,  14,  33,  34,  35,  31,  23,  13,  23,
31752      &    13,  33,  32,  35,  31,  13,  13,  23,  23,  14,
31753      &    13,  14,  14,  25,  16,  14,  23,  13,  31,  14,
31754      &    13,  23,  25,  16,  23,  35,  33,  34,  32,  33,
31755      &    31,  31,  14,  13,  23,   0,   0,   0,   0,  13,
31756      &    23,  13,  14,  23,  14,  13,  23,  13,  78,  23,
31757      &    13,  14,  23,  13,  79,  78,  14,  23,  14,  23,
31758      &    13,  80,  79,  14,  14,  23,  80,  31,  14,  23  /
31759       DATA (NZK(K,2),K=171,340) /
31760      &    13,  79,  78,  31,  14,  23,  13,  80,  79,  23,
31761      &    13,  14,  23,  13,  79,  78,  14,  23,  14,  23,
31762      &    13,  80,  79,  23,  13,  33,  32,  15,  24,  15,
31763      &    31,  14,  23,  34,  33,  24,  24,  15,  31,  14,
31764      &    23,  14,  13,  23,  13,  14,  23,  14,  80,  23,
31765      &    14,  13,  23,  14,  79,  80,  13,  23,  13,  23,
31766      &    14,  78,  79,  13,  13,  23,  78,  23,  14,  13,
31767      &    23,  14,  79,  80,  13,  23,  13,  23,  14,  78,
31768      &    79,  62,  61,  23,  14,  23,  13,  13,  13,  23,
31769      &    13,  13,  23,  14,  14,  14,   1,   8,   8,   1,
31770      &     8,   1,   8,   8,   1,   8,   1,   8,   1,   8,
31771      &     1,   1,   8,   1,   8,   8,   1,   1,   8,   8,
31772      &     1,   8,  25,  23,  13,  31,  23,  13,  16,  14,
31773      &    35,  34,  34,  33,  31,  14,  23,   0,   0,   0,
31774      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31775      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31776      &    13,  23,  14,   7,  16,  19,  14,   7,  23,  14  /
31777       DATA (NZK(K,2),K=341,510) /
31778      &    23,  14,   7,  13,  23,  13,  13,  23,  13,  23,
31779      &    14,  13,  14,  23,  14,  23,  13,  14,  23,  14,
31780      &    23,  16,  14,  23,  14,  23,  14,  13,  13,  23,
31781      &    13,  23,  14,  13,  23,  13,  23,  15,  13,  13,
31782      &    13,  23,  13,  13,  14,  14,  14,  14,  14,  23,
31783      &    13,  16,  25,  14,  15,  24,  23,  14,   7,  23,
31784      &     7,  13,  23,   7,  14,  23,   7,  23,   7,   7,
31785      &     7,   7,   7,  13,  23,  31,   3,  11,  14, 135,
31786      &     5, 134, 134, 134, 136,   6, 133, 133, 133,   0,
31787      &     0,   0,   0,  31,  95,  25,  15,  31,  95,  16,
31788      &    32,  32,  33,  35,  39,  39,  38,  25,  13,  39,
31789      &    32,  39,  38,  35,  32,  39,  13,  23,  14,   7,
31790      &     7,  25,  37,  32,  13,  25,  13,  25,  13,  25,
31791      &    13,  31,  95,  24,  16,  31,  24,  15,  34,  34,
31792      &    33,  35,  37,  37,  36,  24,  14,  37,  34,  37,
31793      &    36,  35,  34,  37,  14,  23,  13,   7,   7,  24,
31794      &    39,  34,  14,  24,  14,  24,  14,  24,  14,   7  /
31795       DATA (NZK(K,2),K=511,540) /
31796      &     7,   7,   7,   7,   7,   7,   7,   7,  25,  13,
31797      &    25,   7,   7,   7,   7,   7,   7,   7,   7,   7,
31798      &    24,  14,  24,  13,  14,  23,  13,  23,  14,  23  /
31799       DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
31800      & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
31801      & 14, 14, 23, 14, 16, 25,
31802      & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
31803      & 23, 13, 14, 23,  0 /
31804       DATA (NZK(K,3),K=  1,170) /
31805      &     0,   0,   0,   0,   0,   0,   0,   5,   6,   5,
31806      &     6,  23,  23,   5,   5,   0,   0,   0,   0,  14,
31807      &    23,   5,   5,   0,   0,  14,  23,   5,   5,   0,
31808      &     0,   5,   5,   0,   0,   5,   5,   0,   0,   0,
31809      &     0,   0,   0,   0,   3,   0,   7,  23,  23,   7,
31810      &     0,   0,   0,   0,  23,   0,   0,   0,   0,   0,
31811      &     110*0   /
31812       DATA (NZK(K,3),K=171,340) /
31813      &     80*0,
31814      &     0,   0,   0,   0,   0,   0,  23,  13,  14,  23,
31815      &    23,  14,  23,  23,  23,  14,  23,  13,  23,  14,
31816      &    13,  23,  13,  23,  14,  23,  14,  14,  23,  13,
31817      &    13,  23,  13,  14,  23,  23,  14,  23,  13,  23,
31818      &    14,  14,   0,   0,   0,   0,   0,   0,   0,   0,
31819      &     30*0,
31820      &    14,  23,   7,   0,   0,   0,  23,   0,   0,   0  /
31821       DATA (NZK(K,3),K=341,510) /
31822      &     30*0,
31823      &     0,   0,   0,   0,   0,   0,   0,   0,   0,  23,
31824      &    14,   0,  13,   0,  14,   0,   0,  23,  13,   0,
31825      &     0,  15,   0,   0,  16,   0,   0,   0,   0,   0,
31826      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31827      &     0,   0,   0,  14,  23,   0,   0,   0,  23, 134,
31828      &   134,   0,   0,   0, 133, 133,   0,   0,   0,   0,
31829      &     80*0  /
31830       DATA (NZK(K,3),K=511,540) /
31831      &     0,   0,   0,   0,   0,   0,   0,   0,  13,  13,
31832      &    25,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31833      &    14,  14,  24,   0,   0,   0,   0,   0,   0,   0  /
31834       DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
31835      & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
31836
31837       END
31838
31839 *$ CREATE DT_BDEVAP.FOR
31840 *COPY DT_BDEVAP
31841 *
31842 *=== bdevap ===========================================================*
31843 *
31844       BLOCK DATA DT_BDEVAP
31845
31846 C     INCLUDE '(DBLPRC)'
31847 * DBLPRC.ADD
31848       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31849       SAVE
31850 * (original name: GLOBAL)
31851       PARAMETER ( KALGNM = 2 )
31852       PARAMETER ( ANGLGB = 5.0D-16 )
31853       PARAMETER ( ANGLSQ = 2.5D-31 )
31854       PARAMETER ( AXCSSV = 0.2D+16 )
31855       PARAMETER ( ANDRFL = 1.0D-38 )
31856       PARAMETER ( AVRFLW = 1.0D+38 )
31857       PARAMETER ( AINFNT = 1.0D+30 )
31858       PARAMETER ( AZRZRZ = 1.0D-30 )
31859       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
31860       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
31861       PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
31862       PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
31863       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
31864       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
31865       PARAMETER ( CSNNRM = 2.0D-15 )
31866       PARAMETER ( DMXTRN = 1.0D+08 )
31867       PARAMETER ( ZERZER = 0.D+00 )
31868       PARAMETER ( ONEONE = 1.D+00 )
31869       PARAMETER ( TWOTWO = 2.D+00 )
31870       PARAMETER ( THRTHR = 3.D+00 )
31871       PARAMETER ( FOUFOU = 4.D+00 )
31872       PARAMETER ( FIVFIV = 5.D+00 )
31873       PARAMETER ( SIXSIX = 6.D+00 )
31874       PARAMETER ( SEVSEV = 7.D+00 )
31875       PARAMETER ( EIGEIG = 8.D+00 )
31876       PARAMETER ( ANINEN = 9.D+00 )
31877       PARAMETER ( TENTEN = 10.D+00 )
31878       PARAMETER ( HLFHLF = 0.5D+00 )
31879       PARAMETER ( ONETHI = ONEONE / THRTHR )
31880       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
31881       PARAMETER ( ONEFOU = ONEONE / FOUFOU )
31882       PARAMETER ( THRTWO = THRTHR / TWOTWO )
31883       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
31884       PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
31885       PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
31886       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
31887       PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
31888       PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
31889       PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
31890       PARAMETER ( EULERO = 0.577215664901532860606512      D+00 )
31891       PARAMETER ( EULEXP = 1.781072417990197985236504      D+00 )
31892       PARAMETER ( EULLOG =-0.5495393129816448223376619     D+00 )
31893       PARAMETER ( E1M2EU = 0.8569023337737540831433017     D+00 )
31894       PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
31895       PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
31896       PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
31897       PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
31898       PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
31899       PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
31900       PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
31901       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
31902       PARAMETER ( CLIGHT = 2.99792458         D+10 )
31903       PARAMETER ( AVOGAD = 6.0221367          D+23 )
31904       PARAMETER ( BOLTZM = 1.380658           D-23 )
31905       PARAMETER ( AMELGR = 9.1093897          D-28 )
31906       PARAMETER ( PLCKBR = 1.05457266         D-27 )
31907       PARAMETER ( ELCCGS = 4.8032068          D-10 )
31908       PARAMETER ( ELCMKS = 1.60217733         D-19 )
31909       PARAMETER ( AMUGRM = 1.6605402          D-24 )
31910       PARAMETER ( AMMUMU = 0.113428913        D+00 )
31911       PARAMETER ( AMPRMU = 1.007276470        D+00 )
31912       PARAMETER ( AMNEMU = 1.008664904        D+00 )
31913       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
31914       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
31915       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
31916       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
31917       PARAMETER ( PLABRC = 0.197327053        D+00 )
31918       PARAMETER ( AMELCT = 0.51099906         D-03 )
31919       PARAMETER ( AMUGEV = 0.93149432         D+00 )
31920       PARAMETER ( AMMUON = 0.105658389        D+00 )
31921       PARAMETER ( AMPRTN = 0.93827231         D+00 )
31922       PARAMETER ( AMNTRN = 0.93956563         D+00 )
31923       PARAMETER ( AMDEUT = 1.87561339         D+00 )
31924       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
31925      &                   * 1.D-09 )
31926       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
31927       PARAMETER ( BLTZMN = 8.617385           D-14 )
31928       PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
31929       PARAMETER ( GFOHB3 = 1.16639            D-05 )
31930       PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
31931       PARAMETER ( SIN2TW = 0.2319             D+00 )
31932       PARAMETER ( GEVMEV = 1.0                D+03 )
31933       PARAMETER ( EMVGEV = 1.0                D-03 )
31934       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
31935       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
31936       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
31937       LOGICAL LGBIAS, LGBANA
31938       COMMON /FKGLOB/ LGBIAS, LGBANA
31939 C     INCLUDE '(DIMPAR)'
31940 * DIMPAR.ADD
31941       PARAMETER ( MXXRGN = 5000 )
31942       PARAMETER ( MXXMDF = 82   )
31943       PARAMETER ( MXXMDE = 54   )
31944       PARAMETER ( MFSTCK = 1000 )
31945       PARAMETER ( MESTCK = 100  )
31946       PARAMETER ( NELEMX = 80   )
31947       PARAMETER ( MPDPDX = 8    )
31948       PARAMETER ( ICOMAX = 180  )
31949       PARAMETER ( NSTBIS = 304  )
31950       PARAMETER ( IDMAXP = 220  )
31951       PARAMETER ( IDMXDC = 640  )
31952       PARAMETER ( MKBMX1 = 1    )
31953       PARAMETER ( MKBMX2 = 1    )
31954 C     INCLUDE '(IOUNIT)'
31955 * IOUNIT.ADD
31956       PARAMETER ( LUNIN  =  5 )
31957       PARAMETER ( LUNOUT =  6 )
31958 **sr 19.5. set error output-unit from 15 to 6
31959       PARAMETER ( LUNERR = 6  )
31960       PARAMETER ( LUNBER = 14 )
31961       PARAMETER ( LUNECH =  8 )
31962       PARAMETER ( LUNFLU = 13 )
31963       PARAMETER ( LUNGEO = 16 )
31964       PARAMETER ( LUNPMF = 12 )
31965       PARAMETER ( LUNRAN =  2 )
31966       PARAMETER ( LUNXSC =  9 )
31967       PARAMETER ( LUNDET = 17 )
31968       PARAMETER ( LUNRAY = 10 )
31969       PARAMETER ( LUNRDB =  1 )
31970       PARAMETER ( LUNPGO =  7 )
31971       PARAMETER ( LUNPGS =  4 )
31972       PARAMETER ( LUNSCR =  3 )
31973 *
31974 *----------------------------------------------------------------------*
31975 *                                                                      *
31976 *     Block Data for the EVAPoration routines:                         *
31977 *                                                                      *
31978 *     Created on    20 may 1990    by    Alfredo Ferrari & Paola Sala  *
31979 *                                                   Infn - Milan       *
31980 *                                                                      *
31981 *     Modified from the original version of J.M.Zazula                 *
31982 *     and, for cookcm, from a LAHET block data kindly provided by      *
31983 *     R.E.Prael-LANL                                                   *
31984 *                                                                      *
31985 *     Last change on  20-feb-95    by    Alfredo Ferrari               *
31986 *                                                                      *
31987 *                                                                      *
31988 *----------------------------------------------------------------------*
31989 *
31990 * (original name: COOKCM)
31991       PARAMETER ( ASMTOG = SIXSIX / PIPIPI**2 )
31992       LOGICAL LDEFOZ, LDEFON
31993       PARAMETER ( INCOOK = 150, IZCOOK = 98 )
31994       COMMON /FKCOOK/ ALPIGN, BETIGN, GAMIGN, POWIGN,
31995      &                SZCOOK (IZCOOK), SNCOOK (INCOOK), PZCOOK (IZCOOK),
31996      &                PNCOOK (INCOOK), LDEFOZ (IZCOOK), LDEFON (INCOOK)
31997 * (original name: EVA0)
31998       COMMON /FKEVA0/ Y0, B0, P0 (1001), P1 (1001), P2 (1001),
31999      *                FLA (6), FLZ (6), RHO (6), OMEGA (6), EXMASS (6),
32000      *                CAM2 (130), CAM3 (200), CAM4 (130), CAM5 (200),
32001      *                T (4,7), RMASS (297), ALPH (297), BET (297),
32002      *                APRIME (250), IA (6), IZ (6)
32003 * (original name: HETTP)
32004       COMMON /FKHETP/  NHSTP,NBERTP,IOSUB,INSRS
32005 * (original name: HETC7)
32006       COMMON /FKHET7/ COSKS,SINKS, COSTH,SINTH, COSPHI,SINPHI
32007 * (original name: INPFLG)
32008       COMMON /FKINPF/ IANG,IFISS,IB0,IGEOM,ISTRAG,KEYDK
32009 *
32010       DATA B0   / 8.D+00 /, Y0 / 1.5D+00 /
32011       DATA IANG / 1 /, IFISS / 1 /,  IB0 / 2 /, IGEOM / 0 /
32012       DATA ISTRAG /0/, KEYDK /0/
32013       DATA NBERTP /LUNBER/
32014       DATA COSTH /ONEONE/, SINTH /ZERZER/, COSPHI /ONEONE/,
32015      &     SINPHI/ZERZER/
32016 *  /cookcm/
32017        DATA ( PZCOOK(I),I =  1, IZCOOK ) /
32018      & 0.000D+00, 5.440D+00, 0.000D+00, 2.760D+00, 0.000D+00, 3.340D+00,
32019      & 0.000D+00, 2.700D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.460D+00,
32020      & 0.000D+00, 2.090D+00, 0.000D+00, 1.620D+00, 0.000D+00, 1.620D+00,
32021      & 0.000D+00, 1.830D+00, 0.000D+00, 1.730D+00, 0.000D+00, 1.350D+00,
32022      & 0.000D+00, 1.540D+00, 0.000D+00, 1.280D+00, 2.600D-01, 8.800D-01,
32023      & 1.900D-01, 1.350D+00,-5.000D-02, 1.520D+00,-9.000D-02, 1.170D+00,
32024      & 4.000D-02, 1.240D+00, 2.900D-01, 1.090D+00, 2.600D-01, 1.170D+00,
32025      & 2.300D-01, 1.150D+00,-8.000D-02, 1.350D+00, 3.400D-01, 1.050D+00,
32026      & 2.800D-01, 1.270D+00, 0.000D+00, 1.050D+00, 0.000D+00, 1.000D+00,
32027      & 9.000D-02, 1.200D+00, 2.000D-01, 1.400D+00, 9.300D-01, 1.000D+00,
32028      &-2.000D-01, 1.190D+00, 9.000D-02, 9.700D-01, 0.000D+00, 9.200D-01,
32029      & 1.100D-01, 6.800D-01, 5.000D-02, 6.800D-01,-2.200D-01, 7.900D-01,
32030      & 9.000D-02, 6.900D-01, 1.000D-02, 7.200D-01, 0.000D+00, 4.000D-01,
32031      & 1.600D-01, 7.300D-01, 0.000D+00, 4.600D-01, 1.700D-01, 8.900D-01,
32032      & 0.000D+00, 7.900D-01, 0.000D+00, 8.900D-01, 0.000D+00, 8.100D-01,
32033      &-6.000D-02, 6.900D-01,-2.000D-01, 7.100D-01,-1.200D-01, 7.200D-01,
32034      & 0.000D+00, 7.700D-01/
32035        DATA ( PNCOOK(I),I =  1, 90 ) /
32036      & 0.000D+00, 5.980D+00, 0.000D+00, 2.770D+00, 0.000D+00, 3.160D+00,
32037      & 0.000D+00, 3.010D+00, 0.000D+00, 2.500D+00, 0.000D+00, 2.670D+00,
32038      & 0.000D+00, 1.800D+00, 0.000D+00, 1.670D+00, 0.000D+00, 1.860D+00,
32039      & 0.000D+00, 2.040D+00, 0.000D+00, 1.640D+00, 0.000D+00, 1.440D+00,
32040      & 0.000D+00, 1.540D+00, 0.000D+00, 1.300D+00, 0.000D+00, 1.270D+00,
32041      & 0.000D+00, 1.290D+00, 8.000D-02, 1.410D+00,-8.000D-02, 1.500D+00,
32042      &-5.000D-02, 2.240D+00,-4.700D-01, 1.430D+00,-1.500D-01, 1.440D+00,
32043      & 6.000D-02, 1.560D+00, 2.500D-01, 1.570D+00,-1.600D-01, 1.460D+00,
32044      & 0.000D+00, 9.300D-01, 1.000D-02, 6.200D-01,-5.000D-01, 1.420D+00,
32045      & 1.300D-01, 1.520D+00,-6.500D-01, 8.000D-01,-8.000D-02, 1.290D+00,
32046      &-4.700D-01, 1.250D+00,-4.400D-01, 9.700D-01, 8.000D-02, 1.650D+00,
32047      &-1.100D-01, 1.260D+00,-4.600D-01, 1.060D+00, 2.200D-01, 1.550D+00,
32048      &-7.000D-02, 1.370D+00, 1.000D-01, 1.200D+00,-2.700D-01, 9.200D-01,
32049      &-3.500D-01, 1.190D+00, 0.000D+00, 1.050D+00,-2.500D-01, 1.610D+00,
32050      &-2.100D-01, 9.000D-01,-2.100D-01, 7.400D-01,-3.800D-01, 7.200D-01/
32051        DATA ( PNCOOK(I),I = 91, INCOOK ) /
32052      &-3.400D-01, 9.200D-01,-2.600D-01, 9.400D-01, 1.000D-02, 6.500D-01,
32053      &-3.600D-01, 8.300D-01, 1.100D-01, 6.700D-01, 5.000D-02, 1.000D+00,
32054      & 5.100D-01, 1.040D+00, 3.300D-01, 6.800D-01,-2.700D-01, 8.100D-01,
32055      & 9.000D-02, 7.500D-01, 1.700D-01, 8.600D-01, 1.400D-01, 1.100D+00,
32056      &-2.200D-01, 8.400D-01,-4.700D-01, 4.800D-01, 2.000D-02, 8.800D-01,
32057      & 2.400D-01, 5.200D-01, 2.700D-01, 4.100D-01,-5.000D-02, 3.800D-01,
32058      & 1.500D-01, 6.700D-01, 0.000D+00, 6.100D-01, 0.000D+00, 7.800D-01,
32059      & 0.000D+00, 6.700D-01, 0.000D+00, 6.700D-01, 0.000D+00, 7.900D-01,
32060      & 0.000D+00, 6.000D-01, 4.000D-02, 6.400D-01,-6.000D-02, 4.500D-01,
32061      & 5.000D-02, 2.600D-01,-2.200D-01, 3.900D-01, 0.000D+00, 3.900D-01/
32062        DATA ( SZCOOK(I),I =  1, 98) /
32063      & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
32064      & 0.000D+00, 0.000D+00,-1.100D-01,-8.100D-01,-2.910D+00,-4.170D+00,
32065      &-5.720D+00,-7.800D+00,-8.970D+00,-9.700D+00,-1.010D+01,-1.070D+01,
32066      &-1.138D+01,-1.207D+01,-1.255D+01,-1.324D+01,-1.393D+01,-1.471D+01,
32067      &-1.553D+01,-1.637D+01,-1.736D+01,-1.860D+01,-1.870D+01,-1.801D+01,
32068      &-1.787D+01,-1.708D+01,-1.660D+01,-1.675D+01,-1.650D+01,-1.635D+01,
32069      &-1.622D+01,-1.641D+01,-1.689D+01,-1.643D+01,-1.668D+01,-1.673D+01,
32070      &-1.745D+01,-1.729D+01,-1.744D+01,-1.782D+01,-1.862D+01,-1.827D+01,
32071      &-1.939D+01,-1.991D+01,-1.914D+01,-1.826D+01,-1.740D+01,-1.642D+01,
32072      &-1.577D+01,-1.437D+01,-1.391D+01,-1.310D+01,-1.311D+01,-1.143D+01,
32073      &-1.089D+01,-1.075D+01,-1.062D+01,-1.041D+01,-1.021D+01,-9.850D+00,
32074      &-9.470D+00,-9.030D+00,-8.610D+00,-8.130D+00,-7.460D+00,-7.480D+00,
32075      &-7.200D+00,-7.130D+00,-7.060D+00,-6.780D+00,-6.640D+00,-6.640D+00,
32076      &-7.680D+00,-7.890D+00,-8.410D+00,-8.490D+00,-7.880D+00,-6.300D+00,
32077      &-5.470D+00,-4.780D+00,-4.370D+00,-4.170D+00,-4.130D+00,-4.320D+00,
32078      &-4.550D+00,-5.040D+00,-5.280D+00,-6.060D+00,-6.280D+00,-6.870D+00,
32079      &-7.200D+00,-7.740D+00/
32080        DATA ( SNCOOK(I),I =  1, 90 ) /
32081      & 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
32082      & 0.000D+00, 0.000D+00, 1.030D+01, 5.660D+00, 6.800D+00, 7.530D+00,
32083      & 7.550D+00, 7.210D+00, 7.440D+00, 8.070D+00, 8.940D+00, 9.810D+00,
32084      & 1.060D+01, 1.139D+01, 1.254D+01, 1.368D+01, 1.434D+01, 1.419D+01,
32085      & 1.383D+01, 1.350D+01, 1.300D+01, 1.213D+01, 1.260D+01, 1.326D+01,
32086      & 1.413D+01, 1.492D+01, 1.552D+01, 1.638D+01, 1.716D+01, 1.755D+01,
32087      & 1.803D+01, 1.759D+01, 1.903D+01, 1.871D+01, 1.880D+01, 1.899D+01,
32088      & 1.846D+01, 1.825D+01, 1.776D+01, 1.738D+01, 1.672D+01, 1.562D+01,
32089      & 1.438D+01, 1.288D+01, 1.323D+01, 1.381D+01, 1.490D+01, 1.486D+01,
32090      & 1.576D+01, 1.620D+01, 1.762D+01, 1.773D+01, 1.816D+01, 1.867D+01,
32091      & 1.969D+01, 1.951D+01, 2.017D+01, 1.948D+01, 1.998D+01, 1.983D+01,
32092      & 2.020D+01, 1.972D+01, 1.987D+01, 1.924D+01, 1.844D+01, 1.761D+01,
32093      & 1.710D+01, 1.616D+01, 1.590D+01, 1.533D+01, 1.476D+01, 1.354D+01,
32094      & 1.263D+01, 1.065D+01, 1.010D+01, 8.890D+00, 1.025D+01, 9.790D+00,
32095      & 1.139D+01, 1.172D+01, 1.243D+01, 1.296D+01, 1.343D+01, 1.337D+01/
32096        DATA ( SNCOOK(I),I = 91, INCOOK ) /
32097      & 1.296D+01, 1.211D+01, 1.192D+01, 1.100D+01, 1.080D+01, 1.042D+01,
32098      & 1.039D+01, 9.690D+00, 9.270D+00, 8.930D+00, 8.570D+00, 8.020D+00,
32099      & 7.590D+00, 7.330D+00, 7.230D+00, 7.050D+00, 7.420D+00, 6.750D+00,
32100      & 6.600D+00, 6.380D+00, 6.360D+00, 6.490D+00, 6.250D+00, 5.850D+00,
32101      & 5.480D+00, 4.530D+00, 4.300D+00, 3.390D+00, 2.350D+00, 1.660D+00,
32102      & 8.100D-01, 4.600D-01,-9.600D-01,-1.690D+00,-2.530D+00,-3.160D+00,
32103      &-1.870D+00,-4.100D-01, 7.100D-01, 1.660D+00, 2.620D+00, 3.220D+00,
32104      & 3.760D+00, 4.100D+00, 4.460D+00, 4.830D+00, 5.090D+00, 5.180D+00,
32105      & 5.170D+00, 5.100D+00, 5.010D+00, 4.970D+00, 5.090D+00, 5.030D+00,
32106      & 4.930D+00, 5.280D+00, 5.490D+00, 5.500D+00, 5.370D+00, 5.300D+00/
32107       DATA LDEFOZ / 53*.FALSE.,25*.TRUE.,7*.FALSE.,13*.TRUE. /
32108       DATA LDEFON / 85*.FALSE.,37*.TRUE.,7*.FALSE.,21*.TRUE. /
32109 *=== End of Block Data Bdevap =========================================*
32110       END
32111
32112 *$ CREATE DT_BDNOPT.FOR
32113 *COPY DT_BDNOPT
32114 *
32115 *=== bdnopt ===========================================================*
32116 *==                                                                    *
32117       BLOCK DATA DT_BDNOPT
32118
32119 C     INCLUDE '(DBLPRC)'
32120 * DBLPRC.ADD
32121       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32122       SAVE
32123 * (original name: GLOBAL)
32124       PARAMETER ( KALGNM = 2 )
32125       PARAMETER ( ANGLGB = 5.0D-16 )
32126       PARAMETER ( ANGLSQ = 2.5D-31 )
32127       PARAMETER ( AXCSSV = 0.2D+16 )
32128       PARAMETER ( ANDRFL = 1.0D-38 )
32129       PARAMETER ( AVRFLW = 1.0D+38 )
32130       PARAMETER ( AINFNT = 1.0D+30 )
32131       PARAMETER ( AZRZRZ = 1.0D-30 )
32132       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
32133       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
32134       PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
32135       PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
32136       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
32137       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
32138       PARAMETER ( CSNNRM = 2.0D-15 )
32139       PARAMETER ( DMXTRN = 1.0D+08 )
32140       PARAMETER ( ZERZER = 0.D+00 )
32141       PARAMETER ( ONEONE = 1.D+00 )
32142       PARAMETER ( TWOTWO = 2.D+00 )
32143       PARAMETER ( THRTHR = 3.D+00 )
32144       PARAMETER ( FOUFOU = 4.D+00 )
32145       PARAMETER ( FIVFIV = 5.D+00 )
32146       PARAMETER ( SIXSIX = 6.D+00 )
32147       PARAMETER ( SEVSEV = 7.D+00 )
32148       PARAMETER ( EIGEIG = 8.D+00 )
32149       PARAMETER ( ANINEN = 9.D+00 )
32150       PARAMETER ( TENTEN = 10.D+00 )
32151       PARAMETER ( HLFHLF = 0.5D+00 )
32152       PARAMETER ( ONETHI = ONEONE / THRTHR )
32153       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
32154       PARAMETER ( ONEFOU = ONEONE / FOUFOU )
32155       PARAMETER ( THRTWO = THRTHR / TWOTWO )
32156       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
32157       PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
32158       PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
32159       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
32160       PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
32161       PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
32162       PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
32163       PARAMETER ( EULERO = 0.577215664901532860606512      D+00 )
32164       PARAMETER ( EULEXP = 1.781072417990197985236504      D+00 )
32165       PARAMETER ( EULLOG =-0.5495393129816448223376619     D+00 )
32166       PARAMETER ( E1M2EU = 0.8569023337737540831433017     D+00 )
32167       PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
32168       PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
32169       PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
32170       PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
32171       PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
32172       PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
32173       PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
32174       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
32175       PARAMETER ( CLIGHT = 2.99792458         D+10 )
32176       PARAMETER ( AVOGAD = 6.0221367          D+23 )
32177       PARAMETER ( BOLTZM = 1.380658           D-23 )
32178       PARAMETER ( AMELGR = 9.1093897          D-28 )
32179       PARAMETER ( PLCKBR = 1.05457266         D-27 )
32180       PARAMETER ( ELCCGS = 4.8032068          D-10 )
32181       PARAMETER ( ELCMKS = 1.60217733         D-19 )
32182       PARAMETER ( AMUGRM = 1.6605402          D-24 )
32183       PARAMETER ( AMMUMU = 0.113428913        D+00 )
32184       PARAMETER ( AMPRMU = 1.007276470        D+00 )
32185       PARAMETER ( AMNEMU = 1.008664904        D+00 )
32186       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
32187       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
32188       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
32189       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
32190       PARAMETER ( PLABRC = 0.197327053        D+00 )
32191       PARAMETER ( AMELCT = 0.51099906         D-03 )
32192       PARAMETER ( AMUGEV = 0.93149432         D+00 )
32193       PARAMETER ( AMMUON = 0.105658389        D+00 )
32194       PARAMETER ( AMPRTN = 0.93827231         D+00 )
32195       PARAMETER ( AMNTRN = 0.93956563         D+00 )
32196       PARAMETER ( AMDEUT = 1.87561339         D+00 )
32197       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
32198      &                   * 1.D-09 )
32199       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
32200       PARAMETER ( BLTZMN = 8.617385           D-14 )
32201       PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
32202       PARAMETER ( GFOHB3 = 1.16639            D-05 )
32203       PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
32204       PARAMETER ( SIN2TW = 0.2319             D+00 )
32205       PARAMETER ( GEVMEV = 1.0                D+03 )
32206       PARAMETER ( EMVGEV = 1.0                D-03 )
32207       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
32208       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
32209       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
32210       LOGICAL LGBIAS, LGBANA
32211       COMMON /FKGLOB/ LGBIAS, LGBANA
32212 C     INCLUDE '(DIMPAR)'
32213 * DIMPAR.ADD
32214       PARAMETER ( MXXRGN = 5000 )
32215       PARAMETER ( MXXMDF = 82   )
32216       PARAMETER ( MXXMDE = 54   )
32217       PARAMETER ( MFSTCK = 1000 )
32218       PARAMETER ( MESTCK = 100  )
32219       PARAMETER ( NELEMX = 80   )
32220       PARAMETER ( MPDPDX = 8    )
32221       PARAMETER ( ICOMAX = 180  )
32222       PARAMETER ( NSTBIS = 304  )
32223       PARAMETER ( IDMAXP = 220  )
32224       PARAMETER ( IDMXDC = 640  )
32225       PARAMETER ( MKBMX1 = 1    )
32226       PARAMETER ( MKBMX2 = 1    )
32227 C     INCLUDE '(IOUNIT)'
32228 * IOUNIT.ADD
32229       PARAMETER ( LUNIN  =  5 )
32230       PARAMETER ( LUNOUT =  6 )
32231 **sr 19.5. set error output-unit from 15 to 6
32232       PARAMETER ( LUNERR = 6  )
32233       PARAMETER ( LUNBER = 14 )
32234       PARAMETER ( LUNECH =  8 )
32235       PARAMETER ( LUNFLU = 13 )
32236       PARAMETER ( LUNGEO = 16 )
32237       PARAMETER ( LUNPMF = 12 )
32238       PARAMETER ( LUNRAN =  2 )
32239       PARAMETER ( LUNXSC =  9 )
32240       PARAMETER ( LUNDET = 17 )
32241       PARAMETER ( LUNRAY = 10 )
32242       PARAMETER ( LUNRDB =  1 )
32243       PARAMETER ( LUNPGO =  7 )
32244       PARAMETER ( LUNPGS =  4 )
32245       PARAMETER ( LUNSCR =  3 )
32246 *
32247 *----------------------------------------------------------------------*
32248 *                                                                      *
32249 *   Created on  20 september 1989    by  Alfredo Ferrari - Infn Milan  *
32250 *                                                                      *
32251 *         Last change on 20-apr-95   by  Alfredo Ferrari               *
32252 *                                                                      *
32253 *----------------------------------------------------------------------*
32254 *
32255 C     INCLUDE '(BLNKCM)'
32256 * BLNKCM.ADD
32257 **sr 17.5. commented since not used here
32258 C     PARAMETER ( NBLNMX = 1100000 )
32259 C     DIMENSION GMSTOR ( NBLNMX ), BRMBRR ( NBLNMX ), BRMEXP ( NBLNMX ),
32260 C    &          BRMSIG ( NBLNMX ), SIGGTT ( KALGNM*NBLNMX ),
32261 C    &          COMSCO ( NBLNMX ), LBSTOR ( KALGNM*NBLNMX )
32262 C     REAL SIGGTT
32263 C     LOGICAL LBSTOR
32264 C     COMMON   NSTOR  ( KALGNM*NBLNMX )
32265 **
32266 **sr 18.5. commented since not used for evap.
32267 C     COMMON / ADDRCM / MBLNMX, KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST,
32268 C    &                  KISBGN, KISLST, KDTBGN, KDTLST, KUBBGN, KUBLST,
32269 C    &                  KUXBGN, KUXLST, KTCBGN, KTCLST, KRNBGN, KRNLST,
32270 C    &                  KYLBGN, KYLLST, KXSBGN, KXSLST, KIHBGN, KIHLST,
32271 C    &                  KINBGN, KINLST, KIEBGN, KIELST, KETBGN, KETLST,
32272 C    &                  KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST,
32273 C    &                  KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST,
32274 C    &                  KWLBGN, KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST,
32275 C    &                  KWSBGN, KWSLST, KNDBGN, KNDLST, KDPBGN, KDPLST,
32276 C    &                  KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN, KBRLST,
32277 C    &                  KTMBGN
32278 **
32279
32280 C     EQUIVALENCE ( NSTOR (1), GMSTOR (1) )
32281 C     EQUIVALENCE ( NSTOR (1), BRMBRR (1) )
32282 C     EQUIVALENCE ( NSTOR (1), BRMEXP (1) )
32283 C     EQUIVALENCE ( NSTOR (1), BRMSIG (1) )
32284 C     EQUIVALENCE ( NSTOR (1), COMSCO (1) )
32285 C     EQUIVALENCE ( NSTOR (1), SIGGTT (1) )
32286 C     EQUIVALENCE ( NSTOR (1), LBSTOR (1) )
32287 C     INCLUDE '(BLNTMP)'
32288 * BLNTMP.ADD
32289 **sr 18.5. commented since not used for evap.
32290 C     COMMON / BLNTMP / KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM,
32291 C    &                  KGCBTM, KGDWTM, KBDWTM, KWLOTM, KWHITM, KWMUTM,
32292 C    &                  KWSHTM, KEXTTM, KSTXTM, KSTNTM, KECTTM, KPCTTM,
32293 C    &                  KLPBTM, NXXRGN
32294 **
32295 C     INCLUDE '(CMMDNR)'
32296 * CMMDNR.ADD
32297 **sr 18.5. commented since not used for evap.
32298 C     LOGICAL LFLDNR
32299 C     COMMON / CMMDNR / DDNEAR, LFLDNR
32300 **
32301 C     INCLUDE '(CTITLE)'
32302 * CTITLE.ADD
32303 **sr 18.5. commented since not used for evap.
32304 C     CHARACTER RUNTIT*80, RUNTIM*32, RUNKEY*10
32305 C     COMMON / CTITLE / RUNTIT, RUNTIM, RUNKEY
32306 C     COMMON / CEXPCK / ITEXPI, ITEXMX
32307 **
32308 C     INCLUDE '(DETECT)'
32309 * DETECT.ADD
32310 **sr 18.5. commented since not used for evap.
32311 C     PARAMETER (NRGNMX = 10)
32312 C     PARAMETER (NDTCMX = 10)
32313 C     PARAMETER (NSCRMX = 10)
32314 C     PARAMETER (NDTBIN = 1024)
32315 C     CHARACTER*10 TITDET,TITSCO
32316 C     LOGICAL LDTCTR
32317 C     COMMON /DETCT/  EDTMIN(NDTCMX), EDTBIN(NDTCMX), EDTCUT(NDTCMX),
32318 C    &                KDTREG(NRGNMX,NDTCMX), KDTDET(NDTCMX,NSCRMX),
32319 C    &                NDTSCO, NDTDET, LDTCTR, IDTREG(MXXRGN),
32320 C    &                KDTSCD(NSCRMX)
32321 C     COMMON /DETCH/  TITDET(NDTCMX), TITSCO(NSCRMX)
32322 **
32323 C     INCLUDE '(DETLOC)'
32324 * DETLOC.ADD
32325 **sr 18.5. commented since not used for evap.
32326 C     PARAMETER (NDTCM2 = 10)
32327 C     COMMON /DETLOC/ ACCUMP (NDTCM2), ACCUMN (NDTCM2),
32328 C    &                ICOINC(NDTCM2), NCLAS
32329 **
32330 C     INCLUDE '(EMGTRN)'
32331 * EMGTRN.ADD
32332 **sr 18.5. commented since not used for evap.
32333 C     LOGICAL LMCSMG
32334 C     COMMON / EMGTRN / UMCSMG, VMCSMG, WMCSMG, LMCSMG
32335 **
32336 C     INCLUDE '(EMSHO)'
32337 * EMSHO.ADD
32338 **sr 18.5. commented since not used for evap.
32339 C     LOGICAL EMFLO, EMFHLO, EMFELO, LIMPRE, LEXPTE
32340 C     COMMON /EMSHO/ EMFETH, EMFPTH, EMFHET, EMFHPT, EMFBIA, EMFLO,
32341 C    &               EMFHLO, EMFELO, LIMPRE, LEXPTE
32342 **
32343 C     INCLUDE '(EPISOR)'
32344 * EPISOR.ADD
32345 **sr 18.5. commented since not used for evap.
32346 C     LOGICAL LUSSRC
32347 C     COMMON/EPISOR/TKESUM,LUSSRC
32348 **
32349 * (original name: FHEAVY,FHEAVC)
32350       PARAMETER ( MXHEAV = 100 )
32351       CHARACTER*8 ANHEAV
32352       COMMON /FKFHVY/ CXHEAV (MXHEAV), CYHEAV (MXHEAV),
32353      &                CZHEAV (MXHEAV), TKHEAV (MXHEAV),
32354      &                PHEAVY (MXHEAV), WHEAVY (MXHEAV),
32355      &                AMHEAV  ( 12 ) , AMNHEA  ( 12 ) ,
32356      &                KHEAVY (MXHEAV), ICHEAV  ( 12 ) ,
32357      &                IBHEAV  ( 12 ) , NPHEAV
32358       COMMON /FKFHVC/ ANHEAV  ( 12 )
32359 * (original name: FINUC)
32360       PARAMETER (MXP=999)
32361       COMMON /FKFINU/ CXR    (MXP), CYR    (MXP), CZR    (MXP),
32362      &                CXRPOL (MXP), CYRPOL (MXP), CZRPOL (MXP),
32363      &                TKI    (MXP), PLR    (MXP), WEI    (MXP),
32364      &                TV, TVCMS, TVRECL, TVHEAV, TVBIND, NP0, NP,
32365      &                KPART  (MXP)
32366 C     INCLUDE '(GENTHR)'
32367 * GENTHR.ADD
32368 **sr 18.5. commented since not used for evap.
32369 C     COMMON / GENTHR / PEANCT, PEAPIT, PLDNCT, PTHRSH (NALLWP),
32370 C    &                  PTHDFF (NALLWP), IJNUCR (NALLWP)
32371 **
32372 C     INCLUDE '(LOWNEU)'
32373 * LOWNEU.ADD
32374 **sr 18.5. commented since not used for evap.
32375 C     PARAMETER ( MXGTHN =  15 )
32376 C     PARAMETER ( MXGLWN = 200 )
32377 C     PARAMETER ( MXSHPP =   5 )
32378 C     LOGICAL LCOMPN, LIMPRN, LBIASN, LDOWNN, LRECPR, LLOWWW, LLOWET
32379 C     CHARACTER*10 TITLOW
32380 C     COMMON / LOWNEU / ATOLOW (MXXMDF), WSHPLN (MXGLWN,MXSHPP), EXTWWL,
32381 C    &                  SHPIMP (MXGLWN), EXTETL (MXGLWN), WWAMFL,
32382 C    &                  VLLNTH (MXGTHN,MXXMDF), ABLNTH (MXGTHN,MXXMDF),
32383 C    &                  STLNTH (MXGTHN,MXXMDF), TMRTLN (MXXMDF),
32384 C    &                  TMNMLN (MXXMDF), ICHCPT (MXXMDF),
32385 C    &                  IGTMRT (MXXMDF), NEUMED (MXXMDF),
32386 C    &                  ID1MED (MXXMDF), ID2MED (MXXMDF),
32387 C    &                  ID3MED (MXXMDF), MGTMED (MXXMDF),
32388 C    &                  LCOMPN (MXXMDF), LRECPR (MXXMDF), KPRLOW, NMGP,
32389 C    &                  NMTG  , IGRTHN, LIMPRN, LBIASN, LDOWNN, LLOWWW,
32390 C    &                  LLOWET, ICLMED, IKRBGN, INABGN, IDWBGN, IETBGN,
32391 C    &                  I0XSEC, IDXSEC, ISENAV, ISVELN, ISPNAV, IWWLWB,
32392 C    &                  IWWLWT, IPXBGN, NPXSEC
32393 C     COMMON / CHLWNT / TITLOW (MXXMDF)
32394 **
32395 C     INCLUDE '(LTCLCM)'
32396 * LTCLCM.ADD
32397 **sr 18.5. commented since not used for evap.
32398 C     COMMON / LTCLCM / MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1
32399 **
32400 C     INCLUDE '(MULBOU)'
32401 * MULBOU.ADD
32402 **sr 18.5. commented since not used for evap.
32403 C     LOGICAL LLDA  , LAGAIN, LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR
32404 C     COMMON / MULBOU / UOLD  , VOLD  , WOLD  , UMAG  , VMAG  , WMAG  ,
32405 C    &                  UNORML, VNORML, WNORML, USENSE, VSENSE, WSENSE,
32406 C    &                  TSENSE, DDSENS, DSMALL, NSSENS, LLDA  , LAGAIN,
32407 C    &                  LSTNEW, LARTEF, LNORML, LSENSE, LMGNOR
32408 **
32409 C     INCLUDE '(MULHD)'
32410 * MULHD.ADD
32411 **sr 18.5. commented since not used for evap.
32412 C     PARAMETER ( MXXPT1 = 1 )
32413 C     PARAMETER ( TIMESS = 2.00D+00 )
32414 C     PARAMETER ( TMSRLX = 1.50D+00 )
32415 C     PARAMETER ( EPSINS = 0.15D+00 )
32416 C     PARAMETER ( EPSRLX = 0.50D+00 )
32417 C     PARAMETER ( SQEPSN = 0.3872983346207417 D+00 )
32418 C     PARAMETER ( SQEPSR = 0.7071067811865475 D+00 )
32419 C     PARAMETER ( PARNSI = 1.732050807568877 D+00 * SQEPSN )
32420 C     PARAMETER ( PRNSR0 = 1.732050807568877 D+00 * SQEPSR )
32421 C     PARAMETER ( R0NCMS = 1.20 D+00 )
32422 C     LOGICAL LTOPT, LSRCRH, LNSCRH
32423 C     COMMON / MULHD / BLCC   ( MXXMDF ), BLCCRA ( MXXMDF ),
32424 C    &                 XCC    ( MXXMDF ), ZTILDE ( MXXMDF, 0:MXXPT1 ),
32425 C    &                 ALPZTL ( MXXMDF, 0:MXXPT1 ), RLDU   ( MXXMDF ),
32426 C    &                 ALPZT2 ( MXXMDF, 0:MXXPT1 ), TEFF0  ( MXXMDF ),
32427 C    &                 XR0    ( MXXMDF ), ECUTM  ( MXXMDF, 39, 2 ),
32428 C    &                 ESTEPF ( MXXMDF ), HTHNSZ ( MXXMDF, 39 ),
32429 C    &                 AE1O3  ( MXXMDF ), PARNSR ( MXXMDF ),
32430 C    &                 HEESLI ( MXXMDF ), THMSPR, THMSSC, HMSAMP,
32431 C    &                 HMREJE, LSRCRH ( MXXMDF ), LNSCRH ( MXXMDF ),
32432 C    &                 LTOPT  ( MXXMDF ), NFSCAT
32433 **
32434 * (original name: PAREVT)
32435       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
32436      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LLVMOD, LSCHDF
32437       PARAMETER ( NALLWP = 39   )
32438       COMMON /FKPARE/ DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC,
32439      &                LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
32440      &                LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
32441      &                ILVMOD, JLVMOD, LLVMOD, LSNGCH, LSCHDF
32442 * (original name: RESNUC)
32443       LOGICAL LRNFSS, LFRAGM
32444       COMMON /FKRESN/  AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
32445      &                   ANOW,   ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
32446      &                   ERES,  EKRES, AMNRES, AMMRES,  PTRES,  PXRES,
32447      &                  PYRES,  PZRES, PTRES2,  KTARP,  KTARN, IGREYP,
32448      &                 IGREYN, IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,
32449      &                  ICRES,  IBRES, ISTRES, IEVAPL, IEVAPH, IEVNEU,
32450      &                 IEVPRO, IEVDEU, IEVTRI, IEV3HE, IEV4HE, IDEEXG,
32451      &                  IBTAR, ICHTAR, IBLEFT, ICLEFT, IOTHER, LRNFSS,
32452      &                 LFRAGM
32453 C     INCLUDE '(SCOHLP)'
32454 * SCOHLP.ADD
32455 **sr 18.5. commented since not used for evap.
32456 C     LOGICAL LSCZER
32457 C     COMMON / SCOHLP / ISCRNG, JSCRNG, LSCZER
32458 **
32459 C     INCLUDE '(TRACKR)'
32460 * TRACKR.ADD
32461 **sr 18.5. commented since not used for evap.
32462 C     PARAMETER ( MXTRCK = 2500 )
32463 C     LOGICAL LFSSSC
32464 C     COMMON / TRACKR /  XTRACK ( 0:MXTRCK ), YTRACK ( 0:MXTRCK ),
32465 C    &                   ZTRACK ( 0:MXTRCK ), TTRACK   ( MXTRCK ),
32466 C    &                   DTRACK   ( MXTRCK ), ETRACK, PTRACK, WTRACK,
32467 C    &                   ATRACK, CTRACK, AKSHRT, AKLONG, WSCRNG,
32468 C    &                   NTRACK, MTRACK, JTRACK, KTRACK, MMTRCK,
32469 C    &                   LT1TRK, LT2TRK, LTRACK, LLOUSE, LFSSSC
32470 **
32471 C     INCLUDE '(USRBDX)'
32472 * USRBDX.ADD
32473 **sr 18.5. commented since not used for evap.
32474 C     PARAMETER ( MXUSBX = 600 )
32475 C     LOGICAL LUSBDX, LFUSBX, LWUSBX, LLNUSX
32476 C     CHARACTER*10 TITUSX
32477 C     COMMON /USRBX/  EBXLOW(MXUSBX), EBXHGH(MXUSBX), ABXLOW(MXUSBX),
32478 C    &                ABXHGH(MXUSBX), DEBXBN(MXUSBX), DABXBN(MXUSBX),
32479 C    &                AUSBDX(MXUSBX),
32480 C    &                NEBXBN(MXUSBX), NABXBN(MXUSBX), NR1USX(MXUSBX),
32481 C    &                NR2USX(MXUSBX), ITUSBX(MXUSBX), IDUSBX(MXUSBX),
32482 C    &                KBUSBX(MXUSBX), IPUSBX(MXUSBX), IGMUSX(MXUSBX),
32483 C    &                LFUSBX(MXUSBX), LWUSBX(MXUSBX), LLNUSX(MXUSBX),
32484 C    &                NUSRBX, LUSBDX
32485 C     COMMON /USXCH/  TITUSX(MXUSBX)
32486 **
32487 C     INCLUDE '(USRBIN)'
32488 * USRBIN.ADD
32489 **sr 18.5. commented since not used for evap.
32490 C     PARAMETER ( MXUSBN = 100 )
32491 C     LOGICAL LUSBIN, LEVTBN, LNTZER, LUSEVT, LUSTKB, LTRKBN
32492 C     CHARACTER*10 TITUSB
32493 C     COMMON /USRBN/  XLOW  (MXUSBN), XHIGH (MXUSBN), YLOW  (MXUSBN),
32494 C    &                YHIGH (MXUSBN), ZLOW  (MXUSBN), ZHIGH (MXUSBN),
32495 C    &                DXUSBN(MXUSBN), DYUSBN(MXUSBN), DZUSBN(MXUSBN),
32496 C    &                TCUSBN(MXUSBN), BKUSBN(MXUSBN), B2USBN(MXUSBN),
32497 C    &                NXBIN (MXUSBN), NYBIN (MXUSBN), NZBIN (MXUSBN),
32498 C    &                ITUSBN(MXUSBN), IDUSBN(MXUSBN), KBUSBN(MXUSBN),
32499 C    &                IPUSBN(MXUSBN), LEVTBN(MXUSBN), LNTZER(MXUSBN),
32500 C    &                LTRKBN(MXUSBN), NUSRBN, LUSBIN, LUSEVT, LUSTKB
32501 C     COMMON /USRCH/  TITUSB(MXUSBN)
32502 **
32503 C     INCLUDE '(USRSNC)'
32504 * USRSNC.ADD
32505 **sr 18.5. commented since not used for evap.
32506 C     PARAMETER ( MXRSNC = 400 )
32507 C     PARAMETER ( NMZMIN =  -5 )
32508 C     LOGICAL LURSNC
32509 C     CHARACTER*10 TIURSN
32510 C     COMMON /USRSNC/  VURSNC(MXRSNC), IZRHGH(MXRSNC), IMRHGH(MXRSNC),
32511 C    &                 NRURSN(MXRSNC), ITURSN(MXRSNC), KBURSN(MXRSNC),
32512 C    &                 IPURSN(MXRSNC), NURSNC, LURSNC
32513 C     COMMON /USRSCH/  TIURSN(MXRSNC)
32514 C     INCLUDE '(USRTRC)'
32515 * USRTRC.ADD
32516 **sr 18.5. commented since not used for evap.
32517 C     PARAMETER ( MXUSTC = 400 )
32518 C     LOGICAL LUSRTC, LUSTRK, LUSCLL, LLNUTC
32519 C     CHARACTER*10 TITUTC
32520 C     COMMON /USRTC/  ETCLOW(MXUSTC), ETCHGH(MXUSTC), DETCBN(MXUSTC),
32521 C    &                VUSRTC(MXUSTC),
32522 C    &                IUSTRK(MXUSTC), IUSCLL(MXUSTC), NETCBN(MXUSTC),
32523 C    &                NRUSTC(MXUSTC), ITUSTC(MXUSTC), IDUSTC(MXUSTC),
32524 C    &                KBUSTC(MXUSTC), IPUSTC(MXUSTC), IGMUTC(MXUSTC),
32525 C    &                LLNUTC(MXUSTC), NUSRTC, NUSTRK, NUSCLL, LUSRTC,
32526 C    &                LUSTRK, LUSCLL
32527 C     COMMON /USTCH/  TITUTC(MXUSTC)
32528 **
32529 C     INCLUDE '(USRYLD)'
32530 * USRYLD.ADD
32531 **sr 18.5. commented since not used for evap.
32532 C     PARAMETER ( MXUSYL = 500 )
32533 C     LOGICAL LUSRYL, LLNUYL, LSCUYL
32534 C     CHARACTER*10 TITUYL
32535 C     COMMON /USRYL/  EYLLOW(MXUSYL), EYLHGH(MXUSYL), DEYLBN(MXUSYL),
32536 C    &                USNRYL(MXUSYL), SGUSYL(MXUSYL), AYLLOW(MXUSYL),
32537 C    &                AYLHGH(MXUSYL), PUSRYL, UUSRYL, VUSRYL, WUSRYL,
32538 C    &                ETXUYL, ETYUYL, ETZUYL, GAMUYL, SQSUYL, UCMUYL,
32539 C    &                VCMUYL, WCMUYL, IJUSYL, JTUSYL,
32540 C    &                NEYLBN(MXUSYL), NR1UYL(MXUSYL), NR2UYL(MXUSYL),
32541 C    &                IXUSYL(MXUSYL), ITUSYL(MXUSYL), IDUSYL(MXUSYL),
32542 C    &                KBUSYL(MXUSYL), IPUSYL(MXUSYL), IGMUYL(MXUSYL),
32543 C    &                IEUSYL(MXUSYL), IAUSYL(MXUSYL), LLNUYL(MXUSYL),
32544 C    &                NUSRYL, LUSRYL, LSCUYL
32545 C     COMMON /USYCH/  TITUYL(MXUSYL)
32546 **
32547 C     INCLUDE '(WWINDW)'
32548 * WWINDW.ADD
32549 **sr 18.5. commented since not used for evap.
32550 C     PARAMETER ( MXWWSP = 3 )
32551 C     PARAMETER ( WWSPMX = 50.D+00 )
32552 C     LOGICAL LWWNDW, LWWPRM
32553 C     COMMON / WWINDW / ETHWW1 (NALLWP), ETHWW2 (NALLWP),
32554 C    &                  WWEXWD (NALLWP), EXTWWN (NALLWP),
32555 C    &                  IWLBGN, IWHBGN, IWMBGN, LWWNDW, LWWPRM
32556 **
32557
32558 * /blnkcm/
32559 * *** If blank common dimension has to be superseded substitute in the
32560 * *** following two lines the new dimension in real*8 units to Nblnmx
32561 **sr 18.5. commented since not used for evap.
32562 C     PARAMETER (MXDUMM = KALGNM * NBLNMX)
32563 C     DATA KTMBGN / NBLNMX /
32564 C     DATA MBLNMX / MXDUMM /
32565 C     DATA KBLNKL, KGMBGN, KGMLST, KCMBGN, KCMLST, KISBGN, KISLST,
32566 C    &     KDTBGN, KDTLST, KUBBGN, KUBLST, KUXBGN, KUXLST, KTCBGN,
32567 C    &     KTCLST, KRNBGN, KRNLST, KYLBGN, KYLLST, KXSBGN, KXSLST,
32568 C    &     KIHBGN, KIHLST, KINBGN, KINLST, KIEBGN, KIELST, KETBGN,
32569 C    &     KETLST, KRRBGN, KRRLST, KGLBGN, KGLLST, KNABGN, KNALST,
32570 C    &     KGDBGN, KGDLST, KDWBGN, KDWLST, KGCBGN, KGCLST, KWLBGN,
32571 C    &     KWLLST, KWHBGN, KWHLST, KWMBGN, KWMLST, KWSBGN, KWSLST,
32572 C    &     KDPBGN, KDPLST, KRGBGN, KRGLST, KSGBGN, KSGLST, KBRBGN,
32573 C    &     KBRLST / 57*0 /
32574
32575 * /blntmp/
32576 **sr 18.5. commented since not used for evap.
32577 C     DATA KIHBTM, KINBTM, KIEBTM, KRRBTM, KGLBTM, KNABTM, KGDWTM,
32578 C    &     KBDWTM, KGCBTM, KWLOTM, KWHITM, KWMUTM, KWSHTM, KEXTTM,
32579 C    &     KSTXTM, KSTNTM, KECTTM, KPCTTM, KLPBTM / 19*0 /
32580
32581 * /cmmdnr/
32582 **sr 18.5. commented since not used for evap.
32583 C     DATA DDNEAR / 0.D+00 /, LFLDNR / .FALSE. /
32584
32585 * /ctitle/
32586 **sr 18.5. commented since not used for evap.
32587 C     DATA RUNTIT (1:40) / '****************************************' /
32588 C     DATA RUNTIT(41:80) / '****************************************' /
32589 C     DATA ITEXPI, ITEXMX / 100000000, 150 /
32590 * /detect/
32591 **sr 18.5. commented since not used for evap.
32592 C     PARAMETER (NNN1 = NRGNMX*NDTCMX)
32593 C     PARAMETER (NNN2 = NSCRMX*NDTCMX)
32594 C     DATA LDTCTR /.FALSE./, NDTSCO /0/, NDTDET /0/
32595 C     DATA EDTMIN/NDTCMX*0.D0/, EDTBIN/NDTCMX*0.D0/, EDTCUT/NDTCMX*0.D0/
32596 C     DATA KDTREG/NNN1*0/, KDTDET/NNN2*0/, KDTSCD/NSCRMX*0/
32597 C     DATA TITDET/NDTCMX*'          '/, TITSCO/NSCRMX*'          '/
32598
32599 * /detloc/
32600 **sr 18.5. commented since not used for evap.
32601 C     DATA ACCUMP /NDTCM2*0.D0/, ACCUMN /NDTCM2*0.D0/, ICOINC /NDTCM2*0/
32602 C     DATA NCLAS /0/
32603
32604 * /emgtrn/
32605 **sr 18.5. commented since not used for evap.
32606 C     DATA LMCSMG / .FALSE. /
32607
32608 * /emsho/
32609 **sr 18.5. commented since not used for evap.
32610 C     DATA LIMPRE, LEXPTE / 2 * .FALSE. /
32611
32612 * /episor/
32613 **sr 18.5. commented since not used for evap.
32614 C     DATA TKESUM / 0.D+00 /, LUSSRC / .FALSE. /
32615
32616 * /fheavy/
32617       DATA AMHEAV / 12 * 0.D+00 /
32618       DATA ANHEAV / 'NEUTRON ', 'PROTON  ', 'DEUTERON', '3-H     ',
32619      &              '3-He    ', '4-He    ', 'H-FRAG-1', 'H-FRAG-2',
32620      &              'H-FRAG-3', 'H-FRAG-4', 'H-FRAG-5', 'H-FRAG-6'/
32621       DATA ICHEAV / 0, 1, 1, 1, 2, 2, 6*0 /,
32622      &     IBHEAV / 1, 1, 2, 3, 3, 4, 6*0 /
32623       DATA NPHEAV / 0 /
32624
32625 * /finuc/
32626       DATA NP / 0 /, TV / 0.D+00 /, TVCMS / 0.D+00 /, TVRECL / 0.D+00/,
32627      &     TVHEAV / 0.D+00 /, TVBIND / 0.D+00 /
32628
32629 * /genthr/
32630 * Up to 20-apr-'95
32631 *     DATA PEANCT, PEAPIT / 2*1.D+00 /
32632 *     DATA PTHRSH / 16*5.D+00,2*2.5D+00,5.D+00,3*2.5D+00,8*5.D+00,
32633 *    &              9*2.5D+00 /
32634 *     DATA PTHDFF / 39*5.D+00 /
32635 *    &              9*2.5D+00 /
32636 * New values:
32637 **sr 18.5. commented since not used for evap.
32638 C     DATA PEANCT, PEAPIT / 1.3D+00, 1.1D+00 /
32639 C     DATA PTHRSH / 12*5.D+00, 2*3.5D+00, 2*5.D+00, 2*2.5D+00, 5.D+00,
32640 C    &              3*2.5D+00, 3.5D+00, 2*5.D+00, 3.5D+00, 4*5.D+00,
32641 C    &              9*2.5D+00 /
32642 C     DATA PTHDFF / 12*5.D+00, 2*3.5D+00, 8*5.D+00, 3.5D+00, 2*5.D+00,
32643 C    &              3.5D+00, 13*5.D+00 /
32644 C     DATA PLDNCT / 0.26D+00 /
32645 C     DATA IJNUCR / 16*1, 2*0, 1, 3*0, 8*1, 9*0 /
32646
32647 * /lowneu/
32648 **sr 18.5. commented since not used for evap.
32649 C     DATA WWAMFL / 10.D+00 /, EXTWWL / 1.D+00 /
32650 C     DATA IWWLWB, IWWLWT / 2 * 100000000 /
32651 C     DATA ICLMED, INABGN, IDWBGN, IETBGN / 4*0 /
32652 C     DATA IGRTHN / 1 /
32653 C     DATA LIMPRN / .FALSE. /, LBIASN / .FALSE. /, LDOWNN / .FALSE. /,
32654 C    &     LLOWWW / .FALSE. /, LLOWET / .FALSE. /
32655
32656 * /ltclcm/
32657 **sr 18.5. commented since not used for evap.
32658 C     DATA MLATTC, NEWLAT, MLATLD, MLATM1, MLTSEN, MLTSM1 / 6*0 /
32659
32660 * /mulbou/
32661 **sr 18.5. commented since not used for evap.
32662 C     DATA LLDA, LAGAIN, LSTNEW, LARTEF, LSENSE, LNORML, LMGNOR
32663 C    &     / 7 * .FALSE. /
32664 C     DATA TSENSE / AINFNT /, NSSENS / -1 /
32665 C     DATA DSMALL / ANGLGB /
32666
32667 * /mulhd/
32668 **sr 18.5. commented since not used for evap.
32669 C     DATA LTOPT  / MXXMDF * .FALSE. /, NFSCAT / 0 /
32670 C     DATA ESTEPF / MXXMDF * 0.1D+00 /
32671 C     DATA LSRCRH / MXXMDF * .FALSE. /, LNSCRH / MXXMDF * .FALSE. /
32672 C     DATA THMSPR / 0.02D+00 /, THMSSC / 1.D+00 /
32673
32674 * /parevt/
32675       DATA DPOWER /-13.D+00 /, FSPRD0 / 0.6D+00 /, FSHPFN / 0.0D+00 /,
32676      &     RN1GSC /-1.0D+00 /, RN2GSC /-1.0D+00 /
32677       DATA LDIFFR /  .TRUE., .TRUE., 6 * .TRUE., .TRUE., 8 * .TRUE.,
32678      &               .TRUE., 4 * .TRUE., .TRUE., 3 * .TRUE.,
32679      &              4 * .FALSE., 9 * .TRUE./
32680 **sr 17.5.95
32681 * default value for LEVPRT changed (reset sr 25.7.97)
32682 * default value for LHEAVY changed 25.7.97
32683 C     DATA LPOWER / .TRUE.  /, LINCTV / .TRUE.  /, LEVPRT / .TRUE.  /,
32684 C    &     LHEAVY / .FALSE. /, LDEEXG / .TRUE.  /, LGDHPR / .TRUE.  /,
32685 C    &     LPREEX / .TRUE.  /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /,
32686 C    &     LPARWV / .TRUE.  /, LSNGCH / .TRUE.  /, LSCHDF / .TRUE.  /
32687       DATA LPOWER / .TRUE.  /, LINCTV / .TRUE.  /, LEVPRT / .TRUE.  /,
32688      &     LHEAVY / .TRUE.  /, LDEEXG / .TRUE.  /, LGDHPR / .TRUE.  /,
32689      &     LPREEX / .TRUE.  /, LHLFIX / .FALSE. /, LPRFIX / .FALSE. /,
32690      &     LPARWV / .TRUE.  /, LSNGCH / .TRUE.  /, LSCHDF / .TRUE.  /
32691 **
32692 **sr 27.5.97
32693 * default value for ILVMOD changed
32694 C     DATA ILVMOD / 0 /, JLVMOD / 1 /, LLVMOD / .TRUE. /
32695       DATA ILVMOD / 1 /, JLVMOD / 1 /, LLVMOD / .TRUE. /
32696 **
32697
32698 * /resnuc/
32699       DATA IPREEH / 0 /, IPRTRI / 0 /, IPRDEU / 0 /, IPR3HE / 0 /,
32700      &     IPR4HE / 0 /
32701       DATA IEVAPL / 0 /, IEVAPH / 0 /, IEVNEU / 0 /, IEVPRO / 0 /,
32702      &     IEVTRI / 0 /, IEVDEU / 0 /, IEV3HE / 0 /, IEV4HE / 0 /,
32703      &     IDEEXG / 0 /
32704       DATA LRNFSS / .FALSE. /
32705
32706 * /scohlp/
32707 **sr 18.5. commented since not used for evap.
32708 C     DATA ISCRNG, JSCRNG / 2*0 /, LSCZER / .FALSE. /
32709
32710 * /trackr/
32711 **sr 18.5. commented since not used for evap.
32712 C     DATA ETRACK /0.D+00/, WTRACK /0.D+00/, ATRACK /0.D+00/,
32713 C    &     CTRACK /0.D+00/, NTRACK /0/, MTRACK /0/, JTRACK /0/
32714
32715 * /usrbin/
32716 **sr 18.5. commented since not used for evap.
32717 C     DATA LUSBIN, LUSEVT, LUSTKB /3*.FALSE./, NUSRBN /0/
32718
32719 * /usrbdx/
32720 **sr 18.5. commented since not used for evap.
32721 C     DATA LUSBDX /.FALSE./, NUSRBX /0/
32722
32723 * /usrsnc/
32724 **sr 18.5. commented since not used for evap.
32725 C     DATA LURSNC /.FALSE./, NURSNC /0/
32726
32727 * /usrtrc/
32728 **sr 18.5. commented since not used for evap.
32729 C     DATA LUSRTC, LUSTRK, LUSCLL / 3*.FALSE. /
32730 C     DATA NUSRTC, NUSTRK, NUSCLL / 3*0 /
32731
32732 * /usryld/
32733 **sr 18.5. commented since not used for evap.
32734 C     DATA LUSRYL / .FALSE./, LSCUYL / .FALSE. /, NUSRYL /0/,
32735 C    &     IJUSYL /0/, JTUSYL /0/
32736 C     DATA PUSRYL, UUSRYL, VUSRYL, WUSRYL / 4*ZERZER /
32737
32738 * /wwindw/
32739 **sr 18.5. commented since not used for evap.
32740 C     DATA IWLBGN, IWHBGN, IWMBGN / 3*0 /
32741 C     DATA LWWPRM / .TRUE. /
32742
32743 *=                                               end*block.bdnopt      *
32744       END
32745
32746 *$ CREATE DT_BDPREE.FOR
32747 *COPY DT_BDPREE
32748 *
32749 *=== bdpree ===========================================================*
32750 *
32751       BLOCK DATA DT_BDPREE
32752
32753 C     INCLUDE '(DBLPRC)'
32754 * DBLPRC.ADD
32755       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32756       SAVE
32757 * (original name: GLOBAL)
32758       PARAMETER ( KALGNM = 2 )
32759       PARAMETER ( ANGLGB = 5.0D-16 )
32760       PARAMETER ( ANGLSQ = 2.5D-31 )
32761       PARAMETER ( AXCSSV = 0.2D+16 )
32762       PARAMETER ( ANDRFL = 1.0D-38 )
32763       PARAMETER ( AVRFLW = 1.0D+38 )
32764       PARAMETER ( AINFNT = 1.0D+30 )
32765       PARAMETER ( AZRZRZ = 1.0D-30 )
32766       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
32767       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
32768       PARAMETER ( EXCSSV = +35.23192357547063 D+00 )
32769       PARAMETER ( ENGLGB = -35.23192357547063 D+00 )
32770       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
32771       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
32772       PARAMETER ( CSNNRM = 2.0D-15 )
32773       PARAMETER ( DMXTRN = 1.0D+08 )
32774       PARAMETER ( ZERZER = 0.D+00 )
32775       PARAMETER ( ONEONE = 1.D+00 )
32776       PARAMETER ( TWOTWO = 2.D+00 )
32777       PARAMETER ( THRTHR = 3.D+00 )
32778       PARAMETER ( FOUFOU = 4.D+00 )
32779       PARAMETER ( FIVFIV = 5.D+00 )
32780       PARAMETER ( SIXSIX = 6.D+00 )
32781       PARAMETER ( SEVSEV = 7.D+00 )
32782       PARAMETER ( EIGEIG = 8.D+00 )
32783       PARAMETER ( ANINEN = 9.D+00 )
32784       PARAMETER ( TENTEN = 10.D+00 )
32785       PARAMETER ( HLFHLF = 0.5D+00 )
32786       PARAMETER ( ONETHI = ONEONE / THRTHR )
32787       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
32788       PARAMETER ( ONEFOU = ONEONE / FOUFOU )
32789       PARAMETER ( THRTWO = THRTHR / TWOTWO )
32790       PARAMETER ( PIPIPI = 3.141592653589793238462643383279D+00 )
32791       PARAMETER ( TWOPIP = 6.283185307179586476925286766559D+00 )
32792       PARAMETER ( PIP5O2 = 7.853981633974483096156608458199D+00 )
32793       PARAMETER ( PIPISQ = 9.869604401089358618834490999876D+00 )
32794       PARAMETER ( PIHALF = 1.570796326794896619231321691640D+00 )
32795       PARAMETER ( ERFA00 = 0.886226925452758013649083741671D+00 )
32796       PARAMETER ( SQTWPI = 2.506628274631000502415765284811D+00 )
32797       PARAMETER ( EULERO = 0.577215664901532860606512      D+00 )
32798       PARAMETER ( EULEXP = 1.781072417990197985236504      D+00 )
32799       PARAMETER ( EULLOG =-0.5495393129816448223376619     D+00 )
32800       PARAMETER ( E1M2EU = 0.8569023337737540831433017     D+00 )
32801       PARAMETER ( ENEPER = 2.718281828459045235360287471353D+00 )
32802       PARAMETER ( SQRENT = 1.648721270700128146848650787814D+00 )
32803       PARAMETER ( SQRTWO = 1.414213562373095048801688724210D+00 )
32804       PARAMETER ( SQRTHR = 1.732050807568877293527446341506D+00 )
32805       PARAMETER ( SQRFIV = 2.236067977499789696409173668731D+00 )
32806       PARAMETER ( SQRSIX = 2.449489742783178098197284074706D+00 )
32807       PARAMETER ( SQRSEV = 2.645751311064590590501615753639D+00 )
32808       PARAMETER ( SQRT12 = 3.464101615137754587054892683012D+00 )
32809       PARAMETER ( CLIGHT = 2.99792458         D+10 )
32810       PARAMETER ( AVOGAD = 6.0221367          D+23 )
32811       PARAMETER ( BOLTZM = 1.380658           D-23 )
32812       PARAMETER ( AMELGR = 9.1093897          D-28 )
32813       PARAMETER ( PLCKBR = 1.05457266         D-27 )
32814       PARAMETER ( ELCCGS = 4.8032068          D-10 )
32815       PARAMETER ( ELCMKS = 1.60217733         D-19 )
32816       PARAMETER ( AMUGRM = 1.6605402          D-24 )
32817       PARAMETER ( AMMUMU = 0.113428913        D+00 )
32818       PARAMETER ( AMPRMU = 1.007276470        D+00 )
32819       PARAMETER ( AMNEMU = 1.008664904        D+00 )
32820       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
32821       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
32822       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
32823       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
32824       PARAMETER ( PLABRC = 0.197327053        D+00 )
32825       PARAMETER ( AMELCT = 0.51099906         D-03 )
32826       PARAMETER ( AMUGEV = 0.93149432         D+00 )
32827       PARAMETER ( AMMUON = 0.105658389        D+00 )
32828       PARAMETER ( AMPRTN = 0.93827231         D+00 )
32829       PARAMETER ( AMNTRN = 0.93956563         D+00 )
32830       PARAMETER ( AMDEUT = 1.87561339         D+00 )
32831       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
32832      &                   * 1.D-09 )
32833       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
32834       PARAMETER ( BLTZMN = 8.617385           D-14 )
32835       PARAMETER ( A0BOHR = PLABRC / ALPFSC / AMELCT )
32836       PARAMETER ( GFOHB3 = 1.16639            D-05 )
32837       PARAMETER ( GFERMI = GFOHB3 * PLABRC * PLABRC * PLABRC )
32838       PARAMETER ( SIN2TW = 0.2319             D+00 )
32839       PARAMETER ( GEVMEV = 1.0                D+03 )
32840       PARAMETER ( EMVGEV = 1.0                D-03 )
32841       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
32842       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
32843       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
32844       LOGICAL LGBIAS, LGBANA
32845       COMMON /FKGLOB/ LGBIAS, LGBANA
32846 C     INCLUDE '(DIMPAR)'
32847 * DIMPAR.ADD
32848       PARAMETER ( MXXRGN = 5000 )
32849       PARAMETER ( MXXMDF = 82   )
32850       PARAMETER ( MXXMDE = 54   )
32851       PARAMETER ( MFSTCK = 1000 )
32852       PARAMETER ( MESTCK = 100  )
32853       PARAMETER ( NALLWP = 39   )
32854       PARAMETER ( NELEMX = 80   )
32855       PARAMETER ( MPDPDX = 8    )
32856       PARAMETER ( ICOMAX = 180  )
32857       PARAMETER ( NSTBIS = 304  )
32858       PARAMETER ( IDMAXP = 220  )
32859       PARAMETER ( IDMXDC = 640  )
32860       PARAMETER ( MKBMX1 = 1    )
32861       PARAMETER ( MKBMX2 = 1    )
32862 C     INCLUDE '(IOUNIT)'
32863 * IOUNIT.ADD
32864       PARAMETER ( LUNIN  =  5 )
32865       PARAMETER ( LUNOUT =  6 )
32866 **sr 19.5. set error output-unit from 15 to 6
32867       PARAMETER ( LUNERR = 6  )
32868       PARAMETER ( LUNBER = 14 )
32869       PARAMETER ( LUNECH =  8 )
32870       PARAMETER ( LUNFLU = 13 )
32871       PARAMETER ( LUNGEO = 16 )
32872       PARAMETER ( LUNPMF = 12 )
32873       PARAMETER ( LUNRAN =  2 )
32874       PARAMETER ( LUNXSC =  9 )
32875       PARAMETER ( LUNDET = 17 )
32876       PARAMETER ( LUNRAY = 10 )
32877       PARAMETER ( LUNRDB =  1 )
32878       PARAMETER ( LUNPGO =  7 )
32879       PARAMETER ( LUNPGS =  4 )
32880       PARAMETER ( LUNSCR =  3 )
32881 *
32882 *----------------------------------------------------------------------*
32883 *                                                                      *
32884 *     Created on 16 september 1991 by    Alfredo Ferrari & Paola Sala  *
32885 *                                                   Infn - Milan       *
32886 *                                                                      *
32887 *     Last change on 03-feb-94     by    Alfredo Ferrari               *
32888 *                                                                      *
32889 *                                                                      *
32890 *----------------------------------------------------------------------*
32891 *
32892 * (original name: CMPISG,CHPISG)
32893       PARAMETER ( TPPPI0 = 0.279656044337515D+00 )
32894       PARAMETER ( TNNPI0 = 0.279642680857450D+00 )
32895       PARAMETER ( TPPPIP = 0.292295207182790D+00 )
32896       PARAMETER ( TPPDEP = 0.287514778898469D+00 )
32897       PARAMETER ( TNNPIM = 0.286723140900975D+00 )
32898       PARAMETER ( TNNDEM = 0.281949292916434D+00 )
32899       PARAMETER ( TPNPI0 = 0.279456888147740D+00 )
32900       PARAMETER ( TPNDE0 = 0.274693916135245D+00 )
32901       PARAMETER ( TPNPIP = 0.292086756473890D+00 )
32902       PARAMETER ( TNPPI0 = 0.279842093144975D+00 )
32903       PARAMETER ( TNPDE0 = 0.275072555824202D+00 )
32904       PARAMETER ( TNPPIP = 0.292489370554958D+00 )
32905       PARAMETER ( PIRSMX = 1.2D+00 )
32906       PARAMETER ( NPIREA = 10 )
32907       PARAMETER ( NPIRTA = 68 )
32908       PARAMETER ( NPIRLN = 21 )
32909       PARAMETER ( NPIRLG = NPIRTA - NPIRLN )
32910       PARAMETER ( NPISIS = NPIRLN + 20 )
32911       PARAMETER ( NPISEX = NPIRLN + 21 )
32912       PARAMETER ( NPIIMN = 14 )
32913       PARAMETER ( NPIIRC =  6 )
32914       PARAMETER ( DELWLL = 0.035D+00 )
32915       CHARACTER CHPIRE*8
32916       LOGICAL LDLRES
32917       COMMON /FKCMPI/ PMNPIS, PMMPIS, PISPIS, PEXPIS, PMXPIS, DPPISG,
32918      &                RTPISG, AMNPIS, AMMPIS, AISPIS, AEXPIS, AMXPIS,
32919      &                ARPISG, BPISLO (NPIRLN:NPIRTA,NPIREA),
32920      &                CPISLO (NPIRLN:NPIRTA,NPIREA), PPITHR (NPIREA),
32921      &                SPISLO (NPIRLN:NPIRTA,NPIREA), APITHR (NPIREA),
32922      &                SGPIIN (NPIIMN:NPIRTA,NPIIRC), RHPICR (1:5)   ,
32923      &                SGPICU (0:20,NPIRTA,NPIREA)  , SGRTRS (NPIREA),
32924      &                SGPIDF (0:20,NPIRTA,NPIREA)  , BRREIN (NPIREA),
32925      &                SGPIIS (NPIRTA,NPIREA)       , BRREOU (NPIREA),
32926      &                BRD3OU (2,2,-1:2), BRDEOU (2,-1:2),
32927      &                SGABSR (2,2,4)   , PRRSDL,
32928      &                IPIREA (2,2,3:5) , IPIINE (2,3:5)    , NPIRVR ,
32929      &                KPIIRE (2,NPIREA), KPIORE (2,NPIREA) ,
32930      &                JSTOKP (5), KPTOJS (23), ITTRRS (3:5), LDLRES
32931       COMMON /FKCHPI/ CHPIRE (NPIREA)
32932       DIMENSION SG2BRS (2,2), SGABSW (2,2), SG3BRS (2,2,2)
32933       EQUIVALENCE ( SG2BRS   (1,1), SGABSR (1,1,1) )
32934       EQUIVALENCE ( SGABSW   (1,1), SGABSR (1,1,2) )
32935       EQUIVALENCE ( SG3BRS (1,1,1), SGABSR (1,1,3) )
32936 * (original name: FRBKCM)
32937       PARAMETER ( MXFFBK =     6 )
32938       PARAMETER ( MXZFBK =     9 )
32939       PARAMETER ( MXNFBK =    10 )
32940       PARAMETER ( MXAFBK =    16 )
32941       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 )
32942       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 )
32943       PARAMETER ( NXAFBK = MXAFBK + 1 )
32944       PARAMETER ( MXPSST =   300 )
32945       PARAMETER ( MXPSFB = 41000 )
32946       LOGICAL LFRMBK, LNCMSS
32947       COMMON /FKFRBK/  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
32948      &          EXFRBK (MXPSFB), SDMFBK (MXPSFB), COUFBK (MXPSFB),
32949      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK,
32950      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
32951      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
32952      &          IPSIND (0:MXNFBK,0:MXZFBK,2), JPSIND (0:MXAFBK),
32953      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
32954      &          IFBCHA (5,MXPSFB), IPOSST, IPOSFB, IFBSTF,
32955      &          IFBFRB, NBUFBK, LFRMBK, LNCMSS
32956 * (original name: NUCGID,NUCGEO,NUCGE2,NUCPWI,NUCGII)
32957       PARAMETER ( PI     = PIPIPI )
32958       PARAMETER ( PISQ   = PIPISQ )
32959       PARAMETER ( SKTOHL = 0.5456645846610345D+00 )
32960       PARAMETER ( RZNUCL = 1.12        D+00 )
32961       PARAMETER ( RMSPRO = 0.8         D+00 )
32962       PARAMETER ( R0PROT = RMSPRO / SQRT12  )
32963       PARAMETER ( ARHPRO = 1.D+00 / 8.D+00 / PI / R0PROT / R0PROT
32964      &          / R0PROT )
32965       PARAMETER ( RLLE04 = RZNUCL )
32966       PARAMETER ( RLLE16 = RZNUCL )
32967       PARAMETER ( RLGT16 = RZNUCL )
32968       PARAMETER ( RCLE04 = 0.75D+00 / PI / RLLE04 / RLLE04 / RLLE04 )
32969       PARAMETER ( RCLE16 = 0.75D+00 / PI / RLLE16 / RLLE16 / RLLE16 )
32970       PARAMETER ( RCGT16 = 0.75D+00 / PI / RLGT16 / RLGT16 / RLGT16 )
32971       PARAMETER ( SKLE04 = 1.4D+00 )
32972       PARAMETER ( SKLE16 = 1.9D+00 )
32973       PARAMETER ( SKGT16 = 2.4D+00 )
32974       PARAMETER ( HLLE04 = SKTOHL * SKLE04 )
32975       PARAMETER ( HLLE16 = SKTOHL * SKLE16 )
32976       PARAMETER ( HLGT16 = SKTOHL * SKGT16 )
32977       PARAMETER ( ALPHA0 = 0.1D+00 )
32978       PARAMETER ( OMALH0 = 1.D+00 - ALPHA0 )
32979       PARAMETER ( GAMSK0 = 0.9D+00 )
32980       PARAMETER ( OMGAS0 = 1.D+00 - GAMSK0 )
32981       PARAMETER ( POTME0 = 0.6666666666666667D+00 )
32982       PARAMETER ( POTBA0 = 1.D+00 )
32983       PARAMETER ( PNFRAT = 1.533D+00 )
32984       PARAMETER ( RADPIM = 0.035D+00 )
32985       PARAMETER ( RDPMHL = 14.D+00   )
32986       PARAMETER ( APMRST = 4.D+00 / 44.D+00 )
32987       PARAMETER ( APMPRO = 1.D+00 / 6.D+00 )
32988       PARAMETER ( APPPRO = 5.D+00 / 6.D+00 )
32989       PARAMETER ( AP0PFS = 0.5D+00 )
32990       PARAMETER ( AP0PFP = 1.D+00 / 3.D+00 )
32991       PARAMETER ( AP0NFP = 2.D+00 / 3.D+00 )
32992       PARAMETER ( XPAUCO = 1.88495407241652 D+00 )
32993       PARAMETER ( MXSCIN = 50     )
32994       LOGICAL LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH, LNCDCY,
32995      &        LNUSCT, LPREEQ, LNPHTC, LNWRAD, LPNRHO, LFTCMP, LFTCAC
32996       COMMON /FKNGID/ RHOTAB (2:260), RHATAB (2:260), ALPTAB (2:260),
32997      &                RADTAB (2:260), SKITAB (2:260), HALTAB (2:260),
32998      &                SK3TAB (2:260), SK4TAB (2:260), HABTAB (2:260),
32999      &                CWSTAB (2:260), EKATAB (2:260), PFATAB (2:260),
33000      &                PFRTAB (2:260)
33001       COMMON /FKNGEO/ RADTOT, RADIU1, RADIU0, RAD1O2, SKINDP, HALODP,
33002      &                ALPHAL, OMALHL, RADSKN, SKNEFF, CPARWS, RADPRO,
33003      &                RADCOR, RADCO2, RADMAX, BIMPTR, RIMPTR, XIMPTR,
33004      &                YIMPTR, ZIMPTR, RHOIMT, EKFPRO, PFRPRO, RHOCEN,
33005      &                RHOCOR, RHOSKN, EKFCEN (2), PFRCEN (2), EKFBIM,
33006      &                PFRBIM, RHOIMP, EKFIMP, PFRIMP, RHOIM2, EKFIM2,
33007      &                PFRIM2, RHOIM3, EKFIM3, PFRIM3, VPRWLL, RIMPCT,
33008      &                BIMPCT, XIMPCT, YIMPCT, ZIMPCT, RIMPC2, XIMPC2,
33009      &                YIMPC2, ZIMPC2, RIMPC3, XIMPC3, YIMPC3, ZIMPC3,
33010      &                XBIMPC, YBIMPC, ZBIMPC, CXIMPC, CYIMPC, CZIMPC,
33011      &                SQRIMP, SIGMAP, SIGMAN, SIGMAA, RHORED, R0TRAJ,
33012      &                R1TRAJ, SBUSED, SBTOT , SBRES , RHOAVE, EKFAVE,
33013      &                PFRAVE, AVEBIN, ACOLL , ZCOLL , RADSIG, OPACTY,
33014      &                EKECON, PNUCCO, EKEWLL, PPRWLL, PXPROJ, PYPROJ,
33015      &                PZPROJ, EKFERM, PNFRMI, PXFERM, PYFERM, PZFERM,
33016      &                EKFER2, PNFRM2, PXFER2, PYFER2, PZFER2, EKFER3,
33017      &                PNFRM3, PXFER3, PYFER3, PZFER3, RHOMEM, EKFMEM,
33018      &                BIMMEM, WLLRED, VPRBIM, POTINC, POTOUT, EEXMIN
33019       COMMON /FKNGE2/ RDTTNC (2), RHONCP (2), RHONC2 (2), RHONC3 (2),
33020      &                RHONCT (2), AMOTHR, EKOTHR, AMCREA, EKNCLN,
33021      &                EEXDEL, EEXANY, CLMBBR, RDCLMB, BFCLMB, BFCEFF,
33022      &                BNPROJ, BNDNUC, DEBRLM, SK4PAR, UBIMPC, VBIMPC,
33023      &                WBIMPC, BNDPOT, SIGMAT, SIGABP, SIGABN, WLLRES,
33024      &                POTBAR, POTMES, AGEPRI, OPNOPA, ETHRND,
33025      &                BNENRG (3), DEFNUC (2), SIGMPR (4), SIGMNU (4),
33026      &                SIGPAB (3), SIGNAB (3), HHLP   (2), FORTOT (2),
33027      &                FPNBLC, DPNBLC, FFTFLG, IFTFLG,
33028      &                IPWELL, ITNCMX, KPRIN , NTARGT, KNUCIM, KNUCI2,
33029      &                KNUCI3, IEVPRE, ISFCOL, ISFTAR, ISFTA2, ISFTA3,
33030      &                NPOTHR, ICOTHR, IBOTHR, NPUMFN, ISTNCL, ITAUCM,
33031      &                IABCOU, IADFLG, IGSFLG, IALFLG, ICBFLG, LPREEQ,
33032      &                LNPHTC, LPNRHO, LNWRAD, LFTCMP, LFTCAC
33033       COMMON /FKNPWI/ ALMBAR, BIMMAX, SIGGEO, LLLMAX, LLLACT
33034       COMMON /FKNGII/ HOLEXP (2*MXSCIN), XEXPIN (3,0:MXSCIN),
33035      &                YEXPIN (3,0:MXSCIN), ZEXPIN (3,0:MXSCIN),
33036      &                AGEXIN (0:MXSCIN), RHOEXP (2), EKFEXP, EHLFIX,
33037      &                NHLEXP, NHLFIX, IPRTYP, NNCEXI (0:MXSCIN),
33038      &                NCEXPI (3,0:MXSCIN), ISEXIN (3,0:MXSCIN),
33039      &                ISCTYP (0:MXSCIN), NUSCIN, NEXPEM,
33040      &                LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH,
33041      &                LNCDCY, LNUSCT
33042       DIMENSION AWSTAB (2:260), SIGMAB (3)
33043       EQUIVALENCE ( DEFPRO, DEFNUC (1) )
33044       EQUIVALENCE ( DEFNEU, DEFNUC (2) )
33045       EQUIVALENCE ( RHOIPP, RHONCP (1) )
33046       EQUIVALENCE ( RHOINP, RHONCP (2) )
33047       EQUIVALENCE ( RHOIP2, RHONC2 (1) )
33048       EQUIVALENCE ( RHOIN2, RHONC2 (2) )
33049       EQUIVALENCE ( RHOIP3, RHONC3 (1) )
33050       EQUIVALENCE ( RHOIN3, RHONC3 (2) )
33051       EQUIVALENCE ( RHOIPT, RHONCT (1) )
33052       EQUIVALENCE ( RHOINT, RHONCT (2) )
33053       EQUIVALENCE ( OMALHL, SK3PAR )
33054       EQUIVALENCE ( ALPHAL, HABPAR )
33055       EQUIVALENCE ( ALPTAB (2), AWSTAB (2) )
33056       EQUIVALENCE ( SIGMPE, SIGMPR (1) )
33057       EQUIVALENCE ( SIGMPC, SIGMPR (2) )
33058       EQUIVALENCE ( SIGMPI, SIGMPR (3) )
33059       EQUIVALENCE ( SIGMPA, SIGMPR (4) )
33060       EQUIVALENCE ( SIGMNE, SIGMNU (1) )
33061       EQUIVALENCE ( SIGMNC, SIGMNU (2) )
33062       EQUIVALENCE ( SIGMNI, SIGMNU (3) )
33063       EQUIVALENCE ( SIGMNA, SIGMNU (4) )
33064       EQUIVALENCE ( SIGMA2, SIGPAB (1) )
33065       EQUIVALENCE ( SIGMA3, SIGPAB (2) )
33066       EQUIVALENCE ( SIGMAS, SIGPAB (3) )
33067       EQUIVALENCE ( SIGPAB (1), SIGMAB (1) )
33068 * (original name: NUCLEV)
33069       LOGICAL LCLVSL, LFLVSL, LRLVSL, LEQSBL
33070       COMMON /FKNLEV/ PAENUC (200,2), SHENUC (200,2), DEFRMI (2),
33071      &                DEFMAG (2), ENNCLV (160,2), RANCLV (160,2),
33072      &                CUMRAD (0:160,2), RUSNUC (2),
33073      &                ENPLVL (114), ENNLVL(164), JUSNUC (160,2),
33074      &                NTANUC (2), NAVNUC (2), NLSNUC (2), NCONUC (2),
33075      &                NSKNUC (2), NHANUC (2), NUSNUC (2), NACNUC (2),
33076      &                JMXNUC (2), IPRNUC (3), JPRNUC (3), MAGNUM (8),
33077      &                MAGNUC (2), MGSNUC (8,2), MGSSNC (25,2),
33078      &                NSBSHL (2), NMNSBS (2), NPRNUC, INUCLV, LCLVSL,
33079      &                LFLVSL, LRLVSL, LEQSBL
33080       DIMENSION JUSPRO (160), JUSNEU (160), MGSPRO (8), MGSNEU (8),
33081      &          MGSSPR (19) , MGSSNE (25)
33082       EQUIVALENCE ( RUSNUC (1), RUSPRO )
33083       EQUIVALENCE ( RUSNUC (2), RUSNEU )
33084       EQUIVALENCE ( JUSNUC (1,1), JUSPRO (1) )
33085       EQUIVALENCE ( JUSNUC (1,2), JUSNEU (1) )
33086       EQUIVALENCE ( MGSNUC (1,1), MGSPRO (1) )
33087       EQUIVALENCE ( MGSNUC (1,2), MGSNEU (1) )
33088       EQUIVALENCE ( MGSSNC (1,1), MGSSPR (1) )
33089       EQUIVALENCE ( MGSSNC (1,2), MGSSNE (1) )
33090       EQUIVALENCE ( NTANUC (1), NTAPRO )
33091       EQUIVALENCE ( NTANUC (2), NTANEU )
33092       EQUIVALENCE ( NAVNUC (1), NAVPRO )
33093       EQUIVALENCE ( NAVNUC (2), NAVNEU )
33094       EQUIVALENCE ( NLSNUC (1), NLSPRO )
33095       EQUIVALENCE ( NLSNUC (2), NLSNEU )
33096       EQUIVALENCE ( NCONUC (1), NCOPRO )
33097       EQUIVALENCE ( NCONUC (2), NCONEU )
33098       EQUIVALENCE ( NSKNUC (1), NSKPRO )
33099       EQUIVALENCE ( NSKNUC (2), NSKNEU )
33100       EQUIVALENCE ( NHANUC (1), NHAPRO )
33101       EQUIVALENCE ( NHANUC (2), NHANEU )
33102       EQUIVALENCE ( NUSNUC (1), NUSPRO )
33103       EQUIVALENCE ( NUSNUC (2), NUSNEU )
33104       EQUIVALENCE ( NACNUC (1), NACPRO )
33105       EQUIVALENCE ( NACNUC (2), NACNEU )
33106       EQUIVALENCE ( JMXNUC (1), JMXPRO )
33107       EQUIVALENCE ( JMXNUC (2), JMXNEU )
33108       EQUIVALENCE ( MAGNUC (1), MAGPRO )
33109       EQUIVALENCE ( MAGNUC (2), MAGNEU )
33110 * (original name: PARNUC)
33111       PARAMETER ( PIGRK  = PIPIPI )
33112       PARAMETER ( ALEVEL = 8.D-03 )
33113       PARAMETER ( RCNUCL = 1.12D+00 )
33114       PARAMETER ( R0SIG  = 1.3D+00 )
33115       PARAMETER ( R0SIGK = 1.5D+00 )
33116       PARAMETER ( RCOULB = 1.5D+00 )
33117       PARAMETER ( COULBH = 0.88235D-03 )
33118       PARAMETER ( RHONU0 = 0.75D+00 / PIGRK / RCNUCL / RCNUCL / RCNUCL )
33119       PARAMETER ( TAUFO0 = 10.0D+00 )
33120       PARAMETER ( EKEEXP = 0.03D+00 )
33121       PARAMETER ( EKREXP = 0.05D+00 )
33122       PARAMETER ( EKEMNM = 0.01D+00 )
33123       PARAMETER ( NCPMX = 120 )
33124       COMMON /FKPARN/ EKORI , PXORI , PYORI , PZORI , PTORI , TAUFOR,
33125      &                ENNUC  (NCPMX), PNUCL  (NCPMX), EKFNUC (NCPMX),
33126      &                XSTNUC (NCPMX), YSTNUC (NCPMX), ZSTNUC (NCPMX),
33127      &                PXNUCL (NCPMX), PYNUCL (NCPMX), PZNUCL (NCPMX),
33128      &                RSTNUC (NCPMX), FREEPA (NCPMX), CRRPAN (NCPMX),
33129      &                CRRPAP (NCPMX), BSTNUC (NCPMX), AGENUC (NCPMX),
33130      &                TAUFPA (NCPMX), RHNUCL(NCPMX,2), BNDGAV, DEFMIN,
33131      &                KPNUCL (NCPMX), KRFNUC (NCPMX), ILINUC (NCPMX),
33132      &                INUCTS (NCPMX), ISFNUC (NCPMX), KPORI , IBORI ,
33133      &                IBNUCL, NPNUC , NNUCTS
33134 *
33135       DATA LABRST, LELSTC, LINELS, LCHEXC, LABSRP, LABSTH / 6*.FALSE. /
33136       DATA POTBAR / POTBA0 /, POTMES / POTME0 /, WLLRES / 0.D+00 /
33137       DATA JUSNUC / 320 * 0 /, INUCLV / 1 /, IEVPRE / 0 /
33138       DATA MAGNUM / 2, 8, 20, 28, 50, 82, 126, 160 /
33139       DATA LPREEQ / .FALSE. /
33140 * /cmpisg/
33141       DATA JSTOKP / 1, 8, 13, 14, 23 /
33142       DATA KPTOJS / 1, 6*0, 2, 4*0, 3, 4, 8*0, 5 /
33143       DATA CHPIRE / 'PI+PPI+P','PI-PPI-P','PI-PPI0N','PI0PPI0P',
33144      &              'PI0PPI+N','PI-NPI-N','PI+NPI+N','PI+NPI0P',
33145      &              'PI0NPI0N','PI0NPI-P' /
33146       DATA KPIIRE / 13, 1, 14, 1, 14, 1, 23, 1, 23, 1, 14, 8,
33147      &              13, 8, 13, 8, 23, 8, 23, 8 /
33148       DATA KPIORE / 13, 1, 14, 1, 23, 8, 23, 1, 13, 8, 14, 8,
33149      &              13, 8, 23, 1, 23, 8, 14, 1 /
33150       DATA IPIREA / 1, 0, 7, 8, 2, 3, 6, 0, 4, 5, 9, 10 /
33151       DATA IPIINE / 1, 2, 3, 4, 5, 6 /
33152 * /frbkcm/
33153       DATA LFRMBK / .FALSE. /
33154       DATA NBUFBK /   500  /
33155       DATA EXMXFB / 80.0 D+00 /
33156       DATA R0FRBK / 1.18 D+00 /
33157       DATA R0CFBK / 2.173D+00 /
33158       DATA C1CFBK / 6.103D-03 /
33159       DATA C2CFBK / 9.443D-03 /
33160 * /parnuc/
33161       DATA TAUFOR / TAUFO0 /
33162 *=== End of Block Data Bdpree =========================================*
33163       END
33164
33165 *$ CREATE DT_XHOINI.FOR
33166 *COPY DT_XHOINI
33167 *
33168 *====phoini============================================================*
33169 *
33170       SUBROUTINE DT_XHOINI
33171 C     SUBROUTINE DT_PHOINI
33172
33173       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33174       SAVE
33175       PARAMETER ( LINP = 10 ,
33176      &            LOUT = 6 ,
33177      &            LDAT = 9 )
33178
33179       RETURN
33180       END
33181
33182 *$ CREATE DT_XVENTB.FOR
33183 *COPY DT_XVENTB
33184 *
33185 *====eventb============================================================*
33186 *
33187       SUBROUTINE DT_XVENTB(NCSY,IREJ)
33188 C     SUBROUTINE DT_EVENTB(NCSY,IREJ)
33189
33190       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33191       SAVE
33192       PARAMETER ( LINP = 10 ,
33193      &            LOUT = 6 ,
33194      &            LDAT = 9 )
33195
33196       WRITE(LOUT,1000)
33197  1000 FORMAT(1X,'EVENTB:   PHOJET-package requested but not linked!')
33198       STOP
33199
33200       END
33201
33202 *$ CREATE DT_XVENT.FOR
33203 *COPY DT_XVENT
33204 *
33205 *===event==============================================================*
33206 *
33207       SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
33208 C     SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
33209
33210       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33211       SAVE
33212
33213       DIMENSION PP(4),PT(4)
33214
33215       RETURN
33216       END
33217
33218 *$ CREATE DT_XOHISX.FOR
33219 *COPY DT_XOHISX
33220 *
33221 *===pohisx=============================================================*
33222 *
33223       SUBROUTINE DT_XOHISX(I,X)
33224 C     SUBROUTINE POHISX(I,X)
33225
33226       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33227       SAVE
33228
33229       RETURN
33230       END
33231
33232 *$ CREATE PHO_LHIST.FOR
33233 *COPY PHO_LHIST
33234 *
33235 *===poluhi=============================================================*
33236 *
33237       SUBROUTINE PHO_LHIST(I,X)
33238 **
33239
33240       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33241       SAVE
33242
33243       RETURN
33244       END
33245
33246 *$ CREATE PDFSET.FOR
33247 *COPY PDFSET
33248 *
33249 C**********************************************************************
33250 C
33251 C   dummy subroutines, remove to link PDFLIB
33252 C
33253 C**********************************************************************
33254       SUBROUTINE PDFSET(PARAM,VALUE)
33255       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33256       DIMENSION PARAM(20),VALUE(20)
33257       CHARACTER*20 PARAM
33258       END
33259
33260 *$ CREATE STRUCTM.FOR
33261 *COPY STRUCTM
33262 *
33263       SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
33264       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33265       END
33266
33267 *$ CREATE STRUCTP.FOR
33268 *COPY STRUCTP
33269 *
33270       SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
33271       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33272       END
33273
33274 *$ CREATE DT_DIQBRK.FOR
33275 *COPY DT_DIQBRK
33276 *
33277 *===diqbrk=============================================================*
33278 *
33279       SUBROUTINE DT_XIQBRK
33280 C     SUBROUTINE DT_DIQBRK
33281
33282       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33283       SAVE
33284
33285       STOP 'diquark-breaking not implemeted !'
33286
33287       RETURN
33288       END
33289
33290 *$ CREATE DT_ELHAIN.FOR
33291 *COPY DT_ELHAIN
33292 *
33293 *===elhain=============================================================*
33294 *
33295       SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
33296
33297 ************************************************************************
33298 * Elastic hadron-hadron scattering.                                    *
33299 * This is a revised version of the original.                           *
33300 * This version dated 03.04.98 is written by S. Roesler                 *
33301 ************************************************************************
33302
33303       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33304       SAVE
33305       PARAMETER ( LINP = 10 ,
33306      &            LOUT = 6 ,
33307      &            LDAT = 9 )
33308       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
33309      &           TINY10=1.0D-10)
33310
33311       PARAMETER (ENNTHR = 3.5D0)
33312       PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
33313      &           BLOWB=0.05D0,BHIB=0.2D0,
33314      &           BLOWM=0.1D0, BHIM=2.0D0)
33315
33316 * particle properties (BAMJET index convention)
33317       CHARACTER*8  ANAME
33318       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33319      &                IICH(210),IIBAR(210),K1(210),K2(210)
33320 * final state from HADRIN interaction
33321       PARAMETER (MAXFIN=10)
33322       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
33323      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
33324
33325 C     DATA TSLOPE /10.0D0/
33326
33327       IREJ = 0
33328
33329     1 CONTINUE
33330
33331       PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
33332       EKIN = ELAB-AAM(IP)
33333 *   kinematical quantities in cms of the hadrons
33334       AMP2 = AAM(IP)**2
33335       AMT2 = AAM(IT)**2
33336       S    = AMP2+AMT2+TWO*ELAB*AAM(IT)
33337       ECM  = SQRT(S)
33338       ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
33339       PCM  = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
33340
33341 * nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
33342       IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
33343      &     ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
33344 *   TSAMCS treats pp and np only, therefore change pn into np and
33345 *   nn into pp
33346          IF (IT.EQ.1) THEN
33347             KPROJ = IP
33348          ELSE
33349             KPROJ = 8
33350             IF (IP.EQ.8) KPROJ = 1
33351          ENDIF
33352          CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
33353          T = TWO*PCM**2*(CTCMS-ONE)
33354
33355 * very crude treatment otherwise: sample t from exponential dist.
33356       ELSE
33357 *   momentum transfer t
33358          TMAX = TWO*TWO*PCM**2
33359          RR = (PLAB-PLOWH)/(PHIH-PLOWH)
33360          IF (IIBAR(IP).NE.0) THEN
33361             TSLOPE = BLOWB+RR*(BHIB-BLOWB)
33362          ELSE
33363             TSLOPE = BLOWM+RR*(BHIM-BLOWM)
33364          ENDIF
33365          FMAX = EXP(-TSLOPE*TMAX)-ONE
33366          R = DT_RNDM(RR)
33367          T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
33368          IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
33369       ENDIF
33370
33371 *   target hadron in Lab after scattering
33372       ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
33373       PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
33374       IF (PLRH(2).LE.TINY10) THEN
33375 C        WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
33376          GOTO 1
33377       ENDIF
33378 *   projectile hadron in Lab after scattering
33379       ELRH(1) = ELAB+AAM(IT)-ELRH(2)
33380       PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
33381 *   scattering angle of projectile in Lab
33382       CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
33383       STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
33384       CALL DT_DSFECF(SPLABP,CPLABP)
33385 *   direction cosines of projectile in Lab
33386       CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
33387      &                          CXRH(1),CYRH(1),CZRH(1))
33388 *   scattering angle of target in Lab
33389       PLLABT = PLAB-CTLABP*PLRH(1)
33390       CTLABT = PLLABT/PLRH(2)
33391       STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
33392 *   direction cosines of target in Lab
33393       CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
33394      &                            CXRH(2),CYRH(2),CZRH(2))
33395 *   fill /HNFSPA/
33396       IRH = 2
33397       ITRH(1) = IP
33398       ITRH(2) = IT
33399
33400       RETURN
33401       END
33402
33403 *$ CREATE DT_TSAMCS.FOR
33404 *COPY DT_TSAMCS
33405 *
33406 *===tsamcs=============================================================*
33407 *
33408       SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
33409
33410 ************************************************************************
33411 * Sampling of cos(theta) for nucleon-proton scattering according to    *
33412 * hetkfa2/bertini parametrization.                                     *
33413 * This is a revised version of the original (HJM 24/10/88)             *
33414 * This version dated 28.10.95 is written by S. Roesler                 *
33415 ************************************************************************
33416
33417       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33418       SAVE
33419       PARAMETER ( LINP = 10 ,
33420      &            LOUT = 6 ,
33421      &            LDAT = 9 )
33422       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
33423      &           TINY10=1.0D-10)
33424
33425       DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
33426       DIMENSION PDCI(60),PDCH(55)
33427
33428       DATA (DCLIN(I),I=1,80) /
33429      &     5.000D-01,  1.000D+00,  0.000D+00,  1.000D+00,  0.000D+00,
33430      &     4.993D-01,  9.881D-01,  5.963D-02,  9.851D-01,  5.945D-02,
33431      &     4.936D-01,  8.955D-01,  5.224D-01,  8.727D-01,  5.091D-01,
33432      &     4.889D-01,  8.228D-01,  8.859D-01,  7.871D-01,  8.518D-01,
33433      &     4.874D-01,  7.580D-01,  1.210D+00,  7.207D-01,  1.117D+00,
33434      &     4.912D-01,  6.969D-01,  1.516D+00,  6.728D-01,  1.309D+00,
33435      &     5.075D-01,  6.471D-01,  1.765D+00,  6.667D-01,  1.333D+00,
33436      &     5.383D-01,  6.054D-01,  1.973D+00,  7.059D-01,  1.176D+00,
33437      &     5.397D-01,  5.990D-01,  2.005D+00,  7.023D-01,  1.191D+00,
33438      &     5.336D-01,  6.083D-01,  1.958D+00,  6.959D-01,  1.216D+00,
33439      &     5.317D-01,  6.075D-01,  1.962D+00,  6.897D-01,  1.241D+00,
33440      &     5.300D-01,  6.016D-01,  1.992D+00,  6.786D-01,  1.286D+00,
33441      &     5.281D-01,  6.063D-01,  1.969D+00,  6.786D-01,  1.286D+00,
33442      &     5.280D-01,  5.960D-01,  2.020D+00,  6.667D-01,  1.333D+00,
33443      &     5.273D-01,  5.920D-01,  2.040D+00,  6.604D-01,  1.358D+00,
33444      &     5.273D-01,  5.862D-01,  2.069D+00,  6.538D-01,  1.385D+00/
33445       DATA (DCLIN(I),I=81,160) /
33446      &     5.223D-01,  5.980D-01,  2.814D+00,  6.538D-01,  1.385D+00,
33447      &     5.202D-01,  5.969D-01,  2.822D+00,  6.471D-01,  1.412D+00,
33448      &     5.183D-01,  5.881D-01,  2.883D+00,  6.327D-01,  1.469D+00,
33449      &     5.159D-01,  5.866D-01,  2.894D+00,  6.250D-01,  1.500D+00,
33450      &     5.133D-01,  5.850D-01,  2.905D+00,  6.170D-01,  1.532D+00,
33451      &     5.106D-01,  5.833D-01,  2.917D+00,  6.087D-01,  1.565D+00,
33452      &     5.084D-01,  5.801D-01,  2.939D+00,  6.000D-01,  1.600D+00,
33453      &     5.063D-01,  5.763D-01,  2.966D+00,  5.909D-01,  1.636D+00,
33454      &     5.036D-01,  5.730D-01,  2.989D+00,  5.814D-01,  1.674D+00,
33455      &     5.014D-01,  5.683D-01,  3.022D+00,  5.714D-01,  1.714D+00,
33456      &     4.986D-01,  5.641D-01,  3.051D+00,  5.610D-01,  1.756D+00,
33457      &     4.964D-01,  5.580D-01,  3.094D+00,  5.500D-01,  1.800D+00,
33458      &     4.936D-01,  5.573D-01,  3.099D+00,  5.431D-01,  1.827D+00,
33459      &     4.909D-01,  5.509D-01,  3.144D+00,  5.313D-01,  1.875D+00,
33460      &     4.885D-01,  5.512D-01,  3.142D+00,  5.263D-01,  1.895D+00,
33461      &     4.857D-01,  5.437D-01,  3.194D+00,  5.135D-01,  1.946D+00/
33462       DATA (DCLIN(I),I=161,195) /
33463      &     4.830D-01,  5.353D-01,  3.253D+00,  5.000D-01,  2.000D+00,
33464      &     4.801D-01,  5.323D-01,  3.274D+00,  4.915D-01,  2.034D+00,
33465      &     4.770D-01,  5.228D-01,  3.341D+00,  4.767D-01,  2.093D+00,
33466      &     4.738D-01,  5.156D-01,  3.391D+00,  4.643D-01,  2.143D+00,
33467      &     4.701D-01,  5.010D-01,  3.493D+00,  4.444D-01,  2.222D+00,
33468      &     4.672D-01,  4.990D-01,  3.507D+00,  4.375D-01,  2.250D+00,
33469      &     4.634D-01,  4.856D-01,  3.601D+00,  4.194D-01,  2.323D+00/
33470
33471       DATA PDCI /
33472      &     4.400D+02,  1.896D-01,  1.931D-01,  1.982D-01,  1.015D-01,
33473      &     1.029D-01,  4.180D-02,  4.228D-02,  4.282D-02,  4.350D-02,
33474      &     2.204D-02,  2.236D-02,  5.900D+02,  1.433D-01,  1.555D-01,
33475      &     1.774D-01,  1.000D-01,  1.128D-01,  5.132D-02,  5.600D-02,
33476      &     6.158D-02,  6.796D-02,  3.660D-02,  3.820D-02,  6.500D+02,
33477      &     1.192D-01,  1.334D-01,  1.620D-01,  9.527D-02,  1.141D-01,
33478      &     5.283D-02,  5.952D-02,  6.765D-02,  7.878D-02,  4.796D-02,
33479      &     6.957D-02,  8.000D+02,  4.872D-02,  6.694D-02,  1.152D-01,
33480      &     9.348D-02,  1.368D-01,  6.912D-02,  7.953D-02,  9.577D-02,
33481      &     1.222D-01,  7.755D-02,  9.525D-02,  1.000D+03,  3.997D-02,
33482      &     5.456D-02,  9.804D-02,  8.084D-02,  1.208D-01,  6.520D-02,
33483      &     8.233D-02,  1.084D-01,  1.474D-01,  9.328D-02,  1.093D-01/
33484
33485       DATA PDCH /
33486      &     1.000D+03,  9.453D-02,  9.804D-02,  8.084D-02,  1.208D-01,
33487      &     6.520D-02,  8.233D-02,  1.084D-01,  1.474D-01,  9.328D-02,
33488      &     1.093D-01,  1.400D+03,  1.072D-01,  7.450D-02,  6.645D-02,
33489      &     1.136D-01,  6.750D-02,  8.580D-02,  1.110D-01,  1.530D-01,
33490      &     1.010D-01,  1.350D-01,  2.170D+03,  4.004D-02,  3.013D-02,
33491      &     2.664D-02,  5.511D-02,  4.240D-02,  7.660D-02,  1.364D-01,
33492      &     2.300D-01,  1.670D-01,  2.010D-01,  2.900D+03,  1.870D-02,
33493      &     1.804D-02,  1.320D-02,  2.970D-02,  2.860D-02,  5.160D-02,
33494      &     1.020D-01,  2.400D-01,  2.250D-01,  3.370D-01,  4.400D+03,
33495      &     1.196D-03,  8.784D-03,  1.517D-02,  2.874D-02,  2.488D-02,
33496      &     4.464D-02,  8.330D-02,  2.008D-01,  2.360D-01,  3.567D-01/
33497
33498       DATA (DCHN(I),I=1,90) /
33499      &     4.770D-01,  4.750D-01,  4.715D-01,  4.685D-01,  4.650D-01,
33500      &     4.610D-01,  4.570D-01,  4.550D-01,  4.500D-01,  4.450D-01,
33501      &     4.405D-01,  4.350D-01,  4.300D-01,  4.250D-01,  4.200D-01,
33502      &     4.130D-01,  4.060D-01,  4.000D-01,  3.915D-01,  3.840D-01,
33503      &     3.760D-01,  3.675D-01,  3.580D-01,  3.500D-01,  3.400D-01,
33504      &     3.300D-01,  3.200D-01,  3.100D-01,  3.000D-01,  2.900D-01,
33505      &     2.800D-01,  2.700D-01,  2.600D-01,  2.500D-01,  2.400D-01,
33506      &     2.315D-01,  2.240D-01,  2.150D-01,  2.060D-01,  2.000D-01,
33507      &     1.915D-01,  1.850D-01,  1.780D-01,  1.720D-01,  1.660D-01,
33508      &     1.600D-01,  1.550D-01,  1.500D-01,  1.450D-01,  1.400D-01,
33509      &     1.360D-01,  1.320D-01,  1.280D-01,  1.250D-01,  1.210D-01,
33510      &     1.180D-01,  1.150D-01,  1.120D-01,  1.100D-01,  1.070D-01,
33511      &     1.050D-01,  1.030D-01,  1.010D-01,  9.900D-02,  9.700D-02,
33512      &     9.550D-02,  9.480D-02,  9.400D-02,  9.200D-02,  9.150D-02,
33513      &     9.100D-02,  9.000D-02,  8.990D-02,  8.900D-02,  8.850D-02,
33514      &     8.750D-02,  8.700D-02,  8.650D-02,  8.550D-02,  8.500D-02,
33515      &     8.499D-02,  8.450D-02,  8.350D-02,  8.300D-02,  8.250D-02,
33516      &     8.150D-02,  8.100D-02,  8.030D-02,  8.000D-02,  7.990D-02/
33517       DATA (DCHN(I),I=91,143) /
33518      &     7.980D-02,  7.950D-02,  7.900D-02,  7.860D-02,  7.800D-02,
33519      &     7.750D-02,  7.650D-02,  7.620D-02,  7.600D-02,  7.550D-02,
33520      &     7.530D-02,  7.500D-02,  7.499D-02,  7.498D-02,  7.480D-02,
33521      &     7.450D-02,  7.400D-02,  7.350D-02,  7.300D-02,  7.250D-02,
33522      &     7.230D-02,  7.200D-02,  7.100D-02,  7.050D-02,  7.020D-02,
33523      &     7.000D-02,  6.999D-02,  6.995D-02,  6.993D-02,  6.991D-02,
33524      &     6.990D-02,  6.870D-02,  6.850D-02,  6.800D-02,  6.780D-02,
33525      &     6.750D-02,  6.700D-02,  6.650D-02,  6.630D-02,  6.600D-02,
33526      &     6.550D-02,  6.525D-02,  6.510D-02,  6.500D-02,  6.499D-02,
33527      &     6.498D-02,  6.496D-02,  6.494D-02,  6.493D-02,  6.490D-02,
33528      &     6.488D-02,  6.485D-02,  6.480D-02/
33529
33530       DATA DCHNA /
33531      &     6.300D+02,  7.810D-02,  1.421D-01,  1.979D-01,  2.479D-01,
33532      &     3.360D-01,  5.400D-01,  7.236D-01,  1.000D+00,  1.540D+03,
33533      &     2.225D-01,  3.950D-01,  5.279D-01,  6.298D-01,  7.718D-01,
33534      &     9.405D-01,  9.835D-01,  1.000D+00,  2.560D+03,  2.625D-01,
33535      &     4.550D-01,  5.963D-01,  7.020D-01,  8.380D-01,  9.603D-01,
33536      &     9.903D-01,  1.000D+00,  3.520D+03,  4.250D-01,  6.875D-01,
33537      &     8.363D-01,  9.163D-01,  9.828D-01,  1.000D+00,  1.000D+00,
33538      &     1.000D+00/
33539
33540       DATA DCHNB /
33541      &     6.300D+02,  3.800D-02,  7.164D-02,  1.275D-01,  2.171D-01,
33542      &     3.227D-01,  4.091D-01,  5.051D-01,  6.061D-01,  7.074D-01,
33543      &     8.434D-01,  1.000D+00,  2.040D+03,  1.200D-01,  2.115D-01,
33544      &     3.395D-01,  5.295D-01,  7.251D-01,  8.511D-01,  9.487D-01,
33545      &     9.987D-01,  1.000D+00,  1.000D+00,  1.000D+00,  2.200D+03,
33546      &     1.344D-01,  2.324D-01,  3.754D-01,  5.674D-01,  7.624D-01,
33547      &     8.896D-01,  9.808D-01,  1.000D+00,  1.000D+00,  1.000D+00,
33548      &     1.000D+00,  2.850D+03,  2.330D-01,  4.130D-01,  6.610D-01,
33549      &     9.010D-01,  9.970D-01,  1.000D+00,  1.000D+00,  1.000D+00,
33550      &     1.000D+00,  1.000D+00,  1.000D+00,  3.500D+03,  3.300D-01,
33551      &     5.450D-01,  7.950D-01,  1.000D+00,  1.000D+00,  1.000D+00,
33552      &     1.000D+00,  1.000D+00,  1.000D+00,  1.000D+00,  1.000D+00/
33553
33554       CST = ONE
33555       IF (EKIN.GT.3.5D0) RETURN
33556 C
33557       IF(KPROJ.EQ.8) GOTO 101
33558       IF(KPROJ.EQ.1) GOTO 102
33559 C*                                             INVALID REACTION
33560       WRITE(LOUT,'(A,I5/A)')
33561      &        ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
33562      &        ' COS(THETA) = 1D0 RETURNED'
33563       RETURN
33564 C-------------------------------- NP ELASTIC SCATTERING----------
33565 101   CONTINUE
33566       IF (EKIN.GT.0.740D0)GOTO 1000
33567       IF (EKIN.LT.0.300D0)THEN
33568 C                                 EKIN .LT. 300 MEV
33569          IDAT=1
33570       ELSE
33571 C                                 300 MEV < EKIN < 740 MEV
33572          IDAT=6
33573       END IF
33574 C
33575       ENER=EKIN
33576       IE=INT(ABS(ENER/0.020D0))
33577       UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
33578 C                                            FORWARD/BACKWARD DECISION
33579       K=IDAT+5*IE
33580       BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
33581       IF (DT_RNDM(CST).LT.BWFW)THEN
33582          VALUE2=-1D0
33583          K=K+1
33584       ELSE
33585          VALUE2=1D0
33586          K=K+3
33587       END IF
33588 C
33589       COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
33590       RND=DT_RNDM(COEF)
33591 C
33592       IF(RND.LT.COEF)THEN
33593          CST=DT_RNDM(RND)
33594          CST=CST*VALUE2
33595       ELSE
33596          R1=DT_RNDM(CST)
33597          R2=DT_RNDM(R1)
33598          R3=DT_RNDM(R2)
33599          R4=DT_RNDM(R3)
33600 C
33601          IF(VALUE2.GT.0.0)THEN
33602             CST=MAX(R1,R2,R3,R4)
33603             GOTO 1500
33604          ELSE
33605             R5=DT_RNDM(R4)
33606 C
33607             IF (IDAT.EQ.1)THEN
33608                CST=-MAX(R1,R2,R3,R4,R5)
33609             ELSE
33610                R6=DT_RNDM(R5)
33611                R7=DT_RNDM(R6)
33612                CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
33613             END IF
33614 C
33615          END IF
33616 C
33617       END IF
33618 C
33619       GOTO 1500
33620 C
33621 C********                                EKIN  .GT.  0.74 GEV
33622 C
33623 1000  ENER=EKIN - 0.66D0
33624 C     IE=ABS(ENER/0.02)
33625       IE=INT(ENER/0.02D0)
33626       EMEV=EKIN*1D3
33627 C
33628       UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
33629       K=IE
33630       BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
33631       RND=DT_RNDM(BWFW)
33632 C                                        FORWARD NEUTRON
33633       IF (RND.GE.BWFW)THEN
33634          DO 1200 K=10,36,9
33635            IF (DCHNA(K).GT.EMEV) THEN
33636               UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
33637               UNIV=DT_RNDM(UNIVE)
33638               DO 1100 I=1,8
33639                  II=K+I
33640                  P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
33641 C
33642                  IF (P.GT.UNIV)THEN
33643                     UNIV=DT_RNDM(UNIVE)
33644                     FLTI=DBLE(I)-UNIV
33645                     GOTO(290,290,290,290,330,340,350,360) I
33646                  END IF
33647  1100         CONTINUE
33648            END IF
33649  1200    CONTINUE
33650 C
33651       ELSE
33652 C                                        BACKWARD NEUTRON
33653          DO 1400 K=13,60,12
33654             IF (DCHNB(K).GT.EMEV) THEN
33655                UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
33656                UNIV=DT_RNDM(UNIVE)
33657                DO 1300 I=1,11
33658                  II=K+I
33659                  P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
33660 C
33661                  IF (P.GT.UNIV)THEN
33662                    UNIV=DT_RNDM(P)
33663                    FLTI=DBLE(I)-UNIV
33664                    GOTO(120,120,140,150,160,160,180,190,200,210,220) I
33665                  END IF
33666  1300          CONTINUE
33667             END IF
33668  1400    CONTINUE
33669       END IF
33670 C
33671 120   CST=1.0D-2*FLTI-1.0D0
33672       GOTO 1500
33673 140   CST=2.0D-2*UNIV-0.98D0
33674       GOTO 1500
33675 150   CST=4.0D-2*UNIV-0.96D0
33676       GOTO 1500
33677 160   CST=6.0D-2*FLTI-1.16D0
33678       GOTO 1500
33679 180   CST=8.0D-2*UNIV-0.80D0
33680       GOTO 1500
33681 190   CST=1.0D-1*UNIV-0.72D0
33682       GOTO 1500
33683 200   CST=1.2D-1*UNIV-0.62D0
33684       GOTO 1500
33685 210   CST=2.0D-1*UNIV-0.50D0
33686       GOTO 1500
33687 220   CST=3.0D-1*(UNIV-1.0D0)
33688       GOTO 1500
33689 C
33690 290   CST=1.0D0-2.5d-2*FLTI
33691       GOTO 1500
33692 330   CST=0.85D0+0.5D-1*UNIV
33693       GOTO 1500
33694 340   CST=0.70D0+1.5D-1*UNIV
33695       GOTO 1500
33696 350   CST=0.50D0+2.0D-1*UNIV
33697       GOTO 1500
33698 360   CST=0.50D0*UNIV
33699 C
33700 1500  RETURN
33701 C
33702 C-----------------------------------  PP ELASTIC SCATTERING -------
33703 C
33704  102  CONTINUE
33705       EMEV=EKIN*1D3
33706 C
33707       IF (EKIN.LE.0.500D0) THEN
33708          RND=DT_RNDM(EMEV)
33709          CST=2.0D0*RND-1.0D0
33710          RETURN
33711 C
33712       ELSEIF (EKIN.LT.1.0D0) THEN
33713          DO 2200 K=13,60,12
33714             IF (PDCI(K).GT.EMEV) THEN
33715                UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
33716                UNIV=DT_RNDM(UNIVE)
33717                SUM=0
33718                DO 2100 I=1,11
33719                  II=K+I
33720                  SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
33721 C
33722                  IF (UNIV.LT.SUM)THEN
33723                    UNIV=DT_RNDM(SUM)
33724                    FLTI=DBLE(I)-UNIV
33725                    GOTO(55,55,55,60,60,65,65,65,65,70,70) I
33726                  END IF
33727  2100          CONTINUE
33728             END IF
33729  2200    CONTINUE
33730       ELSE
33731          DO 2400 K=12,55,11
33732             IF (PDCH(K).GT.EMEV) THEN
33733               UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
33734               UNIV=DT_RNDM(UNIVE)
33735               SUM=0.0D0
33736               DO 2300 I=1,10
33737                 II=K+I
33738                 SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
33739 C
33740                 IF (UNIV.LT.SUM)THEN
33741                   UNIV=DT_RNDM(SUM)
33742                   FLTI=UNIV+DBLE(I)
33743                   GOTO(50,55,60,60,65,65,65,65,70,70) I
33744                 END IF
33745  2300         CONTINUE
33746             END IF
33747  2400    CONTINUE
33748       END IF
33749 C
33750 50    CST=0.4D0*UNIV
33751       GOTO 2500
33752 55    CST=0.2D0*FLTI
33753       GOTO 2500
33754 60    CST=0.3D0+0.1D0*FLTI
33755       GOTO 2500
33756 65    CST=0.6D0+0.04D0*FLTI
33757       GOTO 2500
33758 70    CST=0.78D0+0.02D0*FLTI
33759 C
33760 2500  CONTINUE
33761       IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
33762 C
33763       RETURN
33764       END
33765
33766 *$ CREATE DT_DHADRI.FOR
33767 *COPY DT_DHADRI
33768 *
33769 *===dhadri=============================================================*
33770 *
33771       SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
33772
33773       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33774       SAVE
33775
33776       PARAMETER ( LINP = 10 ,
33777      &            LOUT = 6 ,
33778      &            LDAT = 9 )
33779 C
33780 C-----------------------------
33781 C*** INPUT VARIABLES LIST:
33782 C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
33783 C*** GEV/C LABORATORY MOMENTUM REGION
33784 C*** N    - PROJECTILE HADRON INDEX
33785 C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
33786 C*** ELAB - LABORATORY ENERGY OF N (GEV)
33787 C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
33788 C*** ITTA - TARGET NUCLEON INDEX
33789 C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
33790 C  IR COUNTS THE NUMBER OF PRODUCED PARTICLES
33791 C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
33792 C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
33793 C*** RESPECT., UNITS (GEV/C AND GEV)
33794 C----------------------------
33795
33796       COMMON /HNGAMR/ REDU,AMO,AMM(15)
33797       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33798       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33799      &                NRK(2,268),NURE(30,2)
33800 * particle properties (BAMJET index convention),
33801 * (dublicate of DTPART for HADRIN)
33802       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33803      &                K1H(110),K2H(110)
33804       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33805       COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
33806      &                ITS(149),IS
33807       COMMON /HNDRUN/ RUNTES,EFTES
33808 * particle properties (BAMJET index convention)
33809       CHARACTER*8  ANAME
33810       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33811      &                IICH(210),IIBAR(210),K1(210),K2(210)
33812 * final state from HADRIN interaction
33813       PARAMETER (MAXFIN=10)
33814       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
33815      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
33816
33817       DIMENSION ITPRF(110)
33818       DATA NNN/0/
33819       DATA UMODA/0./
33820       DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
33821       LOWP=0
33822       IF (N.LE.0.OR.N.GE.111)N=1
33823       IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
33824         GOTO 280
33825 *       WRITE (6,1000)
33826 *    +  ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
33827 *       STOP
33828 *1000   FORMAT (3(5H ****/),A,2I4,3(5H ****/))
33829 *    +  45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
33830       ENDIF
33831       IATMPT=0
33832       IF (ABS(PLAB-5.0D0).LT.4.99999D0)                        GO TO 20
33833 C     IF(IPRI.GE.1) WRITE (6,1010) PLAB
33834 C     STOP
33835  1010 FORMAT ( '  PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
33836      + ALLOWED REGION, PLAB=',1E15.5)
33837
33838    20 CONTINUE
33839       UMODAT=N*1.11111D0+ITTA*2.19291D0
33840       IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
33841       UMODA=UMODAT
33842    30 IATMPT=0
33843       LOWP=LOWP+1
33844    40 CONTINUE
33845       IMACH=0
33846       REDU=2.0D0
33847       IF (LOWP.GT.20) THEN
33848 C        WRITE(LOUT,*) ' jump 1'
33849          GO TO 280
33850       ENDIF
33851       NNN=N
33852       IF (NNN.EQ.N)                                             GO TO 50
33853       RUNTES=0.0D0
33854       EFTES=0.0D0
33855    50 CONTINUE
33856       IS=1
33857       IRH=0
33858       IST=1
33859       NSTAB=23
33860       IRE=NURE(N,1)
33861       IF(ITTA.GT.1) IRE=NURE(N,2)
33862 C
33863 C-----------------------------
33864 C*** IE,AMT,ECM,SI DETERMINATION
33865 C----------------------------
33866       CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
33867       IANTH=-1
33868 **sr
33869 C     IF (AMH(1).NE.0.93828D0) IANTH=1
33870       IF (AMH(1).NE.0.9383D0) IANTH=1
33871 **
33872       IF (IANTH.GE.0) SI=1.0D0
33873       ECMMH=ECM
33874 C
33875 C-----------------------------
33876 C    ENERGY INDEX
33877 C  IRE CHARACTERIZES THE REACTION
33878 C  IE IS THE ENERGY INDEX
33879 C----------------------------
33880       IF (SI.LT.1.D-6) THEN
33881 C        WRITE(LOUT,*) ' jump 2'
33882          GO TO 280
33883       ENDIF
33884       IF (N.LE.NSTAB)                                           GO TO 60
33885       RUNTES=RUNTES+1.0D0
33886       IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
33887  1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
33888       IF(IBARH(N).EQ.1) N=8
33889       IF(IBARH(N).EQ.-1)  N=9
33890    60 CONTINUE
33891       IMACH=IMACH+1
33892 **sr 19.2.97: loop for direct channel suppression
33893 C     IF (IMACH.GT.10) THEN
33894       IF (IMACH.GT.1000) THEN
33895 **
33896 C        WRITE(LOUT,*) ' jump 3'
33897          GO TO 280
33898       ENDIF
33899       ECM =ECMMH
33900       AMN2=AMN**2
33901       AMT2=AMT**2
33902       ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM    )
33903       IF(ECMN.LE.AMN) ECMN=AMN
33904       PCMN=SQRT(ECMN**2-AMN2)
33905       GAM=(ELAB+AMT)/ECM
33906       BGAM=PLAB/ECM
33907       IF (IANTH.GE.0) ECM=2.1D0
33908 C
33909 C-----------------------------
33910 C*** RANDOM CHOICE OF REACTION CHANNEL
33911 C----------------------------
33912       IST=0
33913       VV=DT_RNDM(AMN2)
33914       VV=VV-1.D-17
33915 C
33916 C-----------------------------
33917 C***  PLACE REDUCED VERSION
33918 C----------------------------
33919       IIEI=IEII(IRE)
33920       IDWK=IEII(IRE+1)-IIEI
33921       IIWK=IRII(IRE)
33922       IIKI=IKII(IRE)
33923 C
33924 C-----------------------------
33925 C***  SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
33926 C----------------------------
33927       HECM=ECM
33928       HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
33929       IF (HUMO.LT.ECM) ECM=HUMO
33930 C
33931 C-----------------------------
33932 C*** INTERPOLATION PREPARATION
33933 C----------------------------
33934       ECMO=UMO(IE)
33935       ECM1=UMO(IE-1)
33936       DECM=ECMO-ECM1
33937       DEC=ECMO-ECM
33938 C
33939 C-----------------------------
33940 C*** RANDOM LOOP
33941 C----------------------------
33942       IK=0
33943       WKK=0.0D0
33944       WICOR=0.0D0
33945    70 IK=IK+1
33946       IWK=IIWK+(IK-1)*IDWK+IE-IIEI
33947       WOK=WK(IWK)
33948       WDK=WOK-WK(IWK-1)
33949 C
33950 C-----------------------------
33951 C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
33952 C    GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
33953 C    CONTRIBUTE
33954 C----------------------------
33955       IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
33956       WICO=WOK*1.23459876D0+WDK*1.735218469D0
33957       IF (WICO.EQ.WICOR)                                        GO TO 70
33958       IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
33959       WICOR=WICO
33960 C
33961 C-----------------------------
33962 C*** INTERPOLATION IN CHANNEL WEIGHTS
33963 C----------------------------
33964       EKLIM=-THRESH(IIKI+IK)
33965       IELIM=IDT_IEFUND(EKLIM,IRE)
33966       DELIM=UMO(IELIM)+EKLIM
33967      *+1.D-16
33968       DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
33969       IF (DELIM*DELIM-DETE*DETE) 90,90,80
33970    80 DECC=DELIM
33971                                                                GO TO 100
33972    90 DECC=DECM
33973   100 CONTINUE
33974       WKK=WOK-WDK*DEC/(DECC+1.D-9)
33975 C
33976 C-----------------------------
33977 C*** RANDOM CHOICE
33978 C----------------------------
33979 C
33980       IF (VV.GT.WKK)                                            GO TO 70
33981 C
33982 C***IK IS THE REACTION CHANNEL
33983 C----------------------------
33984       INRK=IKII(IRE)+IK
33985       ECM=HECM
33986       I1001 =0
33987 C
33988   110 CONTINUE
33989       IT1=NRK(1,INRK)
33990       AM1=DT_DAMG(IT1)
33991       IT2=NRK(2,INRK)
33992       AM2=DT_DAMG(IT2)
33993       AMS=AM1+AM2
33994       I1001=I1001+1
33995       IF (I1001.GT.50)                                          GO TO 60
33996 C
33997       IF (IT2*AMS.GT.IT2*ECM)                                  GO TO 110
33998       IT11=IT1
33999       IT22=IT2
34000       IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
34001       AM11=AM1
34002       AM22=AM2
34003       IF (IT2.GT.0)                                            GO TO 120
34004 **sr 19.2.97: supress direct channel for pp-collisions
34005       IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
34006          RR = DT_RNDM(AM11)
34007          IF (RR.LE.0.75D0) GOTO 60
34008       ENDIF
34009 **
34010 C
34011 C-----------------------------
34012 C  INCLUSION OF DIRECT RESONANCES
34013 C  RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE  IT1
34014 C------------------------
34015       KZ1=K1H(IT1)
34016       IST=IST+1
34017       IECO=0
34018       ECO=ECM
34019       GAM=(ELAB+AMT)/ECO
34020       BGAM=PLAB/ECO
34021       CXS(1)=CX
34022       CYS(1)=CY
34023       CZS(1)=CZ
34024                                                                GO TO 170
34025   120 CONTINUE
34026       WW=DT_RNDM(ECO)
34027       IF(WW.LT. 0.5D0)                                         GO TO 130
34028       IT1=IT22
34029       IT2=IT11
34030       AM1=AM22
34031       AM2=AM11
34032   130 CONTINUE
34033 C
34034 C-----------------------------
34035 C   THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
34036       IBN=IBARH(N)
34037       IB1=IBARH(IT1)
34038       IT11=IT1
34039       IT22=IT2
34040       AM11=AM1
34041       AM22=AM2
34042       IF(IB1.EQ.IBN)                                           GO TO 140
34043       IT1=IT22
34044       IT2=IT11
34045       AM1=AM22
34046       AM2=AM11
34047   140 CONTINUE
34048 C-----------------------------
34049 C***IT1,IT2 ARE THE CREATED PARTICLES
34050 C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
34051 C------------------------
34052       CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
34053      *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
34054       IST=IST+1
34055       ITS(IST)=IT1
34056       AMM(IST)=AM1
34057 C
34058 C-----------------------------
34059 C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
34060 C----------------------------
34061       CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
34062      &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34063       IST=IST+1
34064       ITS(IST)=IT2
34065       AMM(IST)=AM2
34066       CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
34067      *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34068   150 CONTINUE
34069 C
34070 C-----------------------------
34071 C***TEST   STABLE OR UNSTABLE
34072 C----------------------------
34073       IF(ITS(IST).GT.NSTAB)                                    GO TO 160
34074       IRH=IRH+1
34075 C
34076 C-----------------------------
34077 C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
34078 C----------------------------
34079 C*    IF (REDU.LT.0.D0) GO TO 1009
34080       ITRH(IRH)=ITS(IST)
34081       PLRH(IRH)=PLS(IST)
34082       CXRH(IRH)=CXS(IST)
34083       CYRH(IRH)=CYS(IST)
34084       CZRH(IRH)=CZS(IST)
34085       ELRH(IRH)=ELS(IST)
34086       IST=IST-1
34087       IF(IST.GE.1)                                             GO TO 150
34088                                                                GO TO 260
34089   160 CONTINUE
34090 C
34091 C  RANDOM CHOICE OF DECAY CHANNELS
34092 C----------------------------
34093 C
34094       IT=ITS(IST)
34095       ECO=AMM(IST)
34096       GAM=ELS(IST)/ECO
34097       BGAM=PLS(IST)/ECO
34098       IECO=0
34099       KZ1=K1H(IT)
34100   170 CONTINUE
34101       IECO=IECO+1
34102       VV=DT_RNDM(GAM)
34103       VV=VV-1.D-17
34104       IIK=KZ1-1
34105   180 IIK=IIK+1
34106       IF (VV.GT.WTI(IIK))                                      GO TO 180
34107 C
34108 C  IIK IS THE DECAY CHANNEL
34109 C----------------------------
34110       IT1=NZKI(IIK,1)
34111       I310=0
34112   190 CONTINUE
34113       I310=I310+1
34114       AM1=DT_DAMG(IT1)
34115       IT2=NZKI(IIK,2)
34116       AM2=DT_DAMG(IT2)
34117       IF (IT2-1.LT.0)                                          GO TO 240
34118       IT3=NZKI(IIK,3)
34119       AM3=DT_DAMG(IT3)
34120       AMS=AM1+AM2+AM3
34121 C
34122 C  IF  IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
34123 C----------------------------
34124       IF (IECO.LE.10)                                          GO TO 200
34125       IATMPT=IATMPT+1
34126       IF(IATMPT.GT.3) THEN
34127 C        WRITE(LOUT,*) ' jump 4'
34128          GO TO 280
34129       ENDIF
34130                                                                 GO TO 40
34131   200 CONTINUE
34132       IF (I310.GT.50)                                          GO TO 170
34133       IF (AMS.GT.ECO)                                          GO TO 190
34134 C
34135 C  FOR THE DECAY CHANNEL
34136 C  IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM  IT
34137 C----------------------------
34138       IF (REDU.LT.0.D0)                                        GO TO 30
34139       ITWTHC=0
34140       REDU=2.0D0
34141       IF(IT3.EQ.0)                                             GO TO 220
34142   210 CONTINUE
34143       ITWTH=1
34144       CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
34145      *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
34146                                                                GO TO 230
34147   220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
34148      &COD2,COF2,SIF2,AM1,AM2)
34149       ITWTH=-1
34150       IT3=0
34151   230 CONTINUE
34152       ITWTHC=ITWTHC+1
34153       IF (REDU.GT.0.D0)                                        GO TO 240
34154       REDU=2.0D0
34155       IF (ITWTHC.GT.100)                                        GO TO 30
34156       IF (ITWTH) 220,220,210
34157   240 CONTINUE
34158       ITS(IST  )=IT1
34159       IF (IT2-1.LT.0)                                          GO TO 250
34160       ITS(IST+1)  =IT2
34161       ITS(IST+2)=IT3
34162       RX=CXS(IST)
34163       RY=CYS(IST)
34164       RZ=CZS(IST)
34165       AMM(IST)=AM1
34166       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
34167      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34168       IST=IST+1
34169       AMM(IST)=AM2
34170       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
34171      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34172       IF (IT3.LE.0)                                            GO TO 250
34173       IST=IST+1
34174       AMM(IST)=AM3
34175       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
34176      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
34177   250 CONTINUE
34178                                                                GO TO 150
34179   260 CONTINUE
34180   270 CONTINUE
34181       RETURN
34182   280 CONTINUE
34183 C
34184 C----------------------------
34185 C
34186 C   ZERO CROSS SECTION CASE
34187 C----------------------------
34188 C
34189       IRH=1
34190       ITRH(1)=N
34191       CXRH(1)=CX
34192       CYRH(1)=CY
34193       CZRH(1)=CZ
34194       ELRH(1)=ELAB
34195       PLRH(1)=PLAB
34196       RETURN
34197       END
34198
34199 *$ CREATE DT_RUNTT.FOR
34200 *COPY DT_RUNTT
34201 *
34202 *===runtt==============================================================*
34203 *
34204       BLOCK DATA DT_RUNTT
34205
34206       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34207       SAVE
34208
34209       COMMON /HNDRUN/ RUNTES,EFTES
34210
34211       DATA RUNTES,EFTES /100.D0,100.D0/
34212
34213       END
34214
34215 *$ CREATE DT_NONAME.FOR
34216 *COPY DT_NONAME
34217 *
34218 *===noname=============================================================*
34219 *
34220       BLOCK DATA DT_NONAME
34221
34222       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34223       SAVE
34224
34225 * slope parameters for HADRIN interactions
34226       COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
34227       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34228
34229 C     DATAS     DATAS    DATAS      DATAS     DATAS
34230 C******          *********
34231       DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
34232      &           207, 224, 241, 252, 268 /
34233       DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
34234      &           220, 241, 262, 279, 296 /
34235       DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
34236      &           3364, 3507, 4011, 4368, 4725, 4912, 5184/
34237
34238 C
34239 C     MASSES FOR THE SLOPE B(M) IN GEV
34240 C     SLOPE B(M) FOR AN MESONIC SYSTEM
34241 C     SLOPE B(M) FOR A BARYONIC SYSTEM
34242
34243 *
34244       DATA SM,BBM,BBB/  0.8D0, 0.85D0,  0.9D0, 0.95D0, 1.D0,
34245      &     1.05D0,  1.1D0, 1.15D0,  1.2D0, 1.25D0,
34246      &      1.3D0,  1.35D0, 1.4D0,  1.45D0,  1.5D0,
34247      &     1.55D0,  1.6D0,  1.65D0, 1.7D0,   1.75D0,
34248      &      1.8D0,  1.85D0, 1.9D0,  1.95D0,  2.D0,
34249      &     15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
34250      &    12.35D0, 11.7D0, 10.85D0, 10.D0,  9.15D0,
34251      &      8.3D0,  7.8D0,  7.3D0,  7.25D0,  7.2D0,
34252      &     6.95D0,  6.7D0,  6.6D0,  6.5D0,   6.3D0,
34253      &      6.1D0,  5.85D0, 5.6D0,  5.35D0,  5.1D0,
34254      &      15.D0,   15.D0, 15.D0,  15.D0,   15.D0, 15.D0, 15.D0,
34255      &     14.2D0,  13.4D0, 12.6D0,
34256      &     11.8D0, 11.2D0, 10.6D0,  9.8D0,    9.D0,
34257      &     8.25D0,  7.5D0, 6.25D0,  5.D0,    4.5D0, 5*4.D0 /
34258 *
34259       END
34260
34261 *$ CREATE DT_DAMG.FOR
34262 *COPY DT_DAMG
34263 *
34264 *===damg===============================================================*
34265 *
34266       DOUBLE PRECISION FUNCTION DT_DAMG(IT)
34267
34268       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34269       SAVE
34270
34271 * particle properties (BAMJET index convention),
34272 * (dublicate of DTPART for HADRIN)
34273       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34274      &                K1H(110),K2H(110)
34275
34276       DIMENSION GASUNI(14)
34277       DATA GASUNI/
34278      *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
34279      *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
34280       DATA GAUNO/2.352D0/
34281       DATA GAUNON/2.4D0/
34282       DATA IO/14/
34283       DATA NSTAB/23/
34284
34285       I=1
34286       IF (IT.LE.0)                                              GO TO 30
34287       IF (IT.LE.NSTAB)                                          GO TO 20
34288       DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
34289       VV=DT_RNDM(DGAUNI)
34290       VV=VV*2.0D0-1.0D0+1.D-16
34291    10 CONTINUE
34292       VO=GASUNI(I)
34293       I=I+1
34294       V1=GASUNI(I)
34295       IF (VV.GT.V1)                                             GO TO 10
34296       UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
34297      &      (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
34298       DAM=GAH(IT)*UNIGA/GAUNO
34299       AAM=AMH(IT)+DAM
34300       DT_DAMG=AAM
34301       RETURN
34302    20 CONTINUE
34303       DT_DAMG=AMH(IT)
34304       RETURN
34305    30 CONTINUE
34306       DT_DAMG=0.0D0
34307       RETURN
34308       END
34309
34310 *$ CREATE DT_DCALUM.FOR
34311 *COPY DT_DCALUM
34312 *
34313 *===dcalum=============================================================*
34314 *
34315       SUBROUTINE DT_DCALUM(N,ITTA)
34316
34317       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34318       SAVE
34319
34320 C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
34321
34322 * particle properties (BAMJET index convention),
34323 * (dublicate of DTPART for HADRIN)
34324       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34325      &                K1H(110),K2H(110)
34326       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34327       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34328       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34329      &                NRK(2,268),NURE(30,2)
34330
34331       IRE=NURE(N,ITTA/8+1)
34332       IEO=IEII(IRE)+1
34333       IEE=IEII(IRE +1)
34334       AM1=AMH(N   )
34335       AM12=AM1**2
34336       AM2=AMH(ITTA)
34337       AM22=AM2**2
34338       DO 10 IE=IEO,IEE
34339         PLAB2=PLABF(IE)**2
34340         ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
34341         UMO(IE)=ELAB
34342    10 CONTINUE
34343       IKO=IKII(IRE)+1
34344       IKE=IKII(IRE +1)
34345       UMOO=UMO(IEO)
34346       DO 30 IK=IKO,IKE
34347         IF(NRK(2,IK).GT.0)                                      GO TO 30
34348         IKI=NRK(1,IK)
34349         AMSS=5.0D0
34350         K11=K1H(IKI)
34351         K22=K2H(IKI)
34352         DO 20 IK1=K11,K22
34353           IN=NZKI(IK1,1)
34354           AMS=AMH(IN)
34355           IN=NZKI(IK1,2)
34356           IF(IN.GT.0)AMS=AMS+AMH(IN)
34357           IN=NZKI(IK1,3)
34358           IF(IN.GT.0) AMS=AMS+AMH(IN)
34359           IF (AMS.LT.AMSS) AMSS=AMS
34360    20   CONTINUE
34361         IF(UMOO.LT.AMSS) UMOO=AMSS
34362         THRESH(IK)=UMOO
34363    30 CONTINUE
34364       RETURN
34365       END
34366
34367 *$ CREATE DT_DCHANH.FOR
34368 *COPY DT_DCHANH
34369 *
34370 *===dchanh=============================================================*
34371 *
34372       SUBROUTINE DT_DCHANH
34373
34374       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34375       SAVE
34376
34377       PARAMETER ( LINP = 10 ,
34378      &            LOUT = 6 ,
34379      &            LDAT = 9 )
34380 * particle properties (BAMJET index convention),
34381 * (dublicate of DTPART for HADRIN)
34382       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34383      &                K1H(110),K2H(110)
34384       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34385       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34386       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34387      &                NRK(2,268),NURE(30,2)
34388
34389       DIMENSION HWT(460),HWK(40),SI(5184)
34390       EQUIVALENCE (WK(1),SI(1))
34391 C--------------------
34392 C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
34393 C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
34394 C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
34395 C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
34396 C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
34397 C--------------------------
34398       IREG=16
34399       DO 90 IRE=1,IREG
34400         IWKO=IRII(IRE)
34401         IEE=IEII(IRE+1)-IEII(IRE)
34402         IKE=IKII(IRE+1)-IKII(IRE)
34403         IEO=IEII(IRE)+1
34404         IIKA=IKII(IRE)
34405 *   modifications to suppress elestic scattering  24/07/91
34406         DO 80 IE=1,IEE
34407           SIS=1.D-14
34408           SINORC=0.0D0
34409           DO 10 IK=1,IKE
34410             IWK=IWKO+IEE*(IK-1)+IE
34411             IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
34412             SIS=SIS+SI(IWK)*SINORC
34413    10     CONTINUE
34414           SIIN(IEO+IE-1)=SIS
34415           SIO=0.D0
34416           IF (SIS.GE.1.D-12)                                    GO TO 20
34417           SIS=1.D0
34418           SIO=1.D0
34419    20     CONTINUE
34420           SINORC=0.0D0
34421           DO 30 IK=1,IKE
34422             IWK=IWKO+IEE*(IK-1)+IE
34423             IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
34424             SIO=SIO+SI(IWK)*SINORC/SIS
34425             HWK(IK)=SIO
34426    30     CONTINUE
34427           DO 40 IK=1,IKE
34428             IWK=IWKO+IEE*(IK-1)+IE
34429    40     WK(IWK)=HWK(IK)
34430           IIKI=IKII(IRE)
34431           DO 70 IK=1,IKE
34432             AM111=0.D0
34433             INRK1=NRK(1,IIKI+IK)
34434             IF (INRK1.GT.0) AM111=AMH(INRK1)
34435             AM222=0.D0
34436             INRK2=NRK(2,IIKI+IK)
34437             IF (INRK2.GT.0) AM222=AMH(INRK2)
34438             THRESH(IIKI+IK)=AM111 +AM222
34439             IF (INRK2-1.GE.0)                                   GO TO 60
34440             INRKK=K1H(INRK1)
34441             AMSS=5.D0
34442             INRKO=K2H(INRK1)
34443             DO 50 INRK1=INRKK,INRKO
34444               INZK1=NZKI(INRK1,1)
34445               INZK2=NZKI(INRK1,2)
34446               INZK3=NZKI(INRK1,3)
34447               IF (INZK1.LE.0.OR.INZK1.GT.110)                   GO TO 50
34448               IF (INZK2.LE.0.OR.INZK2.GT.110)                   GO TO 50
34449               IF (INZK3.LE.0.OR.INZK3.GT.110)                   GO TO 50
34450 C     WRITE (6,310)INRK1,INZK1,INZK2,INZK3
34451  1000 FORMAT (4I10)
34452               AMS=AMH(INZK1)+AMH(INZK2)
34453               IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
34454               IF (AMSS.GT.AMS) AMSS=AMS
34455    50       CONTINUE
34456             AMS=AMSS
34457             IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
34458             THRESH(IIKI+IK)=AMS
34459    60       CONTINUE
34460    70     CONTINUE
34461    80   CONTINUE
34462    90 CONTINUE
34463       DO 100 J=1,460
34464   100 HWT(J)=0.D0
34465       DO 120 I=1,110
34466         IK1=K1H(I)
34467         IK2=K2H(I)
34468         HV=0.D0
34469         IF (IK2.GT.460)IK2=460
34470         IF (IK1.LE.0)IK1=1
34471         DO 110 J=IK1,IK2
34472           HV=HV+WTI(J)
34473           HWT(J)=HV
34474           JI=J
34475   110   CONTINUE
34476         IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
34477  1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
34478   120 CONTINUE
34479       DO 130 J=1,460
34480   130 WTI(J)=HWT(J)
34481       RETURN
34482       END
34483
34484 *$ CREATE DT_DHADDE.FOR
34485 *COPY DT_DHADDE
34486 *
34487 *===dhadde=============================================================*
34488 *
34489       SUBROUTINE DT_DHADDE
34490
34491       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34492       SAVE
34493
34494 * particle properties (BAMJET index convention)
34495       CHARACTER*8  ANAME
34496       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
34497      &                IICH(210),IIBAR(210),K1(210),K2(210)
34498 * HADRIN: decay channel information
34499       PARAMETER (IDMAX9=602)
34500       CHARACTER*8 ZKNAME
34501       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
34502 * particle properties (BAMJET index convention),
34503 * (dublicate of DTPART for HADRIN)
34504       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34505      &                K1H(110),K2H(110)
34506       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
34507 * decay channel information for HADRIN
34508       COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
34509      &                K1Z(16),K2Z(16),WTZ(153),II22,
34510      &                NZK1(153),NZK2(153),NZK3(153)
34511
34512       DATA IRETUR/0/
34513
34514       IRETUR=IRETUR+1
34515       AMH(31)=0.48D0
34516       IF (IRETUR.GT.1) RETURN
34517       DO 10 I=1,94
34518         AMH(I)   = AAM(I)
34519         GAH(I)   = GA(I)
34520         TAUH(I)  = TAU(I)
34521         ICHH(I)  = IICH(I)
34522         IBARH(I) = IIBAR(I)
34523         K1H(I)   = K1(I)
34524         K2H(I)   = K2(I)
34525    10 CONTINUE
34526 **sr
34527 C     AMH(1)=0.93828D0
34528       AMH(1)=0.9383D0
34529 **
34530       AMH(2)=AMH(1)
34531       DO 20 I=26,30
34532         K1H(I)=452
34533         K2H(I)=452
34534    20 CONTINUE
34535       DO 30 I=1,307
34536         WTI(I)    = WT(I)
34537         NZKI(I,1) = NZK(I,1)
34538         NZKI(I,2) = NZK(I,2)
34539         NZKI(I,3) = NZK(I,3)
34540    30 CONTINUE
34541       DO 40 I=1,16
34542         L=I+94
34543         AMH(L)=AMZ(I)
34544         GAH( L)=GAZ(I)
34545         TAUH( L)=TAUZ(I)
34546         ICHH( L)=ICHZ(I)
34547         IBARH( L)=IBARZ(I)
34548         K1H( L)=K1Z(I)
34549         K2H( L)=K2Z(I)
34550    40 CONTINUE
34551       DO 50 I=1,153
34552         L=I+307
34553         WTI(L)    = WTZ(I)
34554         NZKI(L,3) = NZK3(I)
34555         NZKI(L,2) = NZK2(I)
34556         NZKI(L,1) = NZK1(I)
34557    50 CONTINUE
34558       RETURN
34559       END
34560
34561 *$ CREATE IDT_IEFUND.FOR
34562 *COPY IDT_IEFUND
34563 *
34564 *===iefund=============================================================*
34565 *
34566       INTEGER FUNCTION IDT_IEFUND(PL,IRE)
34567
34568       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34569       SAVE
34570
34571 C*****IEFUN CALCULATES A MOMENTUM INDEX
34572
34573       PARAMETER ( LINP = 10 ,
34574      &            LOUT = 6 ,
34575      &            LDAT = 9 )
34576       COMMON /HNDRUN/ RUNTES,EFTES
34577       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34578       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34579      &                NRK(2,268),NURE(30,2)
34580
34581       IPLA=IEII(IRE)+1
34582      *+1
34583       IPLE=IEII(IRE+1)
34584       IF (PL.LT.0.)                                             GO TO 30
34585       DO 10 I=IPLA,IPLE
34586         J=I-IPLA+1
34587         IF (PL.LE.PLABF(I))                                     GO TO 60
34588    10 CONTINUE
34589       I=IPLE
34590       IF ( EFTES.GT.40.D0)                                      GO TO 20
34591       EFTES=EFTES+1.0D0
34592       WRITE(LOUT,1000)PL,J
34593    20 CONTINUE
34594                                                                 GO TO 70
34595    30 CONTINUE
34596       DO 40 I=IPLA,IPLE
34597         J=I-IPLA+1
34598         IF (-PL.LE.UMO(I))                                      GO TO 60
34599    40 CONTINUE
34600       I=IPLE
34601       IF ( EFTES.GT.40.D0)                                      GO TO 50
34602       EFTES=EFTES+1.0D0
34603       WRITE(LOUT,1000)PL,I
34604    50 CONTINUE
34605    60 CONTINUE
34606    70 CONTINUE
34607       IDT_IEFUND=I
34608       RETURN
34609  1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
34610      +7H IEFUN=,I5)
34611       END
34612
34613 *$ CREATE DT_DSIGIN.FOR
34614 *COPY DT_DSIGIN
34615 *
34616 *===dsigin=============================================================*
34617 *
34618       SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
34619
34620       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34621       SAVE
34622
34623 * particle properties (BAMJET index convention),
34624 * (dublicate of DTPART for HADRIN)
34625       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34626      &                K1H(110),K2H(110)
34627       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
34628       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34629      &                NRK(2,268),NURE(30,2)
34630
34631       IE=IDT_IEFUND(PLAB,IRE)
34632       IF (IE.LE.IEII(IRE)) IE=IE+1
34633       AMT=AMH(ITAR)
34634       AMN=AMH(N)
34635       AMN2=AMN*AMN
34636       AMT2=AMT*AMT
34637       ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
34638 C*** INTERPOLATION PREPARATION
34639       ECMO=UMO(IE)
34640       ECM1=UMO(IE-1)
34641       DECM=ECMO-ECM1
34642       DEC=ECMO-ECM
34643       IIKI=IKII(IRE)+1
34644       EKLIM=-THRESH(IIKI)
34645       WOK=SIIN(IE)
34646       WDK=WOK-SIIN(IE-1)
34647       IF (ECM.GT.ECMO) WDK=0.0D0
34648 C*** INTERPOLATION IN CHANNEL WEIGHTS
34649       IELIM=IDT_IEFUND(EKLIM,IRE)
34650       DELIM=UMO(IELIM)+EKLIM
34651      *+1.D-16
34652       DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
34653       IF (DELIM*DELIM-DETE*DETE) 20,20,10
34654    10 DECC=DELIM
34655                                                                 GO TO 30
34656    20 DECC=DECM
34657    30 CONTINUE
34658       WKK=WOK-WDK*DEC/(DECC+1.D-9)
34659       IF (WKK.LT.0.0D0) WKK=0.0D0
34660       SI=WKK+1.D-12
34661       IF (-EKLIM.GT.ECM) SI=1.D-14
34662       RETURN
34663       END
34664
34665 *$ CREATE DT_DTCHOI.FOR
34666 *COPY DT_DTCHOI
34667 *
34668 *===dtchoi=============================================================*
34669 *
34670       SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
34671
34672       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34673       SAVE
34674
34675 C     ****************************
34676 C     TCHOIC CALCULATES A RANDOM VALUE
34677 C     FOR THE FOUR-MOMENTUM-TRANSFER T
34678 C     ****************************
34679
34680 * particle properties (BAMJET index convention),
34681 * (dublicate of DTPART for HADRIN)
34682       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34683      &                K1H(110),K2H(110)
34684 * slope parameters for HADRIN interactions
34685       COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
34686
34687       AMA=AM1
34688       AMB=AM2
34689       IF (I.GT.30.AND.II.GT.30)                                 GO TO 20
34690       III=II
34691       AM3=AM2
34692       IF (I.LE.30)                                              GO TO 10
34693       III=I
34694       AM3=AM1
34695    10 CONTINUE
34696                                                                 GO TO 30
34697    20 CONTINUE
34698       III=II
34699       AM3=AM2
34700       IF (AMA.LE.AMB)                                           GO TO 30
34701       III=I
34702       AM3=AM1
34703    30 CONTINUE
34704       IB=IBARH(III)
34705       AMA=AM3
34706       K=INT((AMA-0.75D0)/0.05D0)
34707       IF (K-2.LT.0) K=1
34708       IF (K-26.GE.0) K=25
34709       IF (IB)50,40,50
34710    40 BM=BBM(K)
34711                                                                 GO TO 60
34712    50 BM=BBB(K)
34713    60 CONTINUE
34714 C     NORMALIZATION
34715       TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1  **2
34716       TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1  **2
34717       VB=DT_RNDM(TMIN)
34718 **sr test
34719 C     IF (VB.LT.0.2D0) BM=BM*0.1
34720 C    **0.5
34721       BM = BM*5.05D0
34722 **
34723       TMI=BM*TMIN
34724       TMA=BM*TMAX
34725       ETMA=0.D0
34726       IF (ABS(TMA).GT.120.D0)                                   GO TO 70
34727       ETMA=EXP(TMA)
34728    70 CONTINUE
34729       AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
34730 C*** RANDOM CHOICE OF THE T - VALUE
34731       R=DT_RNDM(TMI)
34732       T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
34733       RETURN
34734       END
34735
34736 *$ CREATE DT_DTWOPA.FOR
34737 *COPY DT_DTWOPA
34738 *
34739 *===dtwopa=============================================================*
34740 *
34741       SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
34742      &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
34743
34744       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34745       SAVE
34746
34747 C     ******************************************************
34748 C     QUASI TWO PARTICLE PRODUCTION
34749 C     TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
34750 C     FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
34751 C     IN THE CM - SYSTEM
34752 C     COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
34753 C     SPHERICAL COORDINATES
34754 C     ******************************************************
34755
34756 * particle properties (BAMJET index convention),
34757 * (dublicate of DTPART for HADRIN)
34758       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
34759      &                K1H(110),K2H(110)
34760
34761       AMA=AM1
34762       AMB=AM2
34763       AMA2=AMA*AMA
34764       E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
34765       E2=UMOO - E1
34766       IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
34767       AMTE=(E1-AMA)*(E1+AMA)
34768       AMTE=AMTE+1.D-18
34769       P1=SQRT(AMTE)
34770       P2=P1
34771 C     / P2 / = / P1 /  BUT OPPOSITE DIRECTIONS
34772 C     DETERMINATION  OF  THE ANGLES
34773 C     COS(THETA1)=COD1      COS(THETA2)=COD2
34774 C     SIN(PHI1)=SIF1        SIN(PHI2)=SIF2
34775 C     COS(PHI1)=COF1        COS(PHI2)=COF2
34776 C     PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
34777       CALL DT_DSFECF(COF1,SIF1)
34778       COF2=-COF1
34779       SIF2=-SIF1
34780 C     CALCULATION OF THETA1
34781       CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
34782       COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
34783       IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
34784       COD2=-COD1
34785       RETURN
34786       END
34787
34788 *$ CREATE DT_ZK.FOR
34789 *COPY DT_ZK
34790 *
34791 *===zk=================================================================*
34792 *
34793       BLOCK DATA DT_ZK
34794
34795       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34796       SAVE
34797
34798 * decay channel information for HADRIN
34799       COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
34800      &                K1Z(16),K2Z(16),WTZ(153),II22,
34801      &                NZK1(153),NZK2(153),NZK3(153)
34802 * decay channel information for HADRIN
34803       CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
34804       COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
34805
34806 *     Particle masses in GeV                                           *
34807       DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
34808      &          2*1.7D0, 3*0.D0/
34809 *     Resonance width Gamma in GeV                                     *
34810       DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
34811 *     Mean life time in seconds                                        *
34812       DATA TAUZ / 16*0.D0 /
34813 *     Charge of particles and resonances                               *
34814       DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
34815 *     Baryonic charge                                                  *
34816       DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
34817 *     First number of decay channels used for resonances               *
34818 *     and decaying particles                                           *
34819       DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
34820      &          3*460/
34821 *     Last number of decay channels used for resonances                *
34822 *     and decaying particles                                           *
34823       DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
34824      &          3*460/
34825 *     Weight of decay channel                                          *
34826       DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
34827      & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
34828      & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
34829      & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
34830      & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
34831      & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
34832      & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
34833      & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
34834      & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
34835      & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
34836      & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
34837      & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
34838      & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
34839      & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
34840      & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
34841      & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
34842      & .05D0, .65D0, 9*1.D0 /
34843 *     Particle numbers in decay channel                                *
34844       DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
34845      & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
34846      & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
34847      & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
34848      & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
34849      & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
34850      & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
34851      & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
34852       DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
34853      & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
34854      & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
34855      & 4*33, 32, 3*35,  2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
34856      & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
34857      & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
34858      & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
34859      & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
34860      & 1, 8, 1, 8, 1, 9*0 /
34861       DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
34862      & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
34863      & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
34864      & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
34865      & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
34866      & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
34867 *     Particle  names                                                  *
34868       DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS  ',' PAP  ',' PAN  ',
34869      & 'APN', 'DEO   ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
34870      & 3*'BLANK' /
34871 *     Name of decay channel                                            *
34872       DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
34873      & 'ANNPI0','APPPI0','ANPPI-'/
34874       DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K-  ','K0AK0 ',
34875      & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET  ','&0R0  ','P-R+  ',
34876      & 'P+R-  ','POOM  ',' ETET ','ETSP0 ','R0ET  ',' R0R0 ','R+R-  ',
34877      & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
34878      & 'P+R-R0','R0OM  ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
34879      & 'P+R-OM','OMOM  ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
34880      & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
34881      & 'OMOMOM',
34882      & ' P+PO ','P+POPO','P+P+P-','P+ET  ','P0R+  ','P+R0  ','ETSP+ ',
34883      & 'R+ET  ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
34884      & 'P+R-R+','R+OM  ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
34885      & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
34886      & 'P-PO  ','P-POPO','P-P-P+','P-ET  ','POR-  ','P-R0  ','ETSP- ',
34887      & 'R-ET  ','R-R0  ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
34888       DATA ZKNAM6/'P+R-R-','R-OM  ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
34889      & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
34890      & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO  ','LPI+  ',
34891      & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
34892      & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
34893      & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
34894      & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
34895      & 9*'BLANK'/
34896 *=                                               end*block.zk      *
34897       END
34898
34899 *$ CREATE DT_BLKD43.FOR
34900 *COPY DT_BLKD43
34901 *
34902 *===blkd43=============================================================*
34903 *
34904       BLOCK DATA DT_BLKD43
34905
34906       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34907       SAVE
34908
34909 *
34910 *=== reac =============================================================*
34911 *
34912 *----------------------------------------------------------------------*
34913 *                                                                      *
34914 *     Created on 10 december 1991  by    Alfredo Ferrari & Paola Sala  *
34915 *                                                   Infn - Milan       *
34916 *                                                                      *
34917 *     Last change on 10-dec-91     by    Alfredo Ferrari               *
34918 *                                                                      *
34919 *     This is the original common reac of Hadrin                       *
34920 *                                                                      *
34921 *----------------------------------------------------------------------*
34922 *
34923       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
34924      &                NRK(2,268),NURE(30,2)
34925
34926       DIMENSION
34927      & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
34928      & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
34929      & SPIKP1(315), SPIKPU(278), SPIKPV(372),
34930      & SPIKPW(278), SPIKPX(372), SPIKP4(315),
34931      & SPIKP5(187), SPIKP6(289),
34932      & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
34933      & SPIKP9(143), SPIKP0(169), SPKPV(143),
34934      & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
34935      & SANPEL(84) , SPIKPF(273),
34936      & SPKP15(187), SPKP16(272),
34937      & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
34938      & NURELN(60)
34939 *
34940        DIMENSION NRKLIN(532)
34941        EQUIVALENCE (NRK(1,1), NRKLIN(1))
34942        EQUIVALENCE (   UMO(  1),  UMOPI(1)), (   UMO( 93),  UMOKC(1))
34943        EQUIVALENCE (   UMO(161),   UMOP(1)), (   UMO(200),   UMON(1))
34944        EQUIVALENCE (   UMO(263),  UMOK0(1))
34945        EQUIVALENCE ( PLABF(  1),  PLAPI(1)), ( PLABF( 93),  PLAKC(1))
34946        EQUIVALENCE ( PLABF(161),   PLAP(1)), ( PLABF(200),   PLAN(1))
34947        EQUIVALENCE ( PLABF(263),  PLAK0(1))
34948        EQUIVALENCE (   WK(   1), SPIKP1(1)), (   WK( 316), SPIKPU(1))
34949        EQUIVALENCE (   WK( 594), SPIKPV(1)), (   WK( 966), SPIKPW(1))
34950        EQUIVALENCE (   WK(1244), SPIKPX(1)), (   WK(1616), SPIKP4(1))
34951        EQUIVALENCE (   WK(1931), SPIKP5(1)), (   WK(2118), SPIKP6(1))
34952        EQUIVALENCE (   WK(2407), SKMPEL(1)), (   WK(2509), SPIKP7(1))
34953        EQUIVALENCE (   WK(2798), SKMNEL(1)), (   WK(2866), SPIKP8(1))
34954        EQUIVALENCE (   WK(3053), SPIKP9(1)), (   WK(3196), SPIKP0(1))
34955        EQUIVALENCE (   WK(3365),  SPKPV(1)), (   WK(3508), SAPPEL(1))
34956        EQUIVALENCE (   WK(3613), SPIKPE(1)), (   WK(4012), SAPNEL(1))
34957        EQUIVALENCE (   WK(4096), SPIKPZ(1)), (   WK(4369), SANPEL(1))
34958        EQUIVALENCE (   WK(4453), SPIKPF(1)), (   WK(4726), SPKP15(1))
34959        EQUIVALENCE (   WK(4913), SPKP16(1))
34960        EQUIVALENCE (NRK(1,1), NRKLIN(1))
34961        EQUIVALENCE (NRKLIN(   1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
34962        EQUIVALENCE (NRKLIN( 297),  NRKP(1)), (NRKLIN( 367),  NRKN(1))
34963        EQUIVALENCE (NRKLIN( 483), NRKK0(1))
34964        EQUIVALENCE (NURE(1,1), NURELN(1))
34965 *
34966 **** pi- p data                                                        *
34967 **** pi+ n data                                                        *
34968       DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
34969      & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
34970      & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
34971      & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
34972      & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
34973      & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
34974      & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
34975      & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
34976      & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
34977      & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
34978       DATA PLAKC /
34979      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
34980      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
34981      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
34982      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
34983      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
34984      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
34985      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
34986      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
34987      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
34988      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
34989      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
34990      & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
34991       DATA PLAK0 /
34992      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
34993      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
34994      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
34995      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
34996      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
34997      & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
34998 *                 pp   pn   np   nn                                    *
34999       DATA PLAP /
35000      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35001      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35002      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35003      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35004      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35005      & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
35006 *    app   apn   anp   ann                                             *
35007       DATA PLAN /
35008      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
35009      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35010      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35011      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
35012      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35013      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
35014      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
35015      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
35016      & 3.43D0, 3.75D0, 4.07D0, 4.43D0  /
35017       DATA SIIN / 296*0.D0 /
35018       DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
35019      & 1.557D0,1.615D0,1.6435D0,
35020      & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
35021      & 2.286D0,2.366D0,2.482D0,2.56D0,
35022      & 2.735D0,2.90D0,
35023      &             1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
35024      & 1.496D0,1.527D0,1.557D0,
35025      & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
35026      & 2.071D0,2.159D0,2.286D0,2.366D0,
35027      & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
35028      &             1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
35029      & 1.496D0,1.527D0,1.557D0,
35030      & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
35031      & 2.071D0,2.159D0,2.286D0,2.366D0,
35032      & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
35033      &                   1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
35034      & 1.557D0,1.615D0,1.6435D0,
35035      & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
35036      & 2.286D0,2.366D0,2.482D0,2.56D0,
35037      &  2.735D0, 2.90D0/
35038       DATA UMOKC/ 1.44D0,
35039      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35040      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35041      & 3.1D0,1.44D0,
35042      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35043      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35044      & 3.1D0,1.44D0,
35045      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35046      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35047      & 3.1D0,1.44D0,
35048      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35049      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35050      &  3.1D0/
35051       DATA UMOK0/ 1.44D0,
35052      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35053      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35054      & 3.1D0,1.44D0,
35055      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
35056      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
35057      &  3.1D0/
35058 *                 pp   pn   np   nn                                    *
35059       DATA UMOP/
35060      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35061      & 3.D0,3.1D0,3.2D0,
35062      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35063      & 3.D0,3.1D0,3.2D0,
35064      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35065      & 3.D0,3.1D0,3.2D0/
35066 *    app   apn   anp   ann                                             *
35067       DATA UMON /
35068      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35069      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35070      & 3.D0,3.1D0,3.2D0,
35071      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35072      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35073      & 3.D0,3.1D0,3.2D0,
35074      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
35075      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
35076      &  3.D0,3.1D0,3.2D0/
35077 **** reaction channel state particles                                  *
35078       DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
35079      & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
35080      & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
35081      & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
35082      & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
35083      & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
35084      & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
35085      & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
35086      & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
35087      & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
35088       DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
35089      & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
35090      & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
35091      & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
35092      & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
35093      & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
35094      & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
35095      & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
35096 *                                                                      *
35097 *   k0 p   k0 n   ak0 p   ak/ n                                        *
35098 *                                                                      *
35099       DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
35100      & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13,   22, 13, 21, 23,
35101      & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
35102      & 53, 47, 1, 103, 0, 93, 0/
35103 *   pp  pn   np   nn                                                   *
35104       DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
35105      & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
35106      & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
35107      & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
35108 *     app   apn   anp   ann                                            *
35109       DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
35110      & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
35111      & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
35112      & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
35113      & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
35114      & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
35115      & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
35116 **** channel cross section                                             *
35117       DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
35118      & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
35119      & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
35120      & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
35121      & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
35122      &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
35123      & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
35124      & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
35125      &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
35126      & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
35127      & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
35128      & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
35129      & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
35130      & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
35131      & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
35132      & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
35133      & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
35134      & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
35135      & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
35136      & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
35137 **** pi+ n data                                                        *
35138       DATA SPIKPU/   0.D0, 25.D0, 13.D0,  11.D0, 10.5D0, 14.D0,  20.D0,
35139      & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
35140      & 10.D0, 10.D0, 9.5D0,  9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
35141      & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0,   5.5D0,  4.8D0,
35142      & 4.2D0, 7.5D0, 3.4D0,  2.5D0, 2.5D0, 2.1D0, 1.4D0,   1.D0,   .8D0,
35143      &  .6D0, .46D0,  .3D0, .2D0, .15D0, .13D0, 11*0.D0,  .95D0,  .65D0,
35144      & .48D0, .35D0,  .2D0, .18D0, .17D0, .16D0,  .15D0,   .1D0,  .09D0,
35145      & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0,  .2D0,   .1D0,
35146      & .08D0, .06D0, .045D0,   .03D0, .02D0, .01D0,      .005D0, .003D0,
35147      & 12*0.D0, .3D0, .24D0,   .18D0, .15D0, .13D0,  .12D0, .11D0, .1D0,
35148      & .09D0,  .08D0, .05D0,   .04D0, .03D0,  0.D0, 0.16D0, .7D0, 1.3D0,
35149      & 3.1D0,  4.5D0,  2.D0, 18*0.D0, 3*.0D0,  0.D0, 0.D0, 4.0D0, 11.D0,
35150      & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0,  1.5D0, .9D0, .55D0,
35151      &  .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0,   2.25D0, 3.3D0,
35152      & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
35153      & .64D0,  1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0,  4.4D0,   3.D0, 1.8D0,
35154      &  .9D0, .53D0, .28D0,      10*0.D0, 2*0.D0,  .25D0,  .82D0,
35155      & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0,  5.7D0, 3.9D0, 2.35D0, 1.15D0,
35156      & .69D0, .37D0, 10*0.D0,     7*0.D0,   .0D0, .34D0,  1.5D0, 3.47D0,
35157      & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0,  .3D0,  .15D0, 6*0.D0/
35158 *
35159       DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
35160      & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
35161      & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
35162      & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
35163      & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
35164      & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
35165      & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
35166      & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
35167      & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
35168      & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
35169      & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
35170      & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
35171      & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
35172      & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
35173      & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
35174      & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
35175      & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
35176      & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
35177      & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
35178      & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
35179 **** pi- p data                                                        *
35180       DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
35181      & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
35182      & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
35183      & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
35184      & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
35185      & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
35186      & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
35187      & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
35188      & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
35189      & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
35190      & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
35191      & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
35192      & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
35193      & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
35194      & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
35195      & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
35196      & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
35197      & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
35198      & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
35199 *
35200       DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
35201      & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
35202      & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
35203      & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
35204      & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
35205      & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
35206      & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
35207      & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
35208      & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
35209      & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
35210      & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
35211      & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
35212      & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
35213      & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
35214      & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
35215      & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
35216      & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
35217      & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
35218      & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
35219      & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
35220 **** pi- n data                                                        *
35221       DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
35222      & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
35223      & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
35224      & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
35225      & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
35226      & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
35227      & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
35228      & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
35229      & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
35230      & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
35231      & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
35232      & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
35233      & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
35234      & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
35235      & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
35236      & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
35237      & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
35238      & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
35239      & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
35240      & 3.3D0, 5.4D0, 7.D0 /
35241 **** k+  p data                                                        *
35242       DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
35243      & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
35244      & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
35245      & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
35246      & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
35247      & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35248      & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
35249      & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
35250      & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
35251      & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
35252      & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0,
35253      & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0,
35254      & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
35255 **** k+  n data                                                        *
35256       DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
35257      & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
35258      & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
35259      & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
35260      & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
35261      & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
35262      & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
35263      & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
35264      & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
35265      & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
35266      & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
35267      & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
35268      & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
35269      & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
35270      & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
35271      & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
35272      & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
35273      & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
35274      & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
35275 **** k-  p data                                                        *
35276       DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
35277      &     7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
35278      &    0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
35279      &    .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
35280      &    0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
35281      &    .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
35282      &    0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
35283      &    .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
35284      &    0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
35285      &    .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
35286      &    0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
35287      &    .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
35288       DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
35289      & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
35290      & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
35291      & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
35292      & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,  3*0.D0, 1.0D0, 3.03D0,
35293      & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
35294      & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
35295      & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
35296      & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
35297      & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
35298      & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
35299      & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
35300      & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
35301      & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
35302      & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
35303      & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
35304      & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
35305      & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
35306      & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
35307      & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
35308      & 10*0.D0/
35309 ***** k- n data                                                        *
35310       DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
35311      &        3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
35312      &        0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
35313      &        1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
35314      &        0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
35315      &        .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
35316      &        0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
35317      &       .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
35318       DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
35319      &  14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
35320      &  1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
35321      &  3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
35322      &  1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
35323      &  3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
35324      &  1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
35325      &  7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
35326      &  .39D0, .22D0, .07D0, 0.D0,
35327      &  6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
35328      &  4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
35329      &  10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
35330      &  13*0.D0, .1D0, .3D0, .7D0, 1.D0,
35331      &  13*0.D0, .1D0, .3D0, .7D0, 1.D0,
35332      &  9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
35333      &  5.10D0, 5.44D0, 5.3D0,
35334      &  4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
35335 *****  p p data                                                        *
35336       DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35337      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35338      &              0.D0, 3.6D0, 1.7D0, 10*0.D0,
35339      &              .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
35340      &              11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
35341      &              .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
35342      &              2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
35343      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35344      &              16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
35345      &              10*0.D0, 4.3D0, 7.6D0, 9.D0,
35346      &              10*0.D0, 1.7D0, 2.6D0, 3.D0,
35347      &              6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
35348      &              6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
35349      &              1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
35350      &              10*0.D0, 1.9D0, 4.1D0, 5.2D0/
35351 *****  p n data                                                        *
35352       DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35353      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35354      &              0.D0, 1.8D0, .2D0,  12*0.D0,
35355      &              3.2D0, 6.05D0, 9.9D0, 5.1D0,
35356      &              3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
35357      &              2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
35358      &              3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
35359      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35360      &              16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
35361      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
35362      &              16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
35363      &              10*0.D0, .7D0, 5.1D0, 8.D0,
35364      &              10*0.D0, .7D0, 5.1D0, 8.D0,
35365      &              10*.0D0, .3D0, 2.8D0, 4.7D0,
35366      &              10*.0D0, .3D0, 2.8D0, 4.7D0,
35367      &              7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
35368      &              7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
35369      &              5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
35370 *   nn - data                                                          *
35371 *                                                                      *
35372       DATA SPKPV/  0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
35373      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
35374      &              0.D0, 3.6D0, 1.7D0, 12*0.D0,
35375      &              8.7D0, 17.7D0, 18.8D0, 15.9D0,
35376      &              11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
35377      &              .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
35378      &              2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
35379      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
35380      &              11.D0, 5.5D0, 3.5D0,
35381      &              10*0.D0, 4.3D0, 7.6D0, 9.D0,
35382      &              10*0.D0, 1.7D0, 2.6D0, 3.D0,
35383      &              6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
35384      &              6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
35385      &              1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
35386      &              10*0.D0, 1.9D0, 4.1D0, 5.2D0/
35387 ****************   ap - p - data                                       *
35388       DATA SAPPEL/ 0.D0,  176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
35389      &  50.D0,  50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
35390      &  25.D0,  22.D0, 21.D0, 20.D0, 18.D0, 17.D0,  11*0.D0,
35391      &  .05D0,  .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
35392      &  0.D0,  1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
35393      &  .1D0,  .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
35394      &  0.D0,  55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
35395      &  10.D0,  7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
35396      &  1.55D0,  1.3D0, .95D0, .75D0,
35397      &  0.D0,  3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
35398      &  .25D0,  .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35399      & .01D0,  .008D0, .006D0, .005D0/
35400       DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35401      & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35402      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
35403      & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
35404      & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
35405      & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
35406      & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
35407      & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
35408      & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
35409      & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0,
35410      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35411      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35412      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
35413      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
35414      & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
35415      & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
35416      & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
35417      & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
35418      & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
35419      & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
35420 ****************   ap - n - data                                       *
35421       DATA SAPNEL/
35422      & 0.D0,  176.D0, 160.D0, 105.D0, 75.D0,  68.D0, 65.D0,
35423      & 50.D0, 50.D0,  43.D0,  42.D0,  40.5D0, 35.D0, 30.D0,  28.D0,
35424      & 25.D0, 22.D0,  21.D0,  20.D0,  18.D0,  17.D0, 11*0.D0,
35425      & .05D0, .15D0, .18D0,  .2D0,    .2D0,  .3D0,  .4D0,   .6D0,  .7D0,
35426      & .85D0,  0.D0,  1.D0,  .9D0,    .46D0, .3D0,  .23D0, .18D0, .16D0,
35427      & .14D0,  .1D0, .08D0, .05D0,    .02D0, .015D0, 4*.011D0, 3*.005D0,
35428      & 0.D0,  3.3D0,  3.D0, 1.5D0,     1.D0, .7D0,  .4D0,  .35D0, .4D0,
35429      & .25D0, .18D0, .08D0, .04D0,    .03D0, .023D0, .016D0, .014D0,
35430      & .01D0, .008D0, .006D0, .005D0 /
35431        DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35432      &  84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35433      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
35434      & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35435      & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
35436      & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
35437      & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
35438      & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35439      & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35440      & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35441      & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
35442      & 4.9D0, 8.5D0,  15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
35443      & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
35444      & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
35445 *                                                                      *
35446 *                                                                      *
35447 ****************   an - p - data                                       *
35448 *                                                                      *
35449       DATA SANPEL/
35450      & 0.D0,  176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
35451      & 50.D0, 43.D0,  42.D0,  40.5D0, 35.D0, 30.D0, 28.D0,
35452      & 25.D0, 22.D0,  21.D0,  20.D0,  18.D0, 17.D0, 11*0.D0, .05D0,
35453      & .15D0, .18D0,   .2D0,   .2D0,   .3D0,  .4D0, .6D0,   .7D0, .85D0,
35454      & 0.D0,   1.D0,   .9D0,  .46D0,  .3D0,  .23D0, .18D0, .16D0, .14D0,
35455      & .1D0,  .08D0,  .05D0,  .02D0, .015D0, 4*.011D0, 3*.005D0,
35456      & 0.D0,  3.3D0,  3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
35457      & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
35458      & .01D0, .008D0, .006D0, .005D0 /
35459       DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
35460      & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
35461      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
35462      & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35463      & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
35464      & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
35465      & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
35466      & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
35467      & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35468      & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
35469      & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
35470      & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
35471      & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
35472      & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
35473 ****  ko - n - data                                                    *
35474       DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
35475      &      6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
35476      &      0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
35477      &    3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
35478      &     1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35479      &    3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
35480      &     1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
35481      &    4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
35482      &     1.4D0, 1.2D0, 1.05D0, .9D0, .66D0,  .5D0,
35483      &    7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
35484      &   11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
35485      &    4.85D0, 4.9D0,
35486      &   10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
35487      &    6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
35488      &    2.85D0, 2.35D0, 2.01D0, 1.8D0,
35489      &   12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
35490      &   12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0  /
35491 **** ako - p - data                                                    *
35492       DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
35493      & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
35494      & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
35495      & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
35496      & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
35497      & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
35498      & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
35499      & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
35500      & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
35501      & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
35502      & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
35503      & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
35504      & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
35505      & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
35506      & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
35507      & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
35508      & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
35509      & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
35510      & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
35511      & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
35512      & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
35513       DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
35514      & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
35515 *=                                               end*block.blkdt3      *
35516       END
35517
35518 *$ CREATE DT_QEL_POL.FOR
35519 *COPY DT_QEL_POL
35520 *
35521 *===qel_pol============================================================*
35522 *
35523       SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
35524
35525       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35526       SAVE
35527
35528       CALL DT_MASS_INI
35529       CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
35530
35531       RETURN
35532       END
35533
35534 *$ CREATE DT_GEN_QEL.FOR
35535 *COPY DT_GEN_QEL
35536 C==================================================================
35537 C   Generation of  a Quasi-Elastic neutrino scattering
35538 C==================================================================
35539 *
35540 *===gen_qel============================================================*
35541 *
35542       SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
35543
35544 C...Generate a quasi-elastic   neutrino/antineutrino
35545 C.  Interaction on a nuclear target
35546 C.  INPUT  : LTYP = neutrino type (1,...,6)
35547 C.           ENU (GeV) = neutrino energy
35548 C----------------------------------------------------
35549
35550       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35551       SAVE
35552
35553       PARAMETER ( LINP = 10 ,
35554      &            LOUT = 6 ,
35555      &            LDAT = 9 )
35556       PARAMETER (MAXLND=4000)
35557       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
35558 * nuclear potential
35559       LOGICAL LFERMI
35560       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
35561      &                EBINDP(2),EBINDN(2),EPOT(2,210),
35562      &                ETACOU(2),ICOUL,LFERMI
35563 * steering flags for qel neutrino scattering modules
35564       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
35565 **sr - removed (not needed)
35566 C     COMMON /CBAD/  LBAD, NBAD
35567 C     COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
35568 **
35569
35570       DIMENSION PI(3),PO(3)
35571 CJR+
35572       DATA ININU/0/
35573 CJR-
35574 C     REAL*8 DBETA(3)
35575 C     REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
35576       DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
35577       DATA AMN  /0.93827231D0, 0.93956563D0/
35578       DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
35579       DATA INIPRI/0/
35580
35581 C     DATA PFERMI/0.22D0/
35582 CGB+...Binding Energy
35583       DATA EBIND/0.008D0/
35584 CGB-...
35585
35586       ININU=ININU+1
35587       IF(ININU.EQ.1)NDSIG=0
35588       LBAD = 0
35589       enu0=enu
35590 c      write(*,*) enu0
35591 C...Lepton mass
35592       AML = AML0(LTYP)       !  massa leptoni
35593       AML2 = AML**2          !  massa leptoni **2
35594 C...Particle labels (LUND)
35595       N = 5
35596       K(1,1) = 21
35597       K(2,1) = 21
35598       K(3,1) = 21
35599       K(3,3) = 1
35600       K(4,1) = 1
35601       K(4,3) = 1
35602       K(5,1) = 1
35603       K(5,3) = 2
35604       K0 = (LTYP-1)/2          !  2
35605       K1 = LTYP/2              !  2
35606       KA = 12 + 2*K0           !  16
35607       IS = -1 + 2*LTYP - 4*K1  !  -1 +10 -8 = 1
35608       K(1,2) = IS*KA
35609       K(4,2) = IS*(KA-1)
35610       K(3,2) = IS*24
35611       LNU = 2 - LTYP + 2*K1    !  2 - 5 + 2 = - 1
35612       IF (LNU .EQ. 2)  THEN
35613         K(2,2) = 2212
35614         K(5,2) = 2112
35615         AMI = AMN(1)
35616         AMF = AMN(2)
35617 CJR+
35618         PFERMI=PFERMN(2)
35619 CJR-
35620       ELSE
35621         K(2,2) = 2112
35622         K(5,2) = 2212
35623         AMI = AMN(2)
35624         AMF = AMN(1)
35625 CJR+
35626         PFERMI=PFERMP(2)
35627 CJR-
35628       ENDIF
35629       AMI2 = AMI**2
35630       AMF2 = AMF**2
35631
35632       DO IGB=1,5
35633         P(3,IGB) = 0.
35634         P(4,IGB) = 0.
35635         P(5,IGB) = 0.
35636       END DO
35637
35638       NTRY = 0
35639 CGB+...
35640       EFMAX  = SQRT(PFERMI**2 + AMI2) -AMI             ! max. Fermi Energy
35641       ENWELL = EFMAX + EBIND ! depth of nuclear potential well
35642 CGB-...
35643
35644   100 CONTINUE
35645
35646 C...4-momentum initial lepton
35647       P(1,5) = 0.     ! massa
35648       P(1,4) = ENU0    ! energia
35649       P(1,1) = 0.     ! px
35650       P(1,2) = 0.     ! py
35651       P(1,3) = ENU0    ! pz
35652
35653 C     PF = PFERMI*PYR(0)**(1./3.)
35654 c       write(23,*) PYR(0)
35655 c      write(*,*) 'Pfermi=',PF
35656 c      PF = 0.
35657       NTRY=NTRY+1
35658 C     IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
35659       IF (NTRY .GT. 500)  THEN
35660         LBAD = 1
35661         WRITE (LOUT,1001)  NBAD, ENU
35662         RETURN
35663       ENDIF
35664 C     CT = -1. + 2.*PYR(0)
35665 c      CT = -1.
35666 C     ST =  SQRT(1.-CT*CT)
35667 C     F = 2.*3.1415926*PYR(0)
35668 c      F = 0.
35669
35670 C     P(2,4) = SQRT(PF*PF + MI2) - EBIND  ! energia
35671 C     P(2,1) = PF*ST*COS(F)               ! px
35672 C     P(2,2) = PF*ST*SIN(F)               ! py
35673 C     P(2,3) = PF*CT                      ! pz
35674 C     P(2,5) = SQRT(P(2,4)**2-PF*PF)      ! massa
35675        P(2,1) = P21
35676        P(2,2) = P22
35677        P(2,3) = P23
35678        P(2,4) = P24
35679        P(2,5) = P25
35680       beta1=-p(2,1)/p(2,4)
35681       beta2=-p(2,2)/p(2,4)
35682       beta3=-p(2,3)/p(2,4)
35683       N=2
35684 C      WRITE(6,*)' before transforming into target rest frame'
35685       CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
35686 C      print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
35687       N=5
35688
35689       phi11=atan(p(1,2)/p(1,3))
35690       pi(1)=p(1,1)
35691       pi(2)=p(1,2)
35692       pi(3)=p(1,3)
35693
35694       CALL DT_TESTROT(PI,Po,PHI11,1)
35695       DO ll=1,3
35696         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35697       END DO
35698 c        WRITE(*,*) po
35699       p(1,1)=po(1)
35700       p(1,2)=po(2)
35701       p(1,3)=po(3)
35702       phi12=atan(p(1,1)/p(1,3))
35703
35704       pi(1)=p(1,1)
35705       pi(2)=p(1,2)
35706       pi(3)=p(1,3)
35707       CALL DT_TESTROT(Pi,Po,PHI12,2)
35708       DO ll=1,3
35709         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35710       END DO
35711 c        WRITE(*,*) po
35712       p(1,1)=po(1)
35713       p(1,2)=po(2)
35714       p(1,3)=po(3)
35715
35716       enu=p(1,4)
35717
35718 C...Kinematical limits in Q**2
35719 c      S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) !            ????
35720       S = P(2,5)**2 + 2.*ENU*P(2,5)
35721       SQS = SQRT(S)                          ! E centro massa
35722       IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
35723       ELF = (S-AMF2+AML2)/(2.*SQS)           ! energia leptone finale p
35724       PSTAR = (S-P(2,5)**2)/(2.*SQS)       ! p* neutrino nel c.m.
35725       PLF = SQRT(ELF**2-AML2)               ! 3-momento leptone finale
35726       Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)    ! + o -
35727       Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)    ! according con cos(theta)
35728       IF (Q2MIN .LT. 0.)   Q2MIN = 0.      ! ??? non fisico
35729
35730 C...Generate Q**2
35731       DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
35732   200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
35733       DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
35734       IF (DSIG .LT.  DSIGMAX*PYR(0)) GOTO 200
35735       CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
35736       NDSIG=NDSIG+1
35737 C     WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
35738 C    &Q2,Q2min,Q2MAX,DSIGEV
35739
35740 C...c.m. frame. Neutrino along z axis
35741       DETOT = (P(1,4)) + (P(2,4)) ! e totale
35742       DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
35743       DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
35744       DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
35745 c      WRITE(*,*)
35746 c      WRITE(*,*)
35747 C      WRITE(*,*) 'Input values laboratory frame'
35748       N=2
35749
35750       CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
35751
35752       N=5
35753 c      STHETA = ULANGL(P(1,3),P(1,1))
35754 c      write(*,*) 'stheta' ,stheta
35755 c      stheta=0.
35756 c      CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
35757 c      WRITE(*,*)
35758 c      WRITE(*,*)
35759 C      WRITE(*,*) 'Output values cm frame'
35760 C...Kinematic in c.m. frame
35761       CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
35762       STSTAR = SQRT(1.-CTSTAR**2)
35763       PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
35764       P(4,5) = AML                  ! massa leptone
35765       P(4,4) = ELF                 ! e leptone
35766       P(4,3) = PLF*CTSTAR          ! px
35767       P(4,1) = PLF*STSTAR*COS(PHI) ! py
35768       P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
35769
35770       P(5,5) = AMF                  ! barione
35771       P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
35772       P(5,3) = -P(4,3)             ! px
35773       P(5,1) = -P(4,1)             ! py
35774       P(5,2) = -P(4,2)             ! pz
35775
35776       P(3,5) = -Q2
35777       P(3,1) = P(1,1)-P(4,1)
35778       P(3,2) = P(1,2)-P(4,2)
35779       P(3,3) = P(1,3)-P(4,3)
35780       P(3,4) = P(1,4)-P(4,4)
35781
35782 C...Transform back to laboratory  frame
35783 C      WRITE(*,*) 'before going back to nucl rest frame'
35784 c      CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
35785       N=5
35786
35787       CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
35788
35789 C      WRITE(*,*) 'Now back in nucl rest frame'
35790       IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
35791
35792 c********************************************
35793
35794       DO kw=1,5
35795         pi(1)=p(kw,1)
35796         pi(2)=p(kw,2)
35797         pi(3)=p(kw,3)
35798         CALL DT_TESTROT(Pi,Po,PHI12,3)
35799         DO ll=1,3
35800           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35801         END DO
35802         p(kw,1)=po(1)
35803         p(kw,2)=po(2)
35804         p(kw,3)=po(3)
35805       END DO
35806 c********************************************
35807
35808       DO kw=1,5
35809         pi(1)=p(kw,1)
35810         pi(2)=p(kw,2)
35811         pi(3)=p(kw,3)
35812         CALL DT_TESTROT(Pi,Po,PHI11,4)
35813         DO ll=1,3
35814           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35815         END DO
35816         p(kw,1)=po(1)
35817         p(kw,2)=po(2)
35818         p(kw,3)=po(3)
35819       END DO
35820
35821 c********************************************
35822
35823 C      WRITE(*,*) 'Now back in lab frame'
35824
35825       CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
35826
35827 CGB+...
35828 C...test (on final momentum of nucleon) if Fermi-blocking
35829 C...is operating
35830       ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
35831      &  - P(5,5)
35832       IF (ENUCL.LT. EFMAX) THEN
35833         IF(INIPRI.LT.10)THEN
35834           INIPRI=INIPRI+1
35835 C         WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
35836 C...the interaction is not possible due to Pauli-Blocking and
35837 C...it must be resampled
35838         ENDIF
35839         GOTO 100
35840       ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
35841         IF(INIPRI.LT.10)THEN
35842           INIPRI=INIPRI+1
35843 C     WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
35844         ENDIF
35845 C                      Reject (J:R) here all these events
35846 C                      are otherwise rejected in dpmjet
35847         GOTO 100
35848 C...the interaction is possible, but the nucleon remains inside
35849 C...the nucleus. The nucleus is therefore left excited.
35850 C...We treat this case as a nucleon with 0 kinetic energy.
35851 C       P(5,5) = AMF
35852 C       P(5,4) = AMF
35853 C       P(5,1) = 0.
35854 C       P(5,2) = 0.
35855 C       P(5,3) = 0.
35856       ELSE IF (ENUCL.GE.ENWELL) THEN
35857 C     WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
35858 C...the interaction is possible, the nucleon can exit the nucleus
35859 C...but the nuclear well depth must be subtracted. The nucleus could be
35860 C...left in an excited state.
35861         Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
35862 C       P(5,4) = ENUCL-ENWELL + AMF
35863         Pnucl = SQRT(P(5,4)**2-AMF**2)
35864 C...The 3-momentum is scaled assuming that the direction remains
35865 C...unaffected
35866         P(5,1) = P(5,1) * Pnucl/Pstart
35867         P(5,2) = P(5,2) * Pnucl/Pstart
35868         P(5,3) = P(5,3) * Pnucl/Pstart
35869 C     WRITE(6,*)' qel new P(5,4) ',P(5,4)
35870       ENDIF
35871 CGB-...
35872       DSIGSU=DSIGSU+DSIGEV
35873
35874          GA=P(4,4)/P(4,5)
35875          BGX=P(4,1)/P(4,5)
35876          BGY=P(4,2)/P(4,5)
35877          BGZ=P(4,3)/P(4,5)
35878 *
35879          DBETB(1)=BGX/GA
35880          DBETB(2)=BGY/GA
35881          DBETB(3)=BGZ/GA
35882          IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
35883
35884             CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
35885
35886          ENDIF
35887 c
35888 C      PRINT*,' FINE   EVENTO '
35889       enu=enu0
35890       RETURN
35891
35892  1001 FORMAT(2X, 'DT_GEN_QEL   : event rejected ', I5,  G10.3)
35893       END
35894
35895 *$ CREATE DT_MASS_INI.FOR
35896 *COPY DT_MASS_INI
35897 C====================================================================
35898 C.  Masses
35899 C====================================================================
35900 *
35901 *===mass_ini===========================================================*
35902 *
35903       SUBROUTINE DT_MASS_INI
35904 C...Initialize  the kinematics for the quasi-elastic cross section
35905
35906       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35907       SAVE
35908
35909 * particle masses used in qel neutrino scattering modules
35910       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
35911      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
35912      &                EMPROTSQ,EMNEUTSQ,EMNSQ
35913
35914       EML(1) = 0.51100D-03   ! e-
35915       EML(2) = EML(1)        ! e+
35916       EML(3) = 0.105659D0      ! mu-
35917       EML(4) = EML(3)        ! mu+
35918       EML(5) = 1.7777D0        ! tau-
35919       EML(6) = EML(5)        ! tau+
35920       EMPROT = 0.93827231D0    ! p
35921       EMNEUT = 0.93956563D0    ! n
35922       EMPROTSQ = EMPROT**2
35923       EMNEUTSQ = EMNEUT**2
35924       EMN = (EMPROT + EMNEUT)/2.
35925       EMNSQ = EMN**2
35926       DO J=1,3
35927         J0 = 2*(J-1)
35928         EMN1(J0+1) = EMNEUT
35929         EMN1(J0+2) = EMPROT
35930         EMN2(J0+1) = EMPROT
35931         EMN2(J0+2) = EMNEUT
35932       ENDDO
35933       DO J=1,6
35934         EMLSQ(J) = EML(J)**2
35935         ETQE(J)  = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
35936       ENDDO
35937       RETURN
35938       END
35939
35940 *$ CREATE DT_DSQEL_Q2.FOR
35941 *COPY DT_DSQEL_Q2
35942 *
35943 *===dsqel_q2===========================================================*
35944 *
35945       DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
35946
35947 C...differential cross section for  Quasi-Elastic scattering
35948 C.       nu + N -> l + N'
35949 C.  From Llewellin Smith  Phys.Rep.  3C, 261, (1971).
35950 C.
35951 C.  INPUT :  JTYP = 1,...,6    nu_e, ...., nubar_tau
35952 C.           ENU (GeV) =  Neutrino energy
35953 C.           Q2  (GeV**2) =  (Transfer momentum)**2
35954 C.
35955 C.  OUTPUT : DSQEL_Q2  = differential  cross section :
35956 C.                       dsigma/dq**2  (10**-38 cm+2/GeV**2)
35957 C------------------------------------------------------------------
35958
35959       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35960       SAVE
35961
35962 * particle masses used in qel neutrino scattering modules
35963       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
35964      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
35965      &                EMPROTSQ,EMNEUTSQ,EMNSQ
35966 **sr - removed (not needed)
35967 C     COMMON /CAXIAL/ FA0, AXIAL2
35968 **
35969
35970       DIMENSION SS(6)
35971       DATA C0 /0.17590D0 /  ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
35972       DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
35973       DATA AXIAL2 /1.03D0/  ! to be checked
35974
35975       FA0=-1.253D0
35976       CSI = 3.71D0                   !  ???
35977       GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2   ! G_e(q**2)
35978       GVM = (1.D0+CSI)*GVE           ! G_m (q**2)
35979       X = Q2/(EMN*EMN)     ! emn=massa barione
35980       XA = X/4.D0
35981       FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
35982       FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
35983       FA = FA0/(1.D0 + Q2/AXIAL2)**2
35984       FFA = FA*FA
35985       FFV1 = FV1*FV1
35986       FFV2 = FV2*FV2
35987       RM = EMLSQ(JTYP)/(EMN*EMN)            ! emlsq(jtyp)
35988       A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
35989       A2 = -RM * ((FV1 + FV2)**2 +  FFA)
35990       AA = (XA+0.25D0*RM)*(A1 + A2)
35991       BB = -X*FA*(FV1 + FV2)
35992       CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
35993       SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
35994       DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU)  !
35995       IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
35996
35997       RETURN
35998       END
35999
36000 *$ CREATE DT_PREPOLA.FOR
36001 *COPY DT_PREPOLA
36002 *
36003 *===prepola============================================================*
36004 *
36005       SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
36006
36007       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36008       SAVE
36009 c
36010 c By G. Battistoni and E. Scapparone (sept. 1997)
36011 c According to:
36012 c     Albright & Jarlskog, Nucl Phys B84 (1975) 467
36013 c
36014 c
36015       PARAMETER (MAXLND=4000)
36016       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
36017       COMMON /QNPOL/ POLARX(4),PMODUL
36018 * particle masses used in qel neutrino scattering modules
36019       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
36020      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
36021      &                EMPROTSQ,EMNEUTSQ,EMNSQ
36022 * steering flags for qel neutrino scattering modules
36023       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
36024 **sr - removed (not needed)
36025 C     COMMON /CAXIAL/ FA0, AXIAL2
36026 C     COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
36027 C    &        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
36028 **
36029       REAL*8 POL(4,4),BB2(3)
36030       DIMENSION SS(6)
36031 C     DATA C0 /0.17590D0 /  ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
36032       DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
36033 **sr uncommented since common block CAXIAL is now commented
36034       DATA AXIAL2 /1.03D0/  ! to be checked
36035 **
36036
36037       RML=P(4,5)
36038       RMM=0.93960D+00
36039       FM2 = RMM**2
36040       MPI = 0.135D+00
36041       OLDQ2=Q2
36042       FA0=-1.253D+00
36043       CSI = 3.71D+00                      !
36044       GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2   ! G_e(q**2)
36045       GVM = (1.D0+CSI)*GVE           ! G_m (q**2)
36046       X = Q2/(EMN*EMN)     ! emn=massa barione
36047       XA = X/4.D0
36048       FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
36049       FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
36050       FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
36051       FFA = FA*FA
36052       FFV1 = FV1*FV1
36053       FFV2 = FV2*FV2
36054       FP=2.D0*FA*RMM/(MPI**2 + Q2)
36055       RM = EMLSQ(JTYP)/(EMN*EMN)            ! emlsq(jtyp)
36056       A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
36057       A2 = -RM * ((FV1 + FV2)**2 +  FFA)
36058       AA = (XA+0.25D+00*RM)*(A1 + A2)
36059       BB = -X*FA*(FV1 + FV2)
36060       CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
36061       SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
36062
36063       OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2   )  ! articolo di ll...-smith
36064       OMEGA2=4.D+00*CC
36065       OMEGA3=2.D+00*FA*(FV1+FV2)
36066       OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
36067      1     (Q2/FM2))*FP**2)
36068       OMEGA5=OMEGA2
36069       OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
36070       WW1=2.D+00*OMEGA1*EMN**2
36071       WW2=2.D+00*OMEGA2*EMN**2
36072       WW3=2.D+00*OMEGA3*EMN**2
36073       WW4=2.D+00*OMEGA4*EMN**2
36074       WW5=2.D+00*OMEGA5*EMN**2
36075
36076       DO I=1,3
36077         BB2(I)=-P(4,I)/P(4,4)
36078       END DO
36079 c      WRITE(*,*)
36080 c      WRITE(*,*)
36081 c      WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
36082       N=5
36083       CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
36084 * NOW PARTICLES ARE IN THE SCATTERED LEPTON  REST FRAME
36085 c      WRITE(*,*)
36086 c      WRITE(*,*)
36087 c      WRITE(*,*) 'Prepola: now in lepton rest frame'
36088       EE=ENU
36089       QM2=Q2+RML**2
36090       U=Q2/(2.*RMM)
36091       FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
36092      +     (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
36093      +     ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
36094
36095       FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
36096      +     - ((RML**2)/FM2)*WW4                        !<=FM2 inv di RMM!!
36097
36098       FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
36099
36100       DO I=1,3
36101         POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
36102         POLARX(I)=POL(4,I)
36103       END DO
36104
36105       PMODUL=0.D0
36106       DO I=1,3
36107         PMODUL=PMODUL+POL(4,I)**2
36108       END DO
36109
36110       IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
36111          IF(NEUDEC.EQ.1) THEN
36112             CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
36113      +        ETL,PXL,PYL,PZL,
36114      +        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36115 c
36116 c     Tau has decayed in muon
36117 c
36118          ENDIF
36119          IF(NEUDEC.EQ.2) THEN
36120             CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
36121      +        ETL,PXL,PYL,PZL,
36122      +        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36123 c
36124 c     Tau has decayed in electron
36125 c
36126          ENDIF
36127          K(4,1)=15
36128          K(4,4) = 6
36129          K(4,5) = 8
36130          N=N+3
36131 c
36132 c     fill common for muon(electron)
36133 c
36134          P(6,1)=PXL
36135          P(6,2)=PYL
36136          P(6,3)=PZL
36137          P(6,4)=ETL
36138          K(6,1)=1
36139          IF(JTYP.EQ.5) THEN
36140             IF(NEUDEC.EQ.1) THEN
36141                P(6,5)=EML(JTYP-2)
36142                K(6,2)=13
36143             ELSEIF(NEUDEC.EQ.2) THEN
36144                P(6,5)=EML(JTYP-4)
36145                K(6,2)=11
36146             ENDIF
36147          ELSEIF(JTYP.EQ.6) THEN
36148             IF(NEUDEC.EQ.1) THEN
36149                K(6,2)=-13
36150             ELSEIF(NEUDEC.EQ.2) THEN
36151                K(6,2)=-11
36152             ENDIF
36153          END IF
36154          K(6,3)=4
36155          K(6,4)=0
36156          K(6,5)=0
36157 c
36158 c     fill common for tau_(anti)neutrino
36159 c
36160          P(7,1)=PXB
36161          P(7,2)=PYB
36162          P(7,3)=PZB
36163          P(7,4)=ETB
36164          P(7,5)=0.
36165          K(7,1)=1
36166          IF(JTYP.EQ.5) THEN
36167             K(7,2)=16
36168          ELSEIF(JTYP.EQ.6) THEN
36169             K(7,2)=-16
36170          END IF
36171          K(7,3)=4
36172          K(7,4)=0
36173          K(7,5)=0
36174 c
36175 c     Fill common for muon(electron)_(anti)neutrino
36176 c
36177          P(8,1)=PXN
36178          P(8,2)=PYN
36179          P(8,3)=PZN
36180          P(8,4)=ETN
36181          P(8,5)=0.
36182          K(8,1)=1
36183          IF(JTYP.EQ.5) THEN
36184             IF(NEUDEC.EQ.1) THEN
36185                K(8,2)=-14
36186             ELSEIF(NEUDEC.EQ.2) THEN
36187                K(8,2)=-12
36188             ENDIF
36189          ELSEIF(JTYP.EQ.6) THEN
36190             IF(NEUDEC.EQ.1) THEN
36191                K(8,2)=14
36192             ELSEIF(NEUDEC.EQ.2) THEN
36193                K(8,2)=12
36194             ENDIF
36195          END IF
36196          K(8,3)=4
36197          K(8,4)=0
36198          K(8,5)=0
36199       ENDIF
36200 c      WRITE(*,*)
36201 c      WRITE(*,*)
36202
36203 c      IF(PMODUL.GE.1.D+00) THEN
36204 c        WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
36205 c        write(*,*) pmodul
36206 c        DO I=1,3
36207 c          POL(4,I)=POL(4,I)/PMODUL
36208 c          POLARX(I)=POL(4,I)
36209 c        END DO
36210 c        PMODUL=0.
36211 c        DO I=1,3
36212 c          PMODUL=PMODUL+POL(4,I)**2
36213 c        END DO
36214 c        WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
36215 c
36216 c      ENDIF
36217
36218 c      WRITE(*,*) 'PMODUL = ',PMODUL
36219
36220 c      WRITE(*,*)
36221 c      WRITE(*,*)
36222 c      WRITE(*,*) 'prepola: Now back to nucl rest frame'
36223       CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
36224
36225       XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
36226       YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
36227       ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
36228       DO NDC =6,8
36229          V(NDC,1) = XDC
36230          V(NDC,2) = YDC
36231          V(NDC,3) = ZDC
36232       END DO
36233
36234       RETURN
36235       END
36236
36237 *$ CREATE DT_TESTROT.FOR
36238 *COPY DT_TESTROT
36239 *
36240 *===testrot============================================================*
36241 *
36242       SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
36243
36244       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36245       SAVE
36246
36247       DIMENSION ROT(3,3),PI(3),PO(3)
36248
36249       IF (MODE.EQ.1) THEN
36250          ROT(1,1) = 1.D0
36251          ROT(1,2) = 0.D0
36252          ROT(1,3) = 0.D0
36253          ROT(2,1) = 0.D0
36254          ROT(2,2) = COS(PHI)
36255          ROT(2,3) = -SIN(PHI)
36256          ROT(3,1) = 0.D0
36257          ROT(3,2) = SIN(PHI)
36258          ROT(3,3) = COS(PHI)
36259       ELSEIF (MODE.EQ.2) THEN
36260          ROT(1,1) = 0.D0
36261          ROT(1,2) = 1.D0
36262          ROT(1,3) = 0.D0
36263          ROT(2,1) = COS(PHI)
36264          ROT(2,2) = 0.D0
36265          ROT(2,3) = -SIN(PHI)
36266          ROT(3,1) = SIN(PHI)
36267          ROT(3,2) = 0.D0
36268          ROT(3,3) = COS(PHI)
36269       ELSEIF (MODE.EQ.3) THEN
36270          ROT(1,1) = 0.D0
36271          ROT(2,1) = 1.D0
36272          ROT(3,1) = 0.D0
36273          ROT(1,2) = COS(PHI)
36274          ROT(2,2) = 0.D0
36275          ROT(3,2) = -SIN(PHI)
36276          ROT(1,3) = SIN(PHI)
36277          ROT(2,3) = 0.D0
36278          ROT(3,3) = COS(PHI)
36279       ELSEIF (MODE.EQ.4) THEN
36280          ROT(1,1) = 1.D0
36281          ROT(2,1) = 0.D0
36282          ROT(3,1) = 0.D0
36283          ROT(1,2) = 0.D0
36284          ROT(2,2) = COS(PHI)
36285          ROT(3,2) = -SIN(PHI)
36286          ROT(1,3) = 0.D0
36287          ROT(2,3) = SIN(PHI)
36288          ROT(3,3) = COS(PHI)
36289       ELSE
36290          STOP ' TESTROT: mode not supported!'
36291       ENDIF
36292       DO 1 J=1,3
36293         PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
36294     1 CONTINUE
36295
36296       RETURN
36297       END
36298
36299 *$ CREATE DT_LEPDCYP.FOR
36300 *COPY DT_LEPDCYP
36301 *
36302 *===lepdcyp============================================================*
36303 *
36304       SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
36305      &                      ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
36306 C
36307 C-----------------------------------------------------------------
36308 C
36309 C   Author   :- G. Battistoni         10-NOV-1995
36310 C
36311 C=================================================================
36312 C
36313 C   Purpose   : performs decay of polarized lepton in
36314 C               its rest frame: a => b + l + anti-nu
36315 C               (Example: mu- => nu-mu + e- + anti-nu-e)
36316 C               Polarization is assumed along Z-axis
36317 C               WARNING:
36318 C               1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
36319 C                  OF NEGLIGIBLE MASS
36320 C               2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
36321 C                  IN THIS VERSION
36322 C
36323 C   Method    : modifies phase space distribution obtained
36324 C               by routine EXPLOD using a rejection against the
36325 C               matrix element for unpolarized lepton decay
36326 C
36327 C   Inputs    : Mass of a :  AMA
36328 C               Mass of l :  AML
36329 C               Polar. of a: POL
36330 C               (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
36331 C                                                 POL = -1)
36332 C
36333 C   Outputs   : kinematic variables in the rest frame of decaying lepton
36334 C               ETL,PXL,PYL,PZL 4-moment of l
36335 C               ETB,PXB,PYB,PZB 4-moment of b
36336 C               ETN,PXN,PYN,PZN 4-moment of anti-nu
36337 C
36338 C============================================================
36339 C +
36340 C Declarations.
36341 C -
36342       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36343       SAVE
36344
36345       PARAMETER ( LINP = 10 ,
36346      &            LOUT = 6 ,
36347      &            LDAT = 9 )
36348       PARAMETER ( KALGNM = 2 )
36349       PARAMETER ( ANGLGB = 5.0D-16 )
36350       PARAMETER ( ANGLSQ = 2.5D-31 )
36351       PARAMETER ( AXCSSV = 0.2D+16 )
36352       PARAMETER ( ANDRFL = 1.0D-38 )
36353       PARAMETER ( AVRFLW = 1.0D+38 )
36354       PARAMETER ( AINFNT = 1.0D+30 )
36355       PARAMETER ( AZRZRZ = 1.0D-30 )
36356       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
36357       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
36358       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
36359       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
36360       PARAMETER ( CSNNRM = 2.0D-15 )
36361       PARAMETER ( DMXTRN = 1.0D+08 )
36362       PARAMETER ( ZERZER = 0.D+00 )
36363       PARAMETER ( ONEONE = 1.D+00 )
36364       PARAMETER ( TWOTWO = 2.D+00 )
36365       PARAMETER ( THRTHR = 3.D+00 )
36366       PARAMETER ( FOUFOU = 4.D+00 )
36367       PARAMETER ( FIVFIV = 5.D+00 )
36368       PARAMETER ( SIXSIX = 6.D+00 )
36369       PARAMETER ( SEVSEV = 7.D+00 )
36370       PARAMETER ( EIGEIG = 8.D+00 )
36371       PARAMETER ( ANINEN = 9.D+00 )
36372       PARAMETER ( TENTEN = 10.D+00 )
36373       PARAMETER ( HLFHLF = 0.5D+00 )
36374       PARAMETER ( ONETHI = ONEONE / THRTHR )
36375       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
36376       PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
36377       PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
36378       PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
36379       PARAMETER ( CLIGHT = 2.99792458         D+10 )
36380       PARAMETER ( AVOGAD = 6.0221367          D+23 )
36381       PARAMETER ( AMELGR = 9.1093897          D-28 )
36382       PARAMETER ( PLCKBR = 1.05457266         D-27 )
36383       PARAMETER ( ELCCGS = 4.8032068          D-10 )
36384       PARAMETER ( ELCMKS = 1.60217733         D-19 )
36385       PARAMETER ( AMUGRM = 1.6605402          D-24 )
36386       PARAMETER ( AMMUMU = 0.113428913        D+00 )
36387       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
36388       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
36389       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
36390       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
36391       PARAMETER ( PLABRC = 0.197327053        D+00 )
36392       PARAMETER ( AMELCT = 0.51099906         D-03 )
36393       PARAMETER ( AMUGEV = 0.93149432         D+00 )
36394       PARAMETER ( AMMUON = 0.105658389        D+00 )
36395       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
36396       PARAMETER ( GEVMEV = 1.0                D+03 )
36397       PARAMETER ( EMVGEV = 1.0                D-03 )
36398       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
36399       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
36400       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
36401 C +
36402 C    variables for EXPLOD
36403 C -
36404       PARAMETER ( KPMX = 10 )
36405       DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
36406      &          PZEXPL (KPMX), ETEXPL (KPMX)
36407 C +
36408 C      test variables
36409 C -
36410 **sr - removed (not needed)
36411 C     COMMON /GBATNU/ ELERAT,NTRY
36412 **
36413 C +
36414 C     Initializes test variables
36415 C -
36416       NTRY = 0
36417       ELERAT = 0.D+00
36418 C +
36419 C     Maximum value for matrix element
36420 C -
36421       ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
36422      &  SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
36423 C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
36424 C     Inputs for EXPLOD
36425 C part. no. 1 is l       (e- in mu- decay)
36426 C part. no. 2 is b       (nu-mu in mu- decay)
36427 C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
36428 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
36429       NPEXPL = 3
36430       ETOTEX = AMA
36431       AMEXPL(1) = AML
36432       AMEXPL(2) = 0.D+00
36433       AMEXPL(3) = 0.D+00
36434 C +
36435 C     phase space distribution
36436 C -
36437   100 CONTINUE
36438       NTRY = NTRY + 1
36439
36440       CALL DT_EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
36441      &                 PYEXPL, PZEXPL )
36442
36443 C +
36444 C  Calculates matrix element:
36445 C  64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
36446 C  Here CTH is the cosine of the angle between anti-nu and Z axis
36447 C -
36448       CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
36449      &  PZEXPL(3)**2 )
36450       PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
36451       PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
36452      &     PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
36453       ELEMAT = 16.D+00 * PROD1 * PROD2
36454       IF(ELEMAT.GT.ELEMAX) THEN
36455         WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
36456         STOP
36457       ENDIF
36458 C +
36459 C     Here performs the rejection
36460 C -
36461       TEST = DT_RNDM(ETOTEX) * ELEMAX
36462       IF ( TEST .GT. ELEMAT ) GO TO 100
36463 C +
36464 C     final assignment of variables
36465 C -
36466       ELERAT = ELEMAT/ELEMAX
36467       ETL = ETEXPL(1)
36468       PXL = PXEXPL(1)
36469       PYL = PYEXPL(1)
36470       PZL = PZEXPL(1)
36471       ETB = ETEXPL(2)
36472       PXB = PXEXPL(2)
36473       PYB = PYEXPL(2)
36474       PZB = PZEXPL(2)
36475       ETN = ETEXPL(3)
36476       PXN = PXEXPL(3)
36477       PYN = PYEXPL(3)
36478       PZN = PZEXPL(3)
36479   999 RETURN
36480       END
36481
36482 *$ CREATE DT_GEN_DELTA.FOR
36483 *COPY DT_GEN_DELTA
36484 C==================================================================
36485 C.  Generation of  Delta resonance events
36486 C==================================================================
36487 *
36488 *===gen_delta==========================================================*
36489 *
36490       SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
36491
36492       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36493       SAVE
36494
36495       PARAMETER ( LINP = 10 ,
36496      &            LOUT = 6 ,
36497      &            LDAT = 9 )
36498 C...Generate a Delta-production neutrino/antineutrino
36499 C.  CC-interaction on a nucleon
36500 C
36501 C.  INPUT  ENU (GeV) = Neutrino Energy
36502 C.         LLEP = neutrino type
36503 C.         LTARG = nucleon target type 1=p, 2=n.
36504 C.         JINT = 1:CC, 2::NC
36505 C.
36506 C.  OUTPUT PPL(4)  4-monentum of final lepton
36507 C----------------------------------------------------
36508       PARAMETER (MAXLND=4000)
36509       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
36510 **sr - removed (not needed)
36511 C     COMMON /CBAD/  LBAD, NBAD
36512 **
36513
36514       DIMENSION PI(3),PO(3)
36515 C     REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
36516       DIMENSION AML0(6),AMN(2)
36517       DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
36518       DATA AMN  /0.93827231, 0.93956563/
36519       DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
36520
36521 c     WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
36522       LBAD = 0
36523 C...Final lepton mass
36524       IF (JINT.EQ.1) THEN
36525         AML = AML0(LLEP)
36526       ELSE
36527         AML = 0.
36528       ENDIF
36529       AML2 = AML**2
36530
36531 C...Particle labels (LUND)
36532       N = 5
36533       K(1,1) = 21
36534       K(2,1) = 21
36535       K(3,1) = 21
36536       K(4,1) = 1
36537       K(3,3) = 1
36538       K(4,3) = 1
36539       IF (LTARG .EQ. 1)  THEN
36540          K(2,2) = 2212
36541       ELSE
36542          K(2,2) = 2112
36543       ENDIF
36544       K0 = (LLEP-1)/2
36545       K1 = LLEP/2
36546       KA = 12 + 2*K0
36547       IS = -1 + 2*LLEP - 4*K1
36548       LNU = 2 - LLEP + 2*K1
36549       K(1,2) = IS*KA
36550       K(5,1) = 1
36551       K(5,3) = 2
36552       IF (JINT .EQ. 1)  THEN                    ! CC interactions
36553          K(3,2) = IS*24
36554          K(4,2) = IS*(KA-1)
36555         IF(LNU.EQ.1) THEN
36556           IF (LTARG .EQ. 1)  THEN
36557               K(5,2) = 2224
36558           ELSE
36559               K(5,2) = 2214
36560           ENDIF
36561         ELSE
36562           IF (LTARG .EQ. 1)  THEN
36563               K(5,2) = 2114
36564           ELSE
36565               K(5,2) = 1114
36566           ENDIF
36567         ENDIF
36568       ELSE
36569          K(3,2) = 23                           ! NC (Z0) interactions
36570          K(4,2) = K(1,2)
36571 **sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
36572 *                                Delta0 for neutron (LTARG=2)
36573 C        IF (LTARG .EQ. 1)  THEN
36574 C           K(5,2) = 2114
36575 C        ELSE
36576 C           K(5,2) = 2214
36577 C        ENDIF
36578          IF (LTARG .EQ. 1)  THEN
36579             K(5,2) = 2214
36580          ELSE
36581             K(5,2) = 2114
36582          ENDIF
36583 **
36584       ENDIF
36585
36586 C...4-momentum initial lepton
36587       P(1,5) = 0.
36588       P(1,4) = ENU
36589       P(1,1) = 0.
36590       P(1,2) = 0.
36591       P(1,3) = ENU
36592 C...4-momentum initial nucleon
36593       P(2,5) = AMN(LTARG)
36594 C     P(2,4) = P(2,5)
36595 C     P(2,1) = 0.
36596 C     P(2,2) = 0.
36597 C     P(2,3) = 0.
36598        P(2,1) = P21
36599        P(2,2) = P22
36600        P(2,3) = P23
36601        P(2,4) = P24
36602        P(2,5) = P25
36603       N=2
36604       beta1=-p(2,1)/p(2,4)
36605       beta2=-p(2,2)/p(2,4)
36606       beta3=-p(2,3)/p(2,4)
36607       N=2
36608
36609       CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
36610
36611 C     print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
36612
36613       phi11=atan(p(1,2)/p(1,3))
36614       pi(1)=p(1,1)
36615       pi(2)=p(1,2)
36616       pi(3)=p(1,3)
36617
36618       CALL DT_TESTROT(PI,Po,PHI11,1)
36619       DO ll=1,3
36620        IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36621       END DO
36622       p(1,1)=po(1)
36623       p(1,2)=po(2)
36624       p(1,3)=po(3)
36625       phi12=atan(p(1,1)/p(1,3))
36626
36627       pi(1)=p(1,1)
36628       pi(2)=p(1,2)
36629       pi(3)=p(1,3)
36630       CALL DT_TESTROT(Pi,Po,PHI12,2)
36631       DO ll=1,3
36632         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36633       END DO
36634       p(1,1)=po(1)
36635       p(1,2)=po(2)
36636       p(1,3)=po(3)
36637
36638       ENUU=P(1,4)
36639
36640 C...Generate the Mass of the Delta
36641       NTRY = 0
36642 100   R = PYR(0)
36643       AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
36644       NTRY = NTRY + 1
36645       IF (NTRY .GT. 1000)  THEN
36646          LBAD = 1
36647          WRITE (LOUT,1001)  NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
36648          RETURN
36649       ENDIF
36650       IF (AMD .LT. AMDMIN)  GOTO 100
36651       ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
36652       IF (ENUU .LT. ET) GOTO 100
36653
36654 C...Kinematical  limits in Q**2
36655       S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
36656       SQS = SQRT(S)
36657       PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
36658       ELF = (S - AMD**2 + AML2)/(2.*SQS)
36659       PLF = SQRT(ELF**2 - AML2)
36660       Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
36661       Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
36662       IF (Q2MIN .LT. 0.)   Q2MIN = 0.
36663
36664       DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
36665 200   Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
36666       DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
36667       IF (DSIG .LT.  DSIGMAX*PYR(0)) GOTO 200
36668
36669 C...Generate the kinematics of the final particles
36670       EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
36671       GAM = EISTAR/AMN(LTARG)
36672       BET = PSTAR/EISTAR
36673       CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
36674       EL  = GAM*(ELF + BET*PLF*CTSTAR)
36675       PLZ = GAM*(PLF*CTSTAR + BET*ELF)
36676       PL  = SQRT(EL**2 - AML2)
36677       PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
36678       PHI = 6.28319*PYR(0)
36679       P(4,1) = PLT*COS(PHI)
36680       P(4,2) = PLT*SIN(PHI)
36681       P(4,3) = PLZ
36682       P(4,4) = EL
36683       P(4,5) = AML
36684
36685 C...4-momentum of Delta
36686       P(5,1) = -P(4,1)
36687       P(5,2) = -P(4,2)
36688       P(5,3) = ENUU-P(4,3)
36689       P(5,4) = ENUU+AMN(LTARG)-P(4,4)
36690       P(5,5) = AMD
36691
36692 C...4-momentum  of intermediate boson
36693       P(3,5) = -Q2
36694       P(3,4) = P(1,4)-P(4,4)
36695       P(3,1) = P(1,1)-P(4,1)
36696       P(3,2) = P(1,2)-P(4,2)
36697       P(3,3) = P(1,3)-P(4,3)
36698       N=5
36699
36700       DO kw=1,5
36701         pi(1)=p(kw,1)
36702         pi(2)=p(kw,2)
36703         pi(3)=p(kw,3)
36704         CALL DT_TESTROT(Pi,Po,PHI12,3)
36705         DO ll=1,3
36706           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36707         END DO
36708         p(kw,1)=po(1)
36709         p(kw,2)=po(2)
36710         p(kw,3)=po(3)
36711       END DO
36712
36713 c********************************************
36714
36715         DO kw=1,5
36716           pi(1)=p(kw,1)
36717           pi(2)=p(kw,2)
36718           pi(3)=p(kw,3)
36719           CALL DT_TESTROT(Pi,Po,PHI11,4)
36720           DO ll=1,3
36721             IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
36722           END DO
36723           p(kw,1)=po(1)
36724           p(kw,2)=po(2)
36725           p(kw,3)=po(3)
36726        END DO
36727 c********************************************
36728 C         transform back into Lab.
36729
36730       CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
36731
36732 C     WRITE(6,*)' Lab fram ( fermi incl.) '
36733       N=5
36734       CALL PYEXEC
36735
36736       RETURN
36737 1001  FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5,  6G10.3)
36738       END
36739
36740 *$ CREATE DT_DSIGMA_DELTA.FOR
36741 *COPY DT_DSIGMA_DELTA
36742 *
36743 *===dsigma_delta=======================================================*
36744 *
36745       DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
36746
36747       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36748       SAVE
36749
36750 C...Reaction nu + N -> lepton + Delta
36751 C.  returns the  cross section
36752 C.  dsigma/dt
36753 C.  INPUT  LNU = 1, 2  (neutrino-antineutrino)
36754 C.         QQ = t (always negative)  GeV**2
36755 C.         S  = (c.m energy)**2      GeV**2
36756 C.  OUTPUT =  10**-38 cm+2/GeV**2
36757 C-----------------------------------------------------
36758       REAL*8 MN, MN2, MN4, MD,MD2, MD4
36759       DATA MN /0.938/
36760       DATA PI /3.1415926/
36761
36762       GF = (1.1664 * 1.97)
36763       GF2 = GF*GF
36764       MN2 = MN*MN
36765       MN4 = MN2*MN2
36766       MD2 = MD*MD
36767       MD4 = MD2*MD2
36768       AML2 = AML*AML
36769       AML4 = AML2*AML2
36770       VQ  = (MN2 - MD2 - QQ)/2.
36771       VPI = (MN2 + MD2 - QQ)/2.
36772       VK  = (S + QQ - MN2 - AML2)/2.
36773       PIK = (S - MN2)/2.
36774       QK = (AML2 - QQ)/2.
36775       PIQ = (QQ + MN2 - MD2)/2.
36776       Q = SQRT(-QQ)
36777       C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
36778       C3 = SQRT(3.)*C3V/MN
36779       C4 = -C3/MD             ! attenzione al segno
36780       C5A = 1.18/(1.-QQ/0.4225)**2
36781       C32 = C3**2
36782       C42 = C4**2
36783       C5A2 = C5A**2
36784
36785       IF (LNU .EQ. 1)  THEN
36786       ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
36787      . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
36788      . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
36789      . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
36790       ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
36791      . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
36792      . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
36793      . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
36794      . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
36795      . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ-
36796      . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
36797      . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
36798      . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
36799      . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
36800      . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD*
36801      . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A
36802      . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ*
36803      . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A*
36804      . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2
36805      . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK
36806      . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
36807      . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
36808      . *C42-2.*MD2*VPI*QK**2*C32+ANS3
36809       ELSE
36810       ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
36811      . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
36812      . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
36813      . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
36814       ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
36815      . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
36816      . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
36817      . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
36818      . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
36819      . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
36820      . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
36821      . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
36822      . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
36823      . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
36824      . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
36825      . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
36826      . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
36827      . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
36828      . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
36829      . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
36830      . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
36831      . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
36832      . *C42-2.*MD2*VPI*QK**2*C32+ANS3
36833       ENDIF
36834       ANS1=32.*ANS2
36835       ANS=ANS1/(3.*MD2)
36836       P1CM = (S-MN2)/(2.*SQRT(S))
36837       DT_DSIGMA_DELTA  = GF2/2. * ANS/(64.*PI*S*P1CM**2)
36838
36839       RETURN
36840       END
36841
36842 *$ CREATE DT_QGAUS.FOR
36843 *COPY DT_QGAUS
36844 *
36845 *===qgaus==============================================================*
36846 *
36847       SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
36848
36849       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36850       SAVE
36851
36852       DIMENSION X(5),W(5)
36853       DATA X/.1488743389D0,.4333953941D0,
36854      & .6794095682D0,.8650633666D0,.9739065285D0
36855      */
36856       DATA W/.2955242247D0,.2692667193D0,
36857      & .2190863625D0,.1494513491D0,.0666713443D0
36858      */
36859       XM=0.5D0*(B+A)
36860       XR=0.5D0*(B-A)
36861       SS=0
36862       DO 11 J=1,5
36863         DX=XR*X(J)
36864         SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
36865      *  DT_DSQEL_Q2(LTYP,ENU,XM-DX))
36866 11    CONTINUE
36867       SS=XR*SS
36868
36869       RETURN
36870       END
36871
36872 *$ CREATE DT_DIQBRK.FOR
36873 *COPY DT_DIQBRK
36874 *
36875 *===diqbrk=============================================================*
36876 *
36877       SUBROUTINE DT_DIQBRK
36878
36879       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36880       SAVE
36881
36882 * event history
36883       PARAMETER (NMXHKK=200000)
36884       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36885      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36886      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36887 * extended event history
36888       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36889      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36890      &                IHIST(2,NMXHKK)
36891 * event flag
36892       COMMON /DTEVNO/ NEVENT,ICASCA
36893
36894 C     IF(DT_RNDM(VV).LE.0.5D0)THEN
36895 C       CALL GSQBS1(NHKK)
36896 C       CALL GSQBS2(NHKK)
36897 C       CALL USQBS1(NHKK)
36898 C       CALL USQBS2(NHKK)
36899 C       CALL GSABS1(NHKK)
36900 C       CALL GSABS2(NHKK)
36901 C       CALL USABS1(NHKK)
36902 C       CALL USABS2(NHKK)
36903 C     ELSE
36904 C       CALL GSQBS2(NHKK)
36905 C       CALL GSQBS1(NHKK)
36906 C       CALL USQBS2(NHKK)
36907 C       CALL USQBS1(NHKK)
36908 C       CALL GSABS2(NHKK)
36909 C       CALL GSABS1(NHKK)
36910 C       CALL USABS2(NHKK)
36911 C       CALL USABS1(NHKK)
36912 C     ENDIF
36913
36914       IF(DT_RNDM(VV).LE.0.5D0) THEN
36915         CALL DT_DBREAK(1)
36916         CALL DT_DBREAK(2)
36917         CALL DT_DBREAK(3)
36918         CALL DT_DBREAK(4)
36919         CALL DT_DBREAK(5)
36920         CALL DT_DBREAK(6)
36921         CALL DT_DBREAK(7)
36922         CALL DT_DBREAK(8)
36923       ELSE
36924         CALL DT_DBREAK(2)
36925         CALL DT_DBREAK(1)
36926         CALL DT_DBREAK(4)
36927         CALL DT_DBREAK(3)
36928         CALL DT_DBREAK(6)
36929         CALL DT_DBREAK(5)
36930         CALL DT_DBREAK(8)
36931         CALL DT_DBREAK(7)
36932       ENDIF
36933
36934       RETURN
36935       END
36936
36937 *$ CREATE MUSQBS2.FOR
36938 *COPY MUSQBS2
36939 C
36940 C
36941 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36942       SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36943      *              IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
36944 C
36945 C                  USQBS-2 diagram (split target diquark)
36946 C
36947       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36948       SAVE
36949
36950       PARAMETER ( LINP = 10 ,
36951      &            LOUT = 6 ,
36952      &            LDAT = 9 )
36953 * event history
36954       PARAMETER (NMXHKK=200000)
36955       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36956      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36957      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36958 * extended event history
36959       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36960      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36961      &                IHIST(2,NMXHKK)
36962 * Lorentz-parameters of the current interaction
36963       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
36964      &                UMO,PPCM,EPROJ,PPROJ
36965 * diquark-breaking mechanism
36966       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
36967
36968 C
36969       PARAMETER (NTMHKK= 300)
36970       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36971      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36972      +(4,NTMHKK)
36973 *KEEP,XSEADI.
36974       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
36975      +SSMIMQ,VVMTHR
36976 *KEEP,DPRIN.
36977       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
36978       COMMON /EVFLAG/ NUMEV
36979 C
36980 C                  USQBS-2 diagram (split target diquark)
36981 C
36982 C
36983 C     Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
36984 C     Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
36985 C
36986 C     Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
36987 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
36988 C
36989 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
36990 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36991 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
36992 C
36993 C
36994 C       Put new chains into COMMON /HKKTMP/
36995 C
36996       IIGLU1=NC1T-NC1P-1
36997       IIGLU2=NC2T-NC2P-1
36998       IGCOUN=0
36999 C     WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37000       CVQ=1.D0
37001       IREJ=0
37002       IF(IPIP.EQ.2)THEN
37003 C     IF(NUMEV.EQ.-324)THEN
37004 C     WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37005 C    *             'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
37006 C    *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37007 C    *              IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
37008       ENDIF
37009 C
37010 C
37011 C
37012 C     determine x-values of NC1T diquark
37013       XDIQT=PHKK(4,NC1T)*2.D0/UMO
37014       XVQP=PHKK(4,NC1P)*2.D0/UMO
37015 C
37016 C     determine x-values of sea quark pair
37017 C
37018       IPCO=1
37019       ICOU=0
37020  2234 CONTINUE
37021       ICOU=ICOU+1
37022       IF(ICOU.GE.500)THEN
37023         IREJ=1
37024         IF(ISQ.EQ.3)IREJ=3
37025         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
37026         IPCO=0
37027         RETURN
37028       ENDIF
37029       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call  XSEAPA: UMO,XDIQT,XVQP ',
37030      * UMO, XDIQT,XVQP
37031       XSQ=0.D0
37032       XSAQ=0.D0
37033 **NEW
37034 C     CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37035       IF (IPIP.EQ.1) THEN
37036          XQMAX  = XDIQT/2.0D0
37037          XAQMAX = 2.D0*XVQP/3.0D0
37038       ELSE
37039          XQMAX  = 2.D0*XVQP/3.0D0
37040          XAQMAX = XDIQT/2.0D0
37041       ENDIF
37042       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37043       ISAQ = 6+ISQ
37044 C     write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
37045 **
37046         IF(IPCO.GE.3)
37047      &     WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37048       IF(IREJ.GE.1)THEN
37049         IF(IPCO.GE.3)
37050      &     WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37051         IPCO=0
37052         RETURN
37053       ENDIF
37054       IF(IPIP.EQ.1)THEN
37055         IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37056       ELSEIF(IPIP.EQ.2)THEN
37057         IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37058       ENDIF
37059       IF(IPCO.GE.3)THEN
37060         WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
37061      *  XDIQT,XVQP,XSQ,XSAQ
37062       ENDIF
37063 C
37064 C     subtract xsq,xsaq from NC1T diquark and NC1P quark
37065 C
37066 C     XSQ=0.D0
37067       IF(IPIP.EQ.1)THEN
37068         XDIQT=XDIQT-XSQ
37069         XVQP =XVQP -XSAQ
37070       ELSEIF(IPIP.EQ.2)THEN
37071         XDIQT=XDIQT-XSAQ
37072         XVQP =XVQP -XSQ
37073       ENDIF
37074       IF(IPCO.GE.3)
37075      &   WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
37076 C
37077 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37078 C
37079       XVTHRO=CVQ/UMO
37080       IVTHR=0
37081  3466 CONTINUE
37082       IF(IVTHR.EQ.10)THEN
37083         IREJ=1
37084         IF(ISQ.EQ.3)IREJ=3
37085         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
37086       IPCO=0
37087         RETURN
37088       ENDIF
37089       IVTHR=IVTHR+1
37090       XVTHR=XVTHRO/(201-IVTHR)
37091       UNOPRV=UNON
37092  380  CONTINUE
37093       IF(XVTHR.GT.0.66D0*XDIQT)THEN
37094         IREJ=1
37095         IF(ISQ.EQ.3)IREJ=3
37096         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR  large ',
37097      *  XVTHR
37098       IPCO=0
37099         RETURN
37100       ENDIF
37101       IF(DT_RNDM(V).LT.0.5D0)THEN
37102         XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37103         XVTQII=XDIQT-XVTQI
37104       ELSE
37105         XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37106         XVTQI=XDIQT-XVTQII
37107       ENDIF
37108       IF(IPCO.GE.3)THEN
37109         WRITE(LOUT,'(A,2E12.4)')'  MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
37110       ENDIF
37111 C
37112 C     Prepare 4 momenta of new chains and chain ends
37113 C
37114 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37115 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37116 C    +(4,NTMHKK)
37117 C
37118 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37119 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37120 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37121 C
37122 C     SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37123 C    *              IP1,IP21,IP22,IPP1,IPP2)
37124 C
37125       IF(IPIP.EQ.1)THEN
37126         XSQ1=XSQ
37127         XSAQ1=XSAQ
37128         ISQ1=ISQ
37129         ISAQ1=ISAQ
37130       ELSEIF(IPIP.EQ.2)THEN
37131         XSQ1=XSAQ
37132         XSAQ1=XSQ
37133         ISQ1=ISAQ
37134         ISAQ1=ISQ
37135       ENDIF
37136       IDHKT(1)   =IPP1
37137       ISTHKT(1)  =951
37138       JMOHKT(1,1)=NC2P
37139       JMOHKT(2,1)=0
37140       JDAHKT(1,1)=3+IIGLU1
37141       JDAHKT(2,1)=0
37142 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
37143       PHKT(1,1)  =PHKK(1,NC2P)
37144       PHKT(2,1)  =PHKK(2,NC2P)
37145       PHKT(3,1)  =PHKK(3,NC2P)
37146       PHKT(4,1)  =PHKK(4,NC2P)
37147 C     PHKT(5,1)  =PHKK(5,NC2P)
37148       XMIST  =(PHKT(4,1)**2-
37149      * PHKT(3,1)**2-PHKT(2,1)**2-
37150      *PHKT(1,1)**2)
37151       IF(XMIST.GT.0.D0)THEN
37152       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37153      *PHKT(1,1)**2)
37154       ELSE
37155 C     WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
37156       PHKT(5,1)=0.D0
37157       ENDIF
37158       VHKT(1,1)  =VHKK(1,NC2P)
37159       VHKT(2,1)  =VHKK(2,NC2P)
37160       VHKT(3,1)  =VHKK(3,NC2P)
37161       VHKT(4,1)  =VHKK(4,NC2P)
37162       WHKT(1,1)  =WHKK(1,NC2P)
37163       WHKT(2,1)  =WHKK(2,NC2P)
37164       WHKT(3,1)  =WHKK(3,NC2P)
37165       WHKT(4,1)  =WHKK(4,NC2P)
37166 C     Add here IIGLU1 gluons to this chaina
37167       PG1=0.D0
37168       PG2=0.D0
37169       PG3=0.D0
37170       PG4=0.D0
37171       IF(IIGLU1.GE.1)THEN
37172       JJG=NC1P
37173       DO 61 IIG=2,2+IIGLU1-1
37174         KKG=JJG+IIG-1
37175         IDHKT(IIG)   =IDHKK(KKG)
37176         ISTHKT(IIG)  =921
37177         JMOHKT(1,IIG)=KKG
37178         JMOHKT(2,IIG)=0
37179         JDAHKT(1,IIG)=3+IIGLU1
37180         JDAHKT(2,IIG)=0
37181         PHKT(1,IIG)=PHKK(1,KKG)
37182         PG1=PG1+ PHKT(1,IIG)
37183         PHKT(2,IIG)=PHKK(2,KKG)
37184         PG2=PG2+ PHKT(2,IIG)
37185         PHKT(3,IIG)=PHKK(3,KKG)
37186         PG3=PG3+ PHKT(3,IIG)
37187         PHKT(4,IIG)=PHKK(4,KKG)
37188         PG4=PG4+ PHKT(4,IIG)
37189         PHKT(5,IIG)=PHKK(5,KKG)
37190         VHKT(1,IIG)  =VHKK(1,KKG)
37191         VHKT(2,IIG)  =VHKK(2,KKG)
37192         VHKT(3,IIG)  =VHKK(3,KKG)
37193         VHKT(4,IIG)  =VHKK(4,KKG)
37194         WHKT(1,IIG) =WHKK(1,KKG)
37195         WHKT(2,IIG) =WHKK(2,KKG)
37196         WHKT(3,IIG) =WHKK(3,KKG)
37197         WHKT(4,IIG) =WHKK(4,KKG)
37198    61 CONTINUE
37199       ENDIF
37200       IDHKT(2+IIGLU1)   =IP21
37201       ISTHKT(2+IIGLU1)  =952
37202       JMOHKT(1,2+IIGLU1)=NC1T
37203       JMOHKT(2,2+IIGLU1)=0
37204       JDAHKT(1,2+IIGLU1)=3+IIGLU1
37205       JDAHKT(2,2+IIGLU1)=0
37206       PHKT(1,2+IIGLU1)  =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
37207       PHKT(2,2+IIGLU1)  =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
37208       PHKT(3,2+IIGLU1)  =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
37209       PHKT(4,2+IIGLU1)  =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
37210 C     PHKT(5,2)  =PHKK(5,NC1T)
37211       XMIST  =(PHKT(4,2+IIGLU1)**2-
37212      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37213      *PHKT(1,2+IIGLU1)**2)
37214       IF(XMIST.GT.0.D0)THEN
37215       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
37216      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37217      *PHKT(1,2+IIGLU1)**2)
37218       ELSE
37219 C      WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
37220         PHKT(5,5+IIGLU1)=0.D0
37221       ENDIF
37222       VHKT(1,2+IIGLU1)  =VHKK(1,NC1T)
37223       VHKT(2,2+IIGLU1)  =VHKK(2,NC1T)
37224       VHKT(3,2+IIGLU1)  =VHKK(3,NC1T)
37225       VHKT(4,2+IIGLU1)  =VHKK(4,NC1T)
37226       WHKT(1,2+IIGLU1)  =WHKK(1,NC1T)
37227       WHKT(2,2+IIGLU1)  =WHKK(2,NC1T)
37228       WHKT(3,2+IIGLU1)  =WHKK(3,NC1T)
37229       WHKT(4,2+IIGLU1)  =WHKK(4,NC1T)
37230       IDHKT(3+IIGLU1)   =88888
37231       ISTHKT(3+IIGLU1)  =95
37232       JMOHKT(1,3+IIGLU1)=1
37233       JMOHKT(2,3+IIGLU1)=2+IIGLU1
37234       JDAHKT(1,3+IIGLU1)=0
37235       JDAHKT(2,3+IIGLU1)=0
37236       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
37237       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
37238       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
37239       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
37240       XMIST
37241      * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37242      *            -PHKT(3,3+IIGLU1)**2)
37243       IF(XMIST.GT.0.D0)THEN
37244       PHKT(5,3+IIGLU1)
37245      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37246      *            -PHKT(3,3+IIGLU1)**2)
37247       ELSE
37248 C      WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
37249         PHKT(5,5+IIGLU1)=0.D0
37250       ENDIF
37251       IF(IPIP.GE.2)THEN
37252 C     IF(NUMEV.EQ.-324)THEN
37253 C     WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
37254 C    * JDAHKT(1,1),
37255 C    *JDAHKT(2,1),(PHKT(III,1),III=1,5)
37256       DO 71 IIG=2,2+IIGLU1-1
37257 C     WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37258 C    &             JMOHKT(1,IIG),JMOHKT(2,IIG),
37259 C    * JDAHKT(1,IIG),
37260 C    *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37261    71 CONTINUE
37262 C     WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
37263 C    * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
37264 C    *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
37265 C     WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
37266 C    * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
37267 C    *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
37268       ENDIF
37269       CHAMAL=CHAM1
37270       IF(IPIP.EQ.1)THEN
37271         IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
37272       ELSEIF(IPIP.EQ.2)THEN
37273         IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
37274       ENDIF
37275       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
37276 C       IREJ=1
37277         IPCO=0
37278 C       RETURN
37279 C       WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
37280         GO TO 3466
37281       ENDIF
37282       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
37283       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
37284       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
37285       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
37286       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
37287       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
37288       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
37289       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
37290       IF(IPIP.EQ.1)THEN
37291         IDHKT(4+IIGLU1)   =-(ISAQ1-6)
37292       ELSEIF(IPIP.EQ.2)THEN
37293         IDHKT(4+IIGLU1)   =ISAQ1
37294       ENDIF
37295       ISTHKT(4+IIGLU1)  =951
37296       JMOHKT(1,4+IIGLU1)=NC1P
37297       JMOHKT(2,4+IIGLU1)=0
37298       JDAHKT(1,4+IIGLU1)=6+IIGLU1
37299       JDAHKT(2,4+IIGLU1)=0
37300 C     create chain    6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37301       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
37302       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
37303       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
37304       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
37305 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
37306       XMIST  =(PHKT(4,4+IIGLU1)**2-
37307      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37308      *PHKT(1,4+IIGLU1)**2)
37309       IF(XMIST.GT.0.D0)THEN
37310       PHKT(5,4+IIGLU1)  =SQRT(PHKT(4,4+IIGLU1)**2-
37311      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37312      *PHKT(1,4+IIGLU1)**2)
37313       ELSE
37314 C     WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
37315       PHKT(5,4+IIGLU1)=0.D0
37316       ENDIF
37317       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
37318       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
37319       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
37320       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
37321       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
37322       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
37323       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
37324       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
37325       IDHKT(5+IIGLU1)   =IP22
37326       ISTHKT(5+IIGLU1)  =952
37327       JMOHKT(1,5+IIGLU1)=NC1T
37328       JMOHKT(2,5+IIGLU1)=0
37329       JDAHKT(1,5+IIGLU1)=6+IIGLU1
37330       JDAHKT(2,5+IIGLU1)=0
37331       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
37332       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
37333       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
37334       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
37335 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
37336       XMIST  =(PHKT(4,5+IIGLU1)**2-
37337      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37338      *PHKT(1,5+IIGLU1)**2)
37339       IF(XMIST.GT.0.D0)THEN
37340       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
37341      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37342      *PHKT(1,5+IIGLU1)**2)
37343       ELSE
37344 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37345         PHKT(5,5+IIGLU1)=0.D0
37346       ENDIF
37347       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
37348       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
37349       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
37350       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
37351       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
37352       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
37353       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
37354       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
37355       IDHKT(6+IIGLU1)   =88888
37356       ISTHKT(6+IIGLU1)  =95
37357       JMOHKT(1,6+IIGLU1)=4+IIGLU1
37358       JMOHKT(2,6+IIGLU1)=5+IIGLU1
37359       JDAHKT(1,6+IIGLU1)=0
37360       JDAHKT(2,6+IIGLU1)=0
37361       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37362       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37363       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37364       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37365       XMIST
37366      * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37367      *            -PHKT(3,6+IIGLU1)**2)
37368       IF(XMIST.GT.0.D0)THEN
37369       PHKT(5,6+IIGLU1)
37370      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37371      *            -PHKT(3,6+IIGLU1)**2)
37372       ELSE
37373 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37374         PHKT(5,5+IIGLU1)=0.D0
37375       ENDIF
37376 C     IF(IPIP.GE.2)THEN
37377 C     IF(NUMEV.EQ.-324)THEN
37378 C     WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37379 C    * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37380 C    *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37381 C     WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37382 C    * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37383 C    *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37384 C     WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37385 C    * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37386 C    *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37387 C     ENDIF
37388       CHAMAL=CHAM1
37389       IF(IPIP.EQ.1)THEN
37390         IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37391       ELSEIF(IPIP.EQ.2)THEN
37392         IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37393       ENDIF
37394       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37395 C       IREJ=1
37396         IPCO=0
37397 C       RETURN
37398 C       WRITE(6,*)' MUSQBS1 jump back from chain 6',
37399 C    *  CHAMAL,PHKT(5,6+IIGLU1)
37400         GO TO 3466
37401       ENDIF
37402       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
37403       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
37404       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
37405       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
37406       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
37407       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
37408       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
37409       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
37410 C     IDHKT(7)   =1000*IPP1+100*ISQ+1
37411       IDHKT(7+IIGLU1)   =IP1
37412       ISTHKT(7+IIGLU1)  =951
37413       JMOHKT(1,7+IIGLU1)=NC1P
37414       JMOHKT(2,7+IIGLU1)=0
37415 **NEW
37416 C     JDAHKT(1,7+IIGLU1)=9+IIGLU1
37417       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
37418 **
37419       JDAHKT(2,7+IIGLU1)=0
37420       PHKT(1,7+IIGLU1)  =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
37421       PHKT(2,7+IIGLU1)  =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
37422       PHKT(3,7+IIGLU1)  =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
37423       PHKT(4,7+IIGLU1)  =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
37424 C     PHKT(5,7+IIGLU1)  =PHKK(5,NC1P)
37425       XMIST  =(PHKT(4,7+IIGLU1)**2-
37426      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37427      *PHKT(1,7+IIGLU1)**2)
37428       IF(XMIST.GT.0.D0)THEN
37429       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
37430      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37431      *PHKT(1,7+IIGLU1)**2)
37432       ELSE
37433 C     WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
37434       PHKT(5,7+IIGLU1)=0.D0
37435       ENDIF
37436       VHKT(1,7+IIGLU1)  =VHKK(1,NC1P)
37437       VHKT(2,7+IIGLU1)  =VHKK(2,NC1P)
37438       VHKT(3,7+IIGLU1)  =VHKK(3,NC1P)
37439       VHKT(4,7+IIGLU1)  =VHKK(4,NC1P)
37440       WHKT(1,7+IIGLU1)  =WHKK(1,NC1P)
37441       WHKT(2,7+IIGLU1)  =WHKK(2,NC1P)
37442       WHKT(3,7+IIGLU1)  =WHKK(3,NC1P)
37443       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
37444 C     Insert here the IIGLU2 gluons
37445       PG1=0.D0
37446       PG2=0.D0
37447       PG3=0.D0
37448       PG4=0.D0
37449       IF(IIGLU2.GE.1)THEN
37450       JJG=NC2P
37451       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37452         KKG=JJG+IIG-7-IIGLU1
37453         IDHKT(IIG)   =IDHKK(KKG)
37454         ISTHKT(IIG)  =921
37455         JMOHKT(1,IIG)=KKG
37456         JMOHKT(2,IIG)=0
37457         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
37458         JDAHKT(2,IIG)=0
37459         PHKT(1,IIG)=PHKK(1,KKG)
37460         PG1=PG1+ PHKT(1,IIG)
37461         PHKT(2,IIG)=PHKK(2,KKG)
37462         PG2=PG2+ PHKT(2,IIG)
37463         PHKT(3,IIG)=PHKK(3,KKG)
37464         PG3=PG3+ PHKT(3,IIG)
37465         PHKT(4,IIG)=PHKK(4,KKG)
37466         PG4=PG4+ PHKT(4,IIG)
37467         PHKT(5,IIG)=PHKK(5,KKG)
37468         VHKT(1,IIG)  =VHKK(1,KKG)
37469         VHKT(2,IIG)  =VHKK(2,KKG)
37470         VHKT(3,IIG)  =VHKK(3,KKG)
37471         VHKT(4,IIG)  =VHKK(4,KKG)
37472         WHKT(1,IIG)  =WHKK(1,KKG)
37473         WHKT(2,IIG) =WHKK(2,KKG)
37474         WHKT(3,IIG) =WHKK(3,KKG)
37475         WHKT(4,IIG) =WHKK(4,KKG)
37476    81 CONTINUE
37477       ENDIF
37478       IF(IPIP.EQ.1)THEN
37479         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*ISQ1+3
37480         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
37481         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
37482         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
37483       ELSEIF(IPIP.EQ.2)THEN
37484         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*(-ISQ1+6)-3
37485         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
37486         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
37487         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
37488       ENDIF
37489       ISTHKT(8+IIGLU1+IIGLU2)  =952
37490       JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
37491       JMOHKT(2,8+IIGLU1+IIGLU2)=0
37492       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
37493       JDAHKT(2,8+IIGLU1+IIGLU2)=0
37494       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC2T)+
37495      * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
37496       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC2T)+
37497      * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
37498       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC2T)+
37499      * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
37500       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC2T)+
37501      * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
37502 C     WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
37503 C    * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
37504       IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
37505 C       IREJ=1
37506 C       WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
37507 C    *  ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
37508         IPCO=0
37509 C       RETURN
37510         GO TO 3466
37511       ENDIF
37512 C     PHKT(5,8)  =PHKK(5,NC2T)
37513       XMIST  =(PHKT(4,8+IIGLU1+IIGLU2)**2-
37514      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37515      *PHKT(1,8+IIGLU1+IIGLU2)**2)
37516       IF(XMIST.GT.0.D0)THEN
37517       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
37518      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37519      *PHKT(1,8+IIGLU1+IIGLU2)**2)
37520       ELSE
37521 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37522         PHKT(5,5+IIGLU1)=0.D0
37523       ENDIF
37524       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC2T)
37525       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC2T)
37526       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC2T)
37527       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC2T)
37528       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC2T)
37529       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC2T)
37530       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC2T)
37531       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC2T)
37532       IDHKT(9+IIGLU1+IIGLU2)   =88888
37533       ISTHKT(9+IIGLU1+IIGLU2)  =95
37534       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
37535       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
37536       JDAHKT(1,9+IIGLU1+IIGLU2)=0
37537       JDAHKT(2,9+IIGLU1+IIGLU2)=0
37538 **NEW
37539 C     PHKT(1,9+IIGLU1+IIGLU2)
37540 C    * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37541 C     PHKT(2,9+IIGLU1+IIGLU2)
37542 C    * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37543 C     PHKT(3,9+IIGLU1+IIGLU2)
37544 C    * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37545 C     PHKT(4,9+IIGLU1+IIGLU2)
37546 C    * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37547       PHKT(1,9+IIGLU1+IIGLU2)
37548      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37549       PHKT(2,9+IIGLU1+IIGLU2)
37550      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37551       PHKT(3,9+IIGLU1+IIGLU2)
37552      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37553       PHKT(4,9+IIGLU1+IIGLU2)
37554      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37555 **
37556       XMIST
37557      * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37558      * -PHKT(2,9+IIGLU1+IIGLU2)**2
37559      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
37560       IF(XMIST.GT.0.D0)THEN
37561       PHKT(5,9+IIGLU1+IIGLU2)
37562      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37563      * -PHKT(2,9+IIGLU1+IIGLU2)**2
37564      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
37565       ELSE
37566 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37567         PHKT(5,5+IIGLU1)=0.D0
37568       ENDIF
37569       IF(IPIP.GE.2)THEN
37570 C     IF(NUMEV.EQ.-324)THEN
37571 C     WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
37572 C    * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
37573 C    *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
37574 C     DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37575 C     WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
37576 C    * JDAHKT(1,IIG),
37577 C    *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37578 C  91 CONTINUE
37579 C     WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
37580 C    * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
37581 C    *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
37582 C    *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
37583 C     WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
37584 C    * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
37585 C    *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
37586 C    *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
37587       ENDIF
37588       CHAMAL=CHAB1
37589       IF(IPIP.EQ.1)THEN
37590         IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37591       ELSEIF(IPIP.EQ.2)THEN
37592         IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37593       ENDIF
37594       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37595 C       IREJ=1
37596         IPCO=0
37597 C       RETURN
37598 C       WRITE(6,*)' MUSQBS1 jump back from chain 9',
37599 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
37600         GO TO 3466
37601       ENDIF
37602       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
37603       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
37604       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
37605       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
37606       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
37607       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
37608       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
37609       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
37610 C
37611       IPCO=0
37612       IGCOUN=9+IIGLU1+IIGLU2
37613        RETURN
37614        END
37615
37616 *$ CREATE MGSQBS2.FOR
37617 *COPY MGSQBS2
37618 C
37619 C
37620 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37621       SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37622      *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
37623 C
37624 C                  GSQBS-2 diagram (split target diquark)
37625 C
37626       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37627       SAVE
37628
37629       PARAMETER ( LINP = 10 ,
37630      &            LOUT = 6 ,
37631      &            LDAT = 9 )
37632 * event history
37633       PARAMETER (NMXHKK=200000)
37634       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37635      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37636      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37637 * extended event history
37638       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37639      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37640      &                IHIST(2,NMXHKK)
37641 * Lorentz-parameters of the current interaction
37642       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37643      &                UMO,PPCM,EPROJ,PPROJ
37644 * diquark-breaking mechanism
37645       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37646
37647 C
37648       PARAMETER (NTMHKK= 300)
37649       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37650      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37651      +(4,NTMHKK)
37652
37653 *KEEP,XSEADI.
37654       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37655      +SSMIMQ,VVMTHR
37656 *KEEP,DPRIN.
37657       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37658 C
37659 C                  GSQBS-2 diagram (split target diquark)
37660 C
37661 C
37662 C     Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
37663 C     Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
37664 C
37665 C     Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
37666 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37667 C
37668 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37669 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37670 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37671 C
37672 C
37673 C
37674 C       Put new chains into COMMON /HKKTMP/
37675 C
37676       IIGLU1=NC1T-NC1P-1
37677       IIGLU2=NC2T-NC2P-1
37678       IGCOUN=0
37679 C     WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37680       CVQ=1.D0
37681       IREJ=0
37682 C     IF(IPIP.EQ.2)THEN
37683 C     WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37684 C    *             'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
37685 C    *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37686 C    *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
37687 C     ENDIF
37688 C
37689 C
37690 C
37691 C     determine x-values of NC1T diquark
37692       XDIQT=PHKK(4,NC1T)*2.D0/UMO
37693       XVQP=PHKK(4,NC1P)*2.D0/UMO
37694 C
37695 C     determine x-values of sea quark pair
37696 C
37697       IPCO=1
37698       ICOU=0
37699  2234 CONTINUE
37700       ICOU=ICOU+1
37701       IF(ICOU.GE.500)THEN
37702         IREJ=1
37703         IF(ISQ.EQ.3)IREJ=3
37704         IF(IPCO.GE.3)
37705      &     WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
37706         IPCO=0
37707         RETURN
37708       ENDIF
37709       IF(IPCO.GE.3)
37710      &     WRITE(LOUT,*)'MGSQBS2 call  XSEAPA: UMO,XDIQT,XVQP ',
37711      * UMO, XDIQT,XVQP
37712       XSQ=0.D0
37713       XSAQ=0.D0
37714 **NEW
37715 C     CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37716       IF (IPIP.EQ.1) THEN
37717          XQMAX  = XDIQT/2.0D0
37718          XAQMAX = 2.D0*XVQP/3.0D0
37719       ELSE
37720          XQMAX  = 2.D0*XVQP/3.0D0
37721          XAQMAX = XDIQT/2.0D0
37722       ENDIF
37723       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37724       ISAQ = 6+ISQ
37725 C     write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
37726 **
37727         IF(IPCO.GE.3)
37728      &     WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37729       IF(IREJ.GE.1)THEN
37730         IF(IPCO.GE.3)
37731      &     WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37732         IPCO=0
37733         RETURN
37734       ENDIF
37735       IF(IPIP.EQ.1)THEN
37736         IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37737       ELSEIF(IPIP.EQ.2)THEN
37738         IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
37739       ENDIF
37740       IF(IPCO.GE.3)THEN
37741         WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
37742      *  XDIQT,XVQP,XSQ,XSAQ
37743       ENDIF
37744 C
37745 C     subtract xsq,xsaq from NC1T diquark and NC1P quark
37746 C
37747 C     XSQ=0.D0
37748       IF(IPIP.EQ.1)THEN
37749         XDIQT=XDIQT-XSQ
37750         XVQP =XVQP -XSAQ
37751       ELSEIF(IPIP.EQ.2)THEN
37752         XDIQT=XDIQT-XSAQ
37753         XVQP =XVQP -XSQ
37754       ENDIF
37755       IF(IPCO.GE.3)
37756      &   WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
37757 C
37758 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
37759 C
37760       XVTHRO=CVQ/UMO
37761       IVTHR=0
37762  3466 CONTINUE
37763       IF(IVTHR.EQ.10)THEN
37764         IREJ=1
37765         IF(ISQ.EQ.3)IREJ=3
37766         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
37767         IPCO=0
37768         RETURN
37769       ENDIF
37770       IVTHR=IVTHR+1
37771       XVTHR=XVTHRO/(201-IVTHR)
37772       UNOPRV=UNON
37773  380  CONTINUE
37774       IF(XVTHR.GT.0.66D0*XDIQT)THEN
37775         IREJ=1
37776         IF(ISQ.EQ.3)IREJ=3
37777         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR  large ',
37778      *  XVTHR
37779         IPCO=0
37780         RETURN
37781       ENDIF
37782       IF(DT_RNDM(V).LT.0.5D0)THEN
37783         XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37784         XVTQII=XDIQT-XVTQI
37785       ELSE
37786         XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
37787         XVTQI=XDIQT-XVTQII
37788       ENDIF
37789       IF(IPCO.GE.3)THEN
37790         WRITE(LOUT,'(A,2E12.4)')'  MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
37791       ENDIF
37792 C
37793 C     Prepare 4 momenta of new chains and chain ends
37794 C
37795 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37796 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37797 C    +(4,NTMHKK)
37798 C
37799 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37800 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37801 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
37802 C
37803 C     SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37804 C    *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
37805 C
37806       IF(IPIP.EQ.1)THEN
37807         XSQ1=XSQ
37808         XSAQ1=XSAQ
37809         ISQ1=ISQ
37810         ISAQ1=ISAQ
37811       ELSEIF(IPIP.EQ.2)THEN
37812         XSQ1=XSAQ
37813         XSAQ1=XSQ
37814         ISQ1=ISAQ
37815         ISAQ1=ISQ
37816       ENDIF
37817       KK11=IP21
37818 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
37819       KK21=IPP11
37820       KK22=IPP12
37821       XGIVE=0.D0
37822       IF(IPIP.EQ.1)THEN
37823         IDHKT(4+IIGLU1)   =-(ISAQ1-6)
37824       ELSEIF(IPIP.EQ.2)THEN
37825         IDHKT(4+IIGLU1)   =ISAQ1
37826       ENDIF
37827       ISTHKT(4+IIGLU1)  =961
37828       JMOHKT(1,4+IIGLU1)=NC1P
37829       JMOHKT(2,4+IIGLU1)=0
37830       JDAHKT(1,4+IIGLU1)=6+IIGLU1
37831       JDAHKT(2,4+IIGLU1)=0
37832 C     create chain    6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
37833       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
37834       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
37835       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
37836       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
37837 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
37838       XXMIST=(PHKT(4,4+IIGLU1)**2-
37839      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37840      *PHKT(1,4+IIGLU1)**2)
37841       IF(XXMIST.GT.0.D0)THEN
37842         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
37843       ELSE
37844         WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
37845         XXMIST=ABS(XXMIST)
37846         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
37847       ENDIF
37848       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
37849       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
37850       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
37851       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
37852       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
37853       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
37854       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
37855       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
37856       IDHKT(5+IIGLU1)   =IP22
37857       ISTHKT(5+IIGLU1)  =962
37858       JMOHKT(1,5+IIGLU1)=NC1T
37859       JMOHKT(2,5+IIGLU1)=0
37860       JDAHKT(1,5+IIGLU1)=6+IIGLU1
37861       JDAHKT(2,5+IIGLU1)=0
37862       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
37863       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
37864       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
37865       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
37866 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
37867       XXMIST=(PHKT(4,5+IIGLU1)**2-
37868      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37869      *PHKT(1,5+IIGLU1)**2)
37870       IF(XXMIST.GT.0.D0)THEN
37871         PHKT(5,5+IIGLU1)  =SQRT(XXMIST)
37872       ELSE
37873         WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
37874         XXMIST=ABS(XXMIST)
37875         PHKT(5,5+IIGLU1)  =SQRT(XXMIST)
37876       ENDIF
37877       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
37878       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
37879       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
37880       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
37881       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
37882       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
37883       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
37884       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
37885       IDHKT(6+IIGLU1)   =88888
37886       ISTHKT(6+IIGLU1)  =96
37887       JMOHKT(1,6+IIGLU1)=4+IIGLU1
37888       JMOHKT(2,6+IIGLU1)=5+IIGLU1
37889       JDAHKT(1,6+IIGLU1)=0
37890       JDAHKT(2,6+IIGLU1)=0
37891       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37892       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37893       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37894       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37895       PHKT(5,6+IIGLU1)
37896      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37897      *            -PHKT(3,6+IIGLU1)**2)
37898       CHAMAL=CHAM1
37899       IF(IPIP.EQ.1)THEN
37900         IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37901       ELSEIF(IPIP.EQ.2)THEN
37902         IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37903       ENDIF
37904 C---------------------------------------------------
37905       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37906         IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
37907 C                    we drop chain 6 and give the energy to chain 3
37908           IDHKT(6+IIGLU1)=22888
37909           XGIVE=1.D0
37910 C         WRITE(6,*)' drop chain 6 xgive=1'
37911           GO TO 7788
37912         ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
37913 C                    we drop chain 6 and give the energy to chain 3
37914 C                    and change KK11 to IDHKT(5)
37915           IDHKT(6+IIGLU1)=22888
37916           XGIVE=1.D0
37917 C         WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
37918           KK11=IDHKT(5+IIGLU1)
37919           GO TO 7788
37920         ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
37921 C                    we drop chain 6 and give the energy to chain 3
37922 C                    and change KK21 to IDHKT(5+IIGLU1)
37923 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
37924           IDHKT(6+IIGLU1)=22888
37925           XGIVE=1.D0
37926 C         WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
37927           KK21=IDHKT(5+IIGLU1)
37928           GO TO 7788
37929         ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
37930 C                    we drop chain 6 and give the energy to chain 3
37931 C                    and change KK22 to IDHKT(5)
37932 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
37933           IDHKT(6+IIGLU1)=22888
37934           XGIVE=1.D0
37935 C         WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
37936           KK22=IDHKT(5+IIGLU1)
37937           GO TO 7788
37938         ENDIF
37939 C       IREJ=1
37940         IPCO=0
37941 C       RETURN
37942         GO TO 3466
37943       ENDIF
37944  7788 CONTINUE
37945 C---------------------------------------------------
37946       IF(IPIP.GE.3)THEN
37947       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37948      * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37949      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37950       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37951      * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37952      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37953       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37954      * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37955      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37956       ENDIF
37957       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
37958       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
37959       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
37960       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
37961       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
37962       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
37963       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
37964       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
37965 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
37966       IF(IPIP.EQ.1)THEN
37967         IDHKT(1)   =1000*KK21+100*KK22+3
37968         IF(IDHKT(1).EQ.1203)IDHKT(1)=2103
37969         IF(IDHKT(1).EQ.1303)IDHKT(1)=3103
37970         IF(IDHKT(1).EQ.2303)IDHKT(1)=3203
37971       ELSEIF(IPIP.EQ.2)THEN
37972         IDHKT(1)   =1000*KK21+100*KK22-3
37973         IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103
37974         IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103
37975         IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203
37976       ENDIF
37977       ISTHKT(1)  =961
37978       JMOHKT(1,1)=NC2P
37979       JMOHKT(2,1)=0
37980       JDAHKT(1,1)=3+IIGLU1
37981       JDAHKT(2,1)=0
37982 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
37983       PHKT(1,1)  =PHKK(1,NC2P)
37984      *+XGIVE*PHKT(1,4+IIGLU1)
37985       PHKT(2,1)  =PHKK(2,NC2P)
37986      *+XGIVE*PHKT(2,4+IIGLU1)
37987       PHKT(3,1)  =PHKK(3,NC2P)
37988      *+XGIVE*PHKT(3,4+IIGLU1)
37989       PHKT(4,1)  =PHKK(4,NC2P)
37990      *+XGIVE*PHKT(4,4+IIGLU1)
37991 C     PHKT(5,1)  =PHKK(5,NC2P)
37992       XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37993      *PHKT(1,1)**2
37994       IF(XXMIST.GT.0.D0)THEN
37995         PHKT(5,1)  =SQRT(XXMIST)
37996       ELSE
37997         WRITE(LOUT,*)'MGSQBS2',XXMIST
37998         XXMIST=ABS(XXMIST)
37999         PHKT(5,1)  =SQRT(XXMIST)
38000       ENDIF
38001       VHKT(1,1)  =VHKK(1,NC2P)
38002       VHKT(2,1)  =VHKK(2,NC2P)
38003       VHKT(3,1)  =VHKK(3,NC2P)
38004       VHKT(4,1)  =VHKK(4,NC2P)
38005       WHKT(1,1)  =WHKK(1,NC2P)
38006       WHKT(2,1)  =WHKK(2,NC2P)
38007       WHKT(3,1)  =WHKK(3,NC2P)
38008       WHKT(4,1)  =WHKK(4,NC2P)
38009 C     Add here IIGLU1 gluons to this chaina
38010       PG1=0.D0
38011       PG2=0.D0
38012       PG3=0.D0
38013       PG4=0.D0
38014       IF(IIGLU1.GE.1)THEN
38015       JJG=NC1P
38016       DO 61 IIG=2,2+IIGLU1-1
38017         KKG=JJG+IIG-1
38018         IDHKT(IIG)   =IDHKK(KKG)
38019         ISTHKT(IIG)  =921
38020         JMOHKT(1,IIG)=KKG
38021         JMOHKT(2,IIG)=0
38022         JDAHKT(1,IIG)=3+IIGLU1
38023         JDAHKT(2,IIG)=0
38024         PHKT(1,IIG)=PHKK(1,KKG)
38025         PG1=PG1+ PHKT(1,IIG)
38026         PHKT(2,IIG)=PHKK(2,KKG)
38027         PG2=PG2+ PHKT(2,IIG)
38028         PHKT(3,IIG)=PHKK(3,KKG)
38029         PG3=PG3+ PHKT(3,IIG)
38030         PHKT(4,IIG)=PHKK(4,KKG)
38031         PG4=PG4+ PHKT(4,IIG)
38032         PHKT(5,IIG)=PHKK(5,KKG)
38033         VHKT(1,IIG)  =VHKK(1,KKG)
38034         VHKT(2,IIG)  =VHKK(2,KKG)
38035         VHKT(3,IIG)  =VHKK(3,KKG)
38036         VHKT(4,IIG)  =VHKK(4,KKG)
38037         WHKT(1,IIG)  =WHKK(1,KKG)
38038         WHKT(2,IIG)  =WHKK(2,KKG)
38039         WHKT(3,IIG)  =WHKK(3,KKG)
38040         WHKT(4,IIG)  =WHKK(4,KKG)
38041    61 CONTINUE
38042       ENDIF
38043 C     IDHKT(2)   =IP21
38044       IDHKT(2+IIGLU1)   =KK11
38045       ISTHKT(2+IIGLU1)  =962
38046       JMOHKT(1,2+IIGLU1)=NC1T
38047       JMOHKT(2,2+IIGLU1)=0
38048       JDAHKT(1,2+IIGLU1)=3+IIGLU1
38049       JDAHKT(2,2+IIGLU1)=0
38050       PHKT(1,2+IIGLU1)  =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
38051 C    * +0.5D0*PHKK(1,NC2T)
38052      *+XGIVE*PHKT(1,5+IIGLU1)
38053       PHKT(2,2+IIGLU1)  =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
38054 C    *+0.5D0*PHKK(2,NC2T)
38055      *+XGIVE*PHKT(2,5+IIGLU1)
38056       PHKT(3,2+IIGLU1)  =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
38057 C    *+0.5D0*PHKK(3,NC2T)
38058      *+XGIVE*PHKT(3,5+IIGLU1)
38059       PHKT(4,2+IIGLU1)  =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
38060 C    *+0.5D0*PHKK(4,NC2T)
38061      *+XGIVE*PHKT(4,5+IIGLU1)
38062 C     PHKT(5,2)  =PHKK(5,NC1T)
38063       XXMIST=(PHKT(4,2+IIGLU1)**2-
38064      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38065      *PHKT(1,2+IIGLU1)**2)
38066       IF(XXMIST.GT.0.D0)THEN
38067         PHKT(5,2+IIGLU1)  =SQRT(XXMIST)
38068       ELSE
38069         WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
38070         XXMIST=ABS(XXMIST)
38071         PHKT(5,2+IIGLU1)  =SQRT(XXMIST)
38072       ENDIF
38073       VHKT(1,2+IIGLU1)  =VHKK(1,NC1T)
38074       VHKT(2,2+IIGLU1)  =VHKK(2,NC1T)
38075       VHKT(3,2+IIGLU1)  =VHKK(3,NC1T)
38076       VHKT(4,2+IIGLU1)  =VHKK(4,NC1T)
38077       WHKT(1,2+IIGLU1)  =WHKK(1,NC1T)
38078       WHKT(2,2+IIGLU1)  =WHKK(2,NC1T)
38079       WHKT(3,2+IIGLU1)  =WHKK(3,NC1T)
38080       WHKT(4,2+IIGLU1)  =WHKK(4,NC1T)
38081       IDHKT(3+IIGLU1)   =88888
38082       ISTHKT(3+IIGLU1)  =96
38083       JMOHKT(1,3+IIGLU1)=1
38084       JMOHKT(2,3+IIGLU1)=2+IIGLU1
38085       JDAHKT(1,3+IIGLU1)=0
38086       JDAHKT(2,3+IIGLU1)=0
38087       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38088       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38089       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38090       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38091       PHKT(5,3+IIGLU1)
38092      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38093      *            -PHKT(3,3+IIGLU1)**2)
38094       IF(IPIP.EQ.3)THEN
38095       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
38096      * JDAHKT(1,1),
38097      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38098       DO 71 IIG=2,2+IIGLU1-1
38099       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38100      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38101      * JDAHKT(1,IIG),
38102      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38103    71 CONTINUE
38104       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
38105      * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38106      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38107       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38108      * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38109      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38110       ENDIF
38111       CHAMAL=CHAB1
38112       IF(IPIP.EQ.1)THEN
38113         IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
38114       ELSEIF(IPIP.EQ.2)THEN
38115         IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
38116       ENDIF
38117       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38118 C       IREJ=1
38119         IPCO=0
38120 C       RETURN
38121         GO TO 3466
38122       ENDIF
38123       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
38124       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
38125       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
38126       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
38127       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
38128       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
38129       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
38130       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
38131 C     IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ+1
38132       IDHKT(7+IIGLU1)   =IP1
38133       ISTHKT(7+IIGLU1)  =961
38134       JMOHKT(1,7+IIGLU1)=NC1P
38135       JMOHKT(2,7+IIGLU1)=0
38136       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38137       JDAHKT(2,7+IIGLU1)=0
38138       PHKT(1,7+IIGLU1)  =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
38139       PHKT(2,7+IIGLU1)  =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
38140       PHKT(3,7+IIGLU1)  =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
38141       PHKT(4,7+IIGLU1)  =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
38142 C     PHKT(5,7+IIGLU1)  =PHKK(5,NC1P)
38143       XXMIST=(PHKT(4,7+IIGLU1)**2-
38144      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38145      *PHKT(1,7+IIGLU1)**2)
38146       IF(XXMIST.GT.0.D0)THEN
38147         PHKT(5,7+IIGLU1)  =SQRT(XXMIST)
38148       ELSE
38149         WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
38150         XXMIST=ABS(XXMIST)
38151         PHKT(5,7+IIGLU1)  =SQRT(XXMIST)
38152       ENDIF
38153       VHKT(1,7+IIGLU1)  =VHKK(1,NC1P)
38154       VHKT(2,7+IIGLU1)  =VHKK(2,NC1P)
38155       VHKT(3,7+IIGLU1)  =VHKK(3,NC1P)
38156       VHKT(4,7+IIGLU1)  =VHKK(4,NC1P)
38157       WHKT(1,7+IIGLU1)  =WHKK(1,NC1P)
38158       WHKT(2,7+IIGLU1)  =WHKK(2,NC1P)
38159       WHKT(3,7+IIGLU1)  =WHKK(3,NC1P)
38160       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
38161 C     IDHKT(7)   =1000*IPP1+100*ISQ+1
38162 C     Insert here the IIGLU2 gluons
38163       PG1=0.D0
38164       PG2=0.D0
38165       PG3=0.D0
38166       PG4=0.D0
38167       IF(IIGLU2.GE.1)THEN
38168       JJG=NC2P
38169       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38170         KKG=JJG+IIG-7-IIGLU1
38171         IDHKT(IIG)   =IDHKK(KKG)
38172         ISTHKT(IIG)  =921
38173         JMOHKT(1,IIG)=KKG
38174         JMOHKT(2,IIG)=0
38175         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38176         JDAHKT(2,IIG)=0
38177         PHKT(1,IIG)=PHKK(1,KKG)
38178         PG1=PG1+ PHKT(1,IIG)
38179         PHKT(2,IIG)=PHKK(2,KKG)
38180         PG2=PG2+ PHKT(2,IIG)
38181         PHKT(3,IIG)=PHKK(3,KKG)
38182         PG3=PG3+ PHKT(3,IIG)
38183         PHKT(4,IIG)=PHKK(4,KKG)
38184         PG4=PG4+ PHKT(4,IIG)
38185         PHKT(5,IIG)=PHKK(5,KKG)
38186         VHKT(1,IIG)  =VHKK(1,KKG)
38187         VHKT(2,IIG)  =VHKK(2,KKG)
38188         VHKT(3,IIG)  =VHKK(3,KKG)
38189         VHKT(4,IIG)  =VHKK(4,KKG)
38190         WHKT(1,IIG)  =WHKK(1,KKG)
38191         WHKT(2,IIG)  =WHKK(2,KKG)
38192         WHKT(3,IIG)  =WHKK(3,KKG)
38193         WHKT(4,IIG)  =WHKK(4,KKG)
38194    81 CONTINUE
38195       ENDIF
38196       IF(IPIP.EQ.1)THEN
38197         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*ISQ1+3
38198         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
38199         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
38200         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
38201       ELSEIF(IPIP.EQ.2)THEN
38202 **NEW
38203 C       IDHKT(8)   =1000*IPP2+100*(-ISQ1+6)-3
38204         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*(-ISQ1+6)-3
38205 **
38206         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
38207         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
38208         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
38209       ENDIF
38210       ISTHKT(8+IIGLU1+IIGLU2)  =962
38211       JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
38212       JMOHKT(2,8+IIGLU1+IIGLU2)=0
38213       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38214       JDAHKT(2,8+IIGLU1+IIGLU2)=0
38215 C     PHKT(1,8)  =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
38216 C     PHKT(2,8)  =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
38217 C     PHKT(3,8)  =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
38218 C     PHKT(4,8)  =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
38219       PHKT(1,8+IIGLU1+IIGLU2)  =
38220      * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
38221       PHKT(2,8+IIGLU1+IIGLU2)  =
38222      * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
38223       PHKT(3,8+IIGLU1+IIGLU2)  =
38224      * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
38225       PHKT(4,8+IIGLU1+IIGLU2)  =
38226      * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
38227 C     WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
38228 C    * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
38229       IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
38230 C       IREJ=1
38231 C       WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
38232         IPCO=0
38233 C       RETURN
38234         GO TO 3466
38235       ENDIF
38236 C     PHKT(5,8)  =PHKK(5,NC2T)
38237       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38238      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38239      *PHKT(1,8+IIGLU1+IIGLU2)**2)
38240       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC2T)
38241       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC2T)
38242       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC2T)
38243       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC2T)
38244       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC2T)
38245       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC2T)
38246       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC2T)
38247       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC2T)
38248       IDHKT(9+IIGLU1+IIGLU2)   =88888
38249       ISTHKT(9+IIGLU1+IIGLU2)  =96
38250       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38251       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38252       JDAHKT(1,9+IIGLU1+IIGLU2)=0
38253       JDAHKT(2,9+IIGLU1+IIGLU2)=0
38254       PHKT(1,9+IIGLU1+IIGLU2)
38255      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
38256       PHKT(2,9+IIGLU1+IIGLU2)
38257      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
38258       PHKT(3,9+IIGLU1+IIGLU2)
38259      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
38260       PHKT(4,9+IIGLU1+IIGLU2)
38261      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
38262       PHKT(5,9+IIGLU1+IIGLU2)
38263      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
38264      * PHKT(2,9+IIGLU1+IIGLU2)**2
38265      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
38266       IF(IPIP.GE.3)THEN
38267       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38268      * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38269      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38270       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38271       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38272      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38273      * JDAHKT(1,IIG),
38274      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38275    91 CONTINUE
38276       WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
38277      * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
38278      *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
38279      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38280       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38281      * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
38282      *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
38283      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38284       ENDIF
38285       CHAMAL=CHAB1
38286       IF(IPIP.EQ.1)THEN
38287         IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38288       ELSEIF(IPIP.EQ.2)THEN
38289         IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38290       ENDIF
38291       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38292 C       IREJ=1
38293         IPCO=0
38294 C       RETURN
38295         GO TO 3466
38296       ENDIF
38297       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
38298       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
38299       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
38300       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
38301       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
38302       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
38303       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
38304       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
38305 C
38306       IPCO=0
38307       IGCOUN=9+IIGLU1+IIGLU2
38308        RETURN
38309        END
38310
38311 *$ CREATE MUSQBS1.FOR
38312 *COPY MUSQBS1
38313 C
38314 C
38315 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38316       SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38317      *              IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
38318 C
38319 C                  USQBS-1 diagram (split projectile diquark)
38320 C
38321       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38322       SAVE
38323
38324       PARAMETER ( LINP = 10 ,
38325      &            LOUT = 6 ,
38326      &            LDAT = 9 )
38327 * event history
38328       PARAMETER (NMXHKK=200000)
38329       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38330      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38331      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38332 * extended event history
38333       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38334      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38335      &                IHIST(2,NMXHKK)
38336 * Lorentz-parameters of the current interaction
38337       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
38338      &                UMO,PPCM,EPROJ,PPROJ
38339 * diquark-breaking mechanism
38340       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
38341
38342 C
38343       PARAMETER (NTMHKK= 300)
38344       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38345      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38346      +(4,NTMHKK)
38347 *KEEP,XSEADI.
38348       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
38349      +SSMIMQ,VVMTHR
38350 *KEEP,DPRIN.
38351       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
38352       COMMON /EVFLAG/ NUMEV
38353 C
38354 C                  USQBS-1 diagram (split projectile diquark)
38355 C
38356 C     Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
38357 C     Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
38358 C
38359 C     Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
38360 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
38361 C
38362 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38363 C                   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38364 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38365 C
38366 C       Put new chains into COMMON /HKKTMP/
38367 C
38368       IIGLU1=NC1T-NC1P-1
38369       IIGLU2=NC2T-NC2P-1
38370       IGCOUN=0
38371 C     WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
38372       CVQ=1.D0
38373       IREJ=0
38374       IF(IPIP.EQ.3)THEN
38375 C     IF(NUMEV.EQ.-324)THEN
38376       WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
38377      *             ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
38378      *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38379      *              IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
38380       ENDIF
38381 C
38382 C
38383 C
38384 C     determine x-values of NC1P diquark
38385       XDIQP=PHKK(4,NC1P)*2.D0/UMO
38386       XVQT=PHKK(4,NC1T)*2.D0/UMO
38387 C
38388 C     determine x-values of sea quark pair
38389 C
38390       IPCO=1
38391       ICOU=0
38392  2234 CONTINUE
38393       ICOU=ICOU+1
38394       IF(ICOU.GE.500)THEN
38395         IREJ=1
38396         IF(ISQ.EQ.3)IREJ=3
38397         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
38398         IPCO=0
38399         RETURN
38400       ENDIF
38401       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call  XSEAPA: UMO,XDIQP,XVQT ',
38402      * UMO, XDIQP,XVQT
38403       XSQ=0.D0
38404       XSAQ=0.D0
38405 **NEW
38406 C     CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
38407       IF (IPIP.EQ.1) THEN
38408          XQMAX  = XDIQP/2.0D0
38409          XAQMAX = 2.D0*XVQT/3.0D0
38410       ELSE
38411          XQMAX  = 2.D0*XVQT/3.0D0
38412          XAQMAX = XDIQP/2.0D0
38413       ENDIF
38414       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
38415       ISAQ = 6+ISQ
38416 C     write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
38417 **
38418       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
38419       IF(IREJ.GE.1)THEN
38420         IF(IPCO.GE.3)
38421      &     WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
38422         IPCO=0
38423         RETURN
38424       ENDIF
38425       IF(IPIP.EQ.1)THEN
38426         IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
38427       ELSEIF(IPIP.EQ.2)THEN
38428         IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
38429       ENDIF
38430       IF(IPCO.GE.3)THEN
38431         WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
38432      *  XDIQP,XVQT,XSQ,XSAQ
38433       ENDIF
38434 C
38435 C     subtract xsq,xsaq from NC1P diquark and NC1T quark
38436 C
38437 C     XSQ=0.D0
38438       IF(IPIP.EQ.1)THEN
38439         XDIQP=XDIQP-XSQ
38440         XVQT =XVQT -XSAQ
38441       ELSEIF(IPIP.EQ.2)THEN
38442         XDIQP=XDIQP-XSAQ
38443         XVQT =XVQT -XSQ
38444       ENDIF
38445       IF(IPCO.GE.3)
38446      &   WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
38447 C
38448 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
38449 C
38450       XVTHRO=CVQ/UMO
38451       IVTHR=0
38452  3466 CONTINUE
38453       IF(IVTHR.EQ.10)THEN
38454         IREJ=1
38455         IF(ISQ.EQ.3)IREJ=3
38456         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
38457         IPCO=0
38458         RETURN
38459       ENDIF
38460       IVTHR=IVTHR+1
38461       XVTHR=XVTHRO/(201-IVTHR)
38462       UNOPRV=UNON
38463  380  CONTINUE
38464       IF(XVTHR.GT.0.66D0*XDIQP)THEN
38465         IREJ=1
38466         IF(ISQ.EQ.3)IREJ=3
38467         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR  large ',
38468      *  XVTHR
38469         IPCO=0
38470         RETURN
38471       ENDIF
38472       IF(DT_RNDM(V).LT.0.5D0)THEN
38473         XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
38474         XVPQII=XDIQP-XVPQI
38475       ELSE
38476         XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
38477         XVPQI=XDIQP-XVPQII
38478       ENDIF
38479       IF(IPCO.GE.3)THEN
38480         WRITE(LOUT,'(A,2E12.4)')'  MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
38481       ENDIF
38482 C
38483 C     Prepare 4 momenta of new chains and chain ends
38484 C
38485 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38486 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38487 C    +(4,NTMHKK)
38488 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38489 C                   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38490 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38491       IF(IPIP.EQ.1)THEN
38492         XSQ1=XSQ
38493         XSAQ1=XSAQ
38494         ISQ1=ISQ
38495         ISAQ1=ISAQ
38496       ELSEIF(IPIP.EQ.2)THEN
38497         XSQ1=XSAQ
38498         XSAQ1=XSQ
38499         ISQ1=ISAQ
38500         ISAQ1=ISQ
38501       ENDIF
38502       IDHKT(1)   =IP11
38503       ISTHKT(1)  =931
38504       JMOHKT(1,1)=NC1P
38505       JMOHKT(2,1)=0
38506       JDAHKT(1,1)=3+IIGLU1
38507       JDAHKT(2,1)=0
38508 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
38509       PHKT(1,1)  =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
38510       PHKT(2,1)  =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
38511       PHKT(3,1)  =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
38512       PHKT(4,1)  =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
38513 C     PHKT(5,1)  =PHKK(5,NC1P)
38514       XMIST  =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38515      *PHKT(1,1)**2)
38516       IF(XMIST.GE.0.D0)THEN
38517       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38518      *PHKT(1,1)**2)
38519       ELSE
38520 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38521        PHKT(5,1)=0.D0
38522       ENDIF
38523       VHKT(1,1)  =VHKK(1,NC1P)
38524       VHKT(2,1)  =VHKK(2,NC1P)
38525       VHKT(3,1)  =VHKK(3,NC1P)
38526       VHKT(4,1)  =VHKK(4,NC1P)
38527       WHKT(1,1)  =WHKK(1,NC1P)
38528       WHKT(2,1)  =WHKK(2,NC1P)
38529       WHKT(3,1)  =WHKK(3,NC1P)
38530       WHKT(4,1)  =WHKK(4,NC1P)
38531 C     Add here IIGLU1 gluons to this chaina
38532       PG1=0.D0
38533       PG2=0.D0
38534       PG3=0.D0
38535       PG4=0.D0
38536       IF(IIGLU1.GE.1)THEN
38537       JJG=NC1P
38538       DO 61 IIG=2,2+IIGLU1-1
38539         KKG=JJG+IIG-1
38540         IDHKT(IIG)   =IDHKK(KKG)
38541         ISTHKT(IIG)  =921
38542         JMOHKT(1,IIG)=KKG
38543         JMOHKT(2,IIG)=0
38544         JDAHKT(1,IIG)=3+IIGLU1
38545         JDAHKT(2,IIG)=0
38546         PHKT(1,IIG)=PHKK(1,KKG)
38547         PG1=PG1+ PHKT(1,IIG)
38548         PHKT(2,IIG)=PHKK(2,KKG)
38549         PG2=PG2+ PHKT(2,IIG)
38550         PHKT(3,IIG)=PHKK(3,KKG)
38551         PG3=PG3+ PHKT(3,IIG)
38552         PHKT(4,IIG)=PHKK(4,KKG)
38553         PG4=PG4+ PHKT(4,IIG)
38554         PHKT(5,IIG)=PHKK(5,KKG)
38555         VHKT(1,IIG)  =VHKK(1,KKG)
38556         VHKT(2,IIG)  =VHKK(2,KKG)
38557         VHKT(3,IIG)  =VHKK(3,KKG)
38558         VHKT(4,IIG)  =VHKK(4,KKG)
38559         WHKT(1,IIG) =WHKK(1,KKG)
38560         WHKT(2,IIG) =WHKK(2,KKG)
38561         WHKT(3,IIG) =WHKK(3,KKG)
38562         WHKT(4,IIG) =WHKK(4,KKG)
38563    61 CONTINUE
38564       ENDIF
38565       IDHKT(2+IIGLU1)   =IPP2
38566       ISTHKT(2+IIGLU1)  =932
38567       JMOHKT(1,2+IIGLU1)=NC2T
38568       JMOHKT(2,2+IIGLU1)=0
38569       JDAHKT(1,2+IIGLU1)=3+IIGLU1
38570       JDAHKT(2,2+IIGLU1)=0
38571       PHKT(1,2+IIGLU1)  =PHKK(1,NC2T)
38572       PHKT(2,2+IIGLU1)  =PHKK(2,NC2T)
38573       PHKT(3,2+IIGLU1)  =PHKK(3,NC2T)
38574       PHKT(4,2+IIGLU1)  =PHKK(4,NC2T)
38575 C     PHKT(5,2+IIGLU1)  =PHKK(5,NC2T)
38576       XMIST=(PHKT(4,2+IIGLU1)**2-
38577      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38578      *PHKT(1,2+IIGLU1)**2)
38579       IF(XMIST.GT.0.D0)THEN
38580       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
38581      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38582      *PHKT(1,2+IIGLU1)**2)
38583       ELSE
38584 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38585         PHKT(5,2+IIGLU1)=0.D0
38586       ENDIF
38587       VHKT(1,2+IIGLU1)  =VHKK(1,NC2T)
38588       VHKT(2,2+IIGLU1)  =VHKK(2,NC2T)
38589       VHKT(3,2+IIGLU1)  =VHKK(3,NC2T)
38590       VHKT(4,2+IIGLU1)  =VHKK(4,NC2T)
38591       WHKT(1,2+IIGLU1)  =WHKK(1,NC2T)
38592       WHKT(2,2+IIGLU1)  =WHKK(2,NC2T)
38593       WHKT(3,2+IIGLU1)  =WHKK(3,NC2T)
38594       WHKT(4,2+IIGLU1)  =WHKK(4,NC2T)
38595       IDHKT(3+IIGLU1)   =88888
38596       ISTHKT(3+IIGLU1)  =94
38597       JMOHKT(1,3+IIGLU1)=1
38598       JMOHKT(2,3+IIGLU1)=2+IIGLU1
38599       JDAHKT(1,3+IIGLU1)=0
38600       JDAHKT(2,3+IIGLU1)=0
38601       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38602       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38603       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38604       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38605       XMIST
38606      * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38607      *            -PHKT(3,3+IIGLU1)**2)
38608       IF(XMIST.GE.0.D0)THEN
38609       PHKT(5,3+IIGLU1)
38610      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38611      *            -PHKT(3,3+IIGLU1)**2)
38612       ELSE
38613 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38614        PHKT(5,1)=0.D0
38615       ENDIF
38616       IF(IPIP.GE.3)THEN
38617 C     IF(NUMEV.EQ.-324)THEN
38618       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
38619      * JMOHKT(2,1),JDAHKT(1,1),
38620      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38621       DO 71 IIG=2,2+IIGLU1-1
38622       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38623      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38624      * JDAHKT(1,IIG),
38625      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38626    71 CONTINUE
38627       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
38628      * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38629      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38630       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38631      * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38632      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38633       ENDIF
38634       CHAMAL=CHAM1
38635       IF(IPIP.EQ.1)THEN
38636         IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
38637       ELSEIF(IPIP.EQ.2)THEN
38638         IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
38639       ENDIF
38640       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38641 C       IREJ=1
38642         IPCO=0
38643 C       RETURN
38644 C       WRITE(6,*)' MUSQBS1 jump back from chain 3'
38645         GO TO 3466
38646       ENDIF
38647       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
38648       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
38649       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
38650       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
38651       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
38652       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
38653       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
38654       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
38655       IDHKT(4+IIGLU1)   =IP12
38656       ISTHKT(4+IIGLU1)  =931
38657       JMOHKT(1,4+IIGLU1)=NC1P
38658       JMOHKT(2,4+IIGLU1)=0
38659       JDAHKT(1,4+IIGLU1)=6+IIGLU1
38660       JDAHKT(2,4+IIGLU1)=0
38661 C   create  chain   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
38662       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
38663       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
38664       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
38665       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
38666 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
38667       XMIST  =(PHKT(4,4+IIGLU1)**2-
38668      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
38669      *PHKT(1,4+IIGLU1)**2)
38670       IF(XMIST.GT.0.D0)THEN
38671       PHKT(5,4+IIGLU1)  =SQRT(PHKT(4,4+IIGLU1)**2-
38672      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
38673      *PHKT(1,4+IIGLU1)**2)
38674       ELSE
38675 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38676         PHKT(5,4+IIGLU1)=0.D0
38677       ENDIF
38678       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
38679       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
38680       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
38681       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
38682       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
38683       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
38684       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
38685       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
38686       IF(IPIP.EQ.1)THEN
38687         IDHKT(5+IIGLU1)   =-(ISAQ1-6)
38688       ELSEIF(IPIP.EQ.2)THEN
38689         IDHKT(5+IIGLU1)   =ISAQ1
38690       ENDIF
38691       ISTHKT(5+IIGLU1)  =932
38692       JMOHKT(1,5+IIGLU1)=NC1T
38693       JMOHKT(2,5+IIGLU1)=0
38694       JDAHKT(1,5+IIGLU1)=6+IIGLU1
38695       JDAHKT(2,5+IIGLU1)=0
38696       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
38697       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
38698       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
38699       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
38700 C     IF( PHKT(4,5).EQ.0.D0)THEN
38701 C       IREJ=1
38702 CIPCO=0
38703 CRETURN
38704 C     ENDIF
38705 C     PHKT(5,5)  =PHKK(5,NC1T)
38706       XMIST=(PHKT(4,5+IIGLU1)**2-
38707      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
38708      *PHKT(1,5+IIGLU1)**2)
38709       IF(XMIST.GT.0.D0)THEN
38710       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
38711      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
38712      *PHKT(1,5+IIGLU1)**2)
38713       ELSE
38714 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38715         PHKT(5,5+IIGLU1)=0.D0
38716       ENDIF
38717       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
38718       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
38719       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
38720       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
38721       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
38722       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
38723       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
38724       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
38725       IDHKT(6+IIGLU1)   =88888
38726       ISTHKT(6+IIGLU1)  =94
38727       JMOHKT(1,6+IIGLU1)=4+IIGLU1
38728       JMOHKT(2,6+IIGLU1)=5+IIGLU1
38729       JDAHKT(1,6+IIGLU1)=0
38730       JDAHKT(2,6+IIGLU1)=0
38731       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
38732       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
38733       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
38734       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
38735       XMIST
38736      * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
38737      *            -PHKT(3,6+IIGLU1)**2)
38738       IF(XMIST.GE.0.D0)THEN
38739       PHKT(5,6+IIGLU1)
38740      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
38741      *            -PHKT(3,6+IIGLU1)**2)
38742       ELSE
38743 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38744        PHKT(5,1)=0.D0
38745       ENDIF
38746 C     IF(IPIP.EQ.3)THEN
38747       CHAMAL=CHAM1
38748       IF(IPIP.EQ.1)THEN
38749         IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
38750       ELSEIF(IPIP.EQ.2)THEN
38751         IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
38752       ENDIF
38753       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
38754 C       IREJ=1
38755         IPCO=0
38756 C       RETURN
38757 C       WRITE(6,*)' MGSQBS1 jump back from chain 6',
38758 C    *  CHAMAL,PHKT(5,6+IIGLU1)
38759         GO TO 3466
38760       ENDIF
38761       IF(IPIP.GE.3)THEN
38762 C     IF(NUMEV.EQ.-324)THEN
38763       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
38764      * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
38765      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
38766       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
38767      * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
38768      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
38769       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
38770      * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
38771      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
38772       ENDIF
38773       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
38774       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
38775       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
38776       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
38777       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
38778       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
38779       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
38780       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
38781       IF(IPIP.EQ.1)THEN
38782         IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ+3
38783         IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
38784         IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
38785         IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
38786       ELSEIF(IPIP.EQ.2)THEN
38787         IDHKT(7+IIGLU1)   =1000*IPP1+100*(-ISQ1+6)-3
38788         IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
38789         IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
38790         IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
38791 C       WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
38792       ENDIF
38793       ISTHKT(7+IIGLU1)  =931
38794       JMOHKT(1,7+IIGLU1)=NC2P
38795       JMOHKT(2,7+IIGLU1)=0
38796       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38797       JDAHKT(2,7+IIGLU1)=0
38798 C    create chain     9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
38799       PHKT(1,7+IIGLU1)  =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
38800       PHKT(2,7+IIGLU1)  =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
38801       PHKT(3,7+IIGLU1)  =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
38802       PHKT(4,7+IIGLU1)  =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
38803 C     WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
38804 C    * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
38805       IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
38806 C       IREJ=1
38807 C       WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
38808         IPCO=0
38809 C       RETURN
38810         GO TO 3466
38811       ENDIF
38812 C     PHKT(5,7)  =PHKK(5,NC2P)
38813       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
38814      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38815      *PHKT(1,7+IIGLU1)**2)
38816       VHKT(1,7+IIGLU1)  =VHKK(1,NC2P)
38817       VHKT(2,7+IIGLU1)  =VHKK(2,NC2P)
38818       VHKT(3,7+IIGLU1)  =VHKK(3,NC2P)
38819       VHKT(4,7+IIGLU1)  =VHKK(4,NC2P)
38820       WHKT(1,7+IIGLU1)  =WHKK(1,NC2P)
38821       WHKT(2,7+IIGLU1)  =WHKK(2,NC2P)
38822       WHKT(3,7+IIGLU1)  =WHKK(3,NC2P)
38823       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
38824 C     Insert here the IIGLU2 gluons
38825       PG1=0.D0
38826       PG2=0.D0
38827       PG3=0.D0
38828       PG4=0.D0
38829       IF(IIGLU2.GE.1)THEN
38830       JJG=NC2P
38831       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38832         KKG=JJG+IIG-7-IIGLU1
38833         IDHKT(IIG)   =IDHKK(KKG)
38834         ISTHKT(IIG)  =921
38835         JMOHKT(1,IIG)=KKG
38836         JMOHKT(2,IIG)=0
38837         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38838         JDAHKT(2,IIG)=0
38839         PHKT(1,IIG)=PHKK(1,KKG)
38840         PG1=PG1+ PHKT(1,IIG)
38841         PHKT(2,IIG)=PHKK(2,KKG)
38842         PG2=PG2+ PHKT(2,IIG)
38843         PHKT(3,IIG)=PHKK(3,KKG)
38844         PG3=PG3+ PHKT(3,IIG)
38845         PHKT(4,IIG)=PHKK(4,KKG)
38846         PG4=PG4+ PHKT(4,IIG)
38847         PHKT(5,IIG)=PHKK(5,KKG)
38848         VHKT(1,IIG)  =VHKK(1,KKG)
38849         VHKT(2,IIG)  =VHKK(2,KKG)
38850         VHKT(3,IIG)  =VHKK(3,KKG)
38851         VHKT(4,IIG)  =VHKK(4,KKG)
38852         WHKT(1,IIG)  =WHKK(1,KKG)
38853         WHKT(2,IIG) =WHKK(2,KKG)
38854         WHKT(3,IIG) =WHKK(3,KKG)
38855         WHKT(4,IIG) =WHKK(4,KKG)
38856    81 CONTINUE
38857       ENDIF
38858       IDHKT(8+IIGLU1+IIGLU2)   =IP2
38859       ISTHKT(8+IIGLU1+IIGLU2)  =932
38860       JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
38861       JMOHKT(2,8+IIGLU1+IIGLU2)=0
38862       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38863       JDAHKT(2,8+IIGLU1+IIGLU2)=0
38864       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
38865       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
38866       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
38867       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
38868 C     PHKT(5,8+IIGLU1+IIGLU2)  =PHKK(5,NC1T)
38869       XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
38870      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38871      *PHKT(1,8+IIGLU1+IIGLU2)**2)
38872       IF(XMIST.GT.0.D0)THEN
38873       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38874      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38875      *PHKT(1,8+IIGLU1+IIGLU2)**2)
38876       ELSE
38877 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
38878         PHKT(5,8+IIGLU1+IIGLU2)=0.D0
38879       ENDIF
38880       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC1T)
38881       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC1T)
38882       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC1T)
38883       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC1T)
38884       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC1T)
38885       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC1T)
38886       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC1T)
38887       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC1T)
38888       IDHKT(9+IIGLU1+IIGLU2)   =88888
38889       ISTHKT(9+IIGLU1+IIGLU2)  =94
38890       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38891       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38892       JDAHKT(1,9+IIGLU1+IIGLU2)=0
38893       JDAHKT(2,9+IIGLU1+IIGLU2)=0
38894       PHKT(1,9+IIGLU1+IIGLU2)
38895      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
38896       PHKT(2,9+IIGLU1+IIGLU2)
38897      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
38898       PHKT(3,9+IIGLU1+IIGLU2)
38899      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
38900       PHKT(4,9+IIGLU1+IIGLU2)
38901      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
38902       XMIST
38903      *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
38904      * -PHKT(2,9+IIGLU1+IIGLU2)**2
38905      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
38906       IF(XMIST.GE.0.D0)THEN
38907       PHKT(5,9+IIGLU1+IIGLU2)
38908      *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
38909      * -PHKT(2,9+IIGLU1+IIGLU2)**2
38910      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
38911       ELSE
38912 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
38913        PHKT(5,1)=0.D0
38914       ENDIF
38915       IF(IPIP.GE.3)THEN
38916 C     IF(NUMEV.EQ.-324)THEN
38917       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38918      * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38919      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38920       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38921       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38922      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38923      * JDAHKT(1,IIG),
38924      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38925    91 CONTINUE
38926       WRITE(LOUT,*)8+IIGLU1+IIGLU2,
38927      * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
38928      * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
38929      *JDAHKT(1,8+IIGLU1+IIGLU2),
38930      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38931       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38932      * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
38933      *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
38934      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38935       ENDIF
38936       CHAMAL=CHAB1
38937       IF(IPIP.EQ.1)THEN
38938         IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38939       ELSEIF(IPIP.EQ.2)THEN
38940         IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38941       ENDIF
38942       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38943 C       IREJ=1
38944         IPCO=0
38945 C       RETURN
38946 C       WRITE(6,*)' MGSQBS1 jump back from chain 9',
38947 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
38948         GO TO 3466
38949       ENDIF
38950       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
38951       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
38952       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
38953       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
38954       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
38955       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
38956       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
38957       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
38958 C
38959       IPCO=0
38960       IGCOUN=9+IIGLU1+IIGLU2
38961        RETURN
38962        END
38963
38964 *$ CREATE MGSQBS1.FOR
38965 *COPY MGSQBS1
38966 C
38967 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38968       SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
38969      *              IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
38970 C
38971 C                  GSQBS-1 diagram (split projectile diquark)
38972 C
38973       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38974       SAVE
38975
38976       PARAMETER ( LINP = 10 ,
38977      &            LOUT = 6 ,
38978      &            LDAT = 9 )
38979 * event history
38980       PARAMETER (NMXHKK=200000)
38981       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38982      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38983      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38984 * extended event history
38985       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38986      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38987      &                IHIST(2,NMXHKK)
38988 * Lorentz-parameters of the current interaction
38989       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
38990      &                UMO,PPCM,EPROJ,PPROJ
38991 * diquark-breaking mechanism
38992       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
38993
38994 C
38995       PARAMETER (NTMHKK= 300)
38996       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38997      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38998      +(4,NTMHKK)
38999 *KEEP,XSEADI.
39000       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
39001      +SSMIMQ,VVMTHR
39002 *KEEP,DPRIN.
39003       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
39004 C
39005 C                  GSQBS-1 diagram (split projectile diquark)
39006 C
39007 C
39008 C     Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
39009 C     Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
39010 C
39011 C     Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
39012 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
39013 C
39014 C     Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
39015 C                   6 valence quark(vq2P 4)-sea-quark(aqsP 5)
39016 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
39017 C
39018 C       Put new chains into COMMON /HKKTMP/
39019 C
39020       IIGLU1=NC1T-NC1P-1
39021       IIGLU2=NC2T-NC2P-1
39022       IGCOUN=0
39023 C     WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
39024       CVQ=1.D0
39025       NNNC1=IDHKK(NC1)/1000
39026       MMMC1=IDHKK(NC1)-NNNC1*1000
39027       KKKC1=ISTHKK(NC1)
39028       NNNC2=IDHKK(NC2)/1000
39029       MMMC2=IDHKK(NC2)-NNNC2*1000
39030       KKKC2=ISTHKK(NC2)
39031       IREJ=0
39032       IF(IPIP.EQ.3)THEN
39033       WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
39034      *             ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
39035      *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
39036      *              IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
39037       ENDIF
39038 C
39039 C
39040 C
39041 C     determine x-values of NC1P diquark
39042       XDIQP=PHKK(4,NC1P)*2.D0/UMO
39043       XVQT=PHKK(4,NC1T)*2.D0/UMO
39044 C
39045 C     determine x-values of sea quark pair
39046 C
39047       IPCO=1
39048       ICOU=0
39049  2234 CONTINUE
39050       ICOU=ICOU+1
39051       IF(ICOU.GE.500)THEN
39052         IREJ=1
39053         IF(ISQ.EQ.3)IREJ=3
39054         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
39055       IPCO=0
39056         RETURN
39057       ENDIF
39058       IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call  XSEAPA: UMO,XDIQP,XVQT ',
39059      * UMO, XDIQP,XVQT
39060       XSQ=0.D0
39061       XSAQ=0.D0
39062 **NEW
39063 C     CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
39064       IF (IPIP.EQ.1) THEN
39065          XQMAX  = XDIQP/2.0D0
39066          XAQMAX = 2.D0*XVQT/3.0D0
39067       ELSE
39068          XQMAX  = 2.D0*XVQT/3.0D0
39069          XAQMAX = XDIQP/2.0D0
39070       ENDIF
39071       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
39072       ISAQ = 6+ISQ
39073 C     write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
39074 **
39075         IF(IPCO.GE.3)
39076      &     WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
39077       IF(IREJ.GE.1)THEN
39078         IF(IPCO.GE.3)
39079      &     WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
39080       IPCO=0
39081         RETURN
39082       ENDIF
39083       IF(IPIP.EQ.1)THEN
39084         IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
39085       ELSEIF(IPIP.EQ.2)THEN
39086         IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
39087       ENDIF
39088       IF(IPCO.GE.3)THEN
39089         WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
39090      *  XDIQP,XVQT,XSQ,XSAQ
39091       ENDIF
39092 C
39093 C     subtract xsq,xsaq from NC1P diquark and NC1T quark
39094 C
39095 C     XSQ=0.D0
39096       IF(IPIP.EQ.1)THEN
39097         XDIQP=XDIQP-XSQ
39098 **NEW
39099 C       IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
39100 **
39101         XVQT =XVQT -XSAQ
39102       ELSEIF(IPIP.EQ.2)THEN
39103         XDIQP=XDIQP-XSAQ
39104         XVQT =XVQT -XSQ
39105       ENDIF
39106       IF(IPCO.GE.3)
39107      &   WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
39108 C
39109 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
39110 C
39111       XVTHRO=CVQ/UMO
39112       IVTHR=0
39113  3466 CONTINUE
39114       IF(IVTHR.EQ.10)THEN
39115         IREJ=1
39116         IF(ISQ.EQ.3)IREJ=3
39117         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
39118       IPCO=0
39119         RETURN
39120       ENDIF
39121       IVTHR=IVTHR+1
39122       XVTHR=XVTHRO/(201-IVTHR)
39123       UNOPRV=UNON
39124  380  CONTINUE
39125       IF(XVTHR.GT.0.66D0*XDIQP)THEN
39126         IREJ=1
39127         IF(ISQ.EQ.3)IREJ=3
39128         IF(IPCO.GE.3)
39129      &     WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR  large ',
39130      *  XVTHR
39131       IPCO=0
39132         RETURN
39133       ENDIF
39134       IF(DT_RNDM(V).LT.0.5D0)THEN
39135         XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
39136         XVPQII=XDIQP-XVPQI
39137       ELSE
39138         XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
39139         XVPQI=XDIQP-XVPQII
39140       ENDIF
39141       IF(IPCO.GE.3)THEN
39142         WRITE(LOUT,'(A,4E12.4)')'  MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
39143      *  XVTHR,XDIQP,XVPQI,XVPQII
39144       ENDIF
39145 C
39146 C     Prepare 4 momenta of new chains and chain ends
39147 C
39148 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39149 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39150 C    +(4,NTMHKK)
39151 C     Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
39152 C                   6 valence quark(vq2P 4)-sea-quark(aqsP 5)
39153 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
39154       IF(IPIP.EQ.1)THEN
39155         XSQ1=XSQ
39156         XSAQ1=XSAQ
39157         ISQ1=ISQ
39158         ISAQ1=ISAQ
39159       ELSEIF(IPIP.EQ.2)THEN
39160         XSQ1=XSAQ
39161         XSAQ1=XSQ
39162         ISQ1=ISAQ
39163         ISAQ1=ISQ
39164       ENDIF
39165       KK11=IP11
39166 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
39167       KK21= IPP21
39168       KK22= IPP22
39169       XGIVE=0.D0
39170       IDHKT(4+IIGLU1)   =IP12
39171       ISTHKT(4+IIGLU1)  =921
39172       JMOHKT(1,4+IIGLU1)=NC1P
39173       JMOHKT(2,4+IIGLU1)=0
39174       JDAHKT(1,4+IIGLU1)=6+IIGLU1
39175       JDAHKT(2,4+IIGLU1)=0
39176 **NEW
39177       IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
39178      &    (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
39179 **
39180       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
39181       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
39182       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
39183       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
39184 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
39185       XXMIST=(PHKT(4,4+IIGLU1)**2-
39186      *              PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
39187      *              PHKT(1,4+IIGLU1)**2)
39188       IF(XXMIST.GT.0.D0)THEN
39189         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
39190       ELSE
39191         WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
39192         XXMIST=ABS(XXMIST)
39193         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
39194       ENDIF
39195       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
39196       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
39197       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
39198       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
39199       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
39200       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
39201       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
39202       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
39203       IF(IPIP.EQ.1)THEN
39204         IDHKT(5+IIGLU1)   =-(ISAQ1-6)
39205       ELSEIF(IPIP.EQ.2)THEN
39206         IDHKT(5+IIGLU1)   =ISAQ1
39207       ENDIF
39208       ISTHKT(5+IIGLU1)  =922
39209       JMOHKT(1,5+IIGLU1)=NC1T
39210       JMOHKT(2,5+IIGLU1)=0
39211       JDAHKT(1,5+IIGLU1)=6+IIGLU1
39212       JDAHKT(2,5+IIGLU1)=0
39213 **NEW
39214       IF ((XSAQ1.LT.0.0D0).OR.(XVQT  .LT.0.0D0))
39215      &    WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
39216 **
39217       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
39218       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
39219       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
39220       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
39221 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
39222       XMIST=(PHKT(4,5+IIGLU1)**2-
39223      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
39224      *PHKT(1,5+IIGLU1)**2)
39225       IF(XMIST.GT.0.D0)THEN
39226       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
39227      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
39228      *PHKT(1,5+IIGLU1)**2)
39229       ELSE
39230 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
39231         PHKT(5,5+IIGLU1)=0.D0
39232       ENDIF
39233       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
39234       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
39235       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
39236       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
39237       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
39238       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
39239       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
39240       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
39241       IDHKT(6+IIGLU1)   =88888
39242 C     IDHKT(6)   =1000*NNNC1+MMMC1
39243       ISTHKT(6+IIGLU1)  =93
39244 C     ISTHKT(6)  =KKKC1
39245       JMOHKT(1,6+IIGLU1)=4+IIGLU1
39246       JMOHKT(2,6+IIGLU1)=5+IIGLU1
39247       JDAHKT(1,6+IIGLU1)=0
39248       JDAHKT(2,6+IIGLU1)=0
39249       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
39250       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
39251       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
39252       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
39253       PHKT(5,6+IIGLU1)
39254      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
39255      *            -PHKT(3,6+IIGLU1)**2)
39256       CHAMAL=CHAM1
39257       IF(IPIP.EQ.1)THEN
39258         IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
39259       ELSEIF(IPIP.EQ.2)THEN
39260         IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
39261       ENDIF
39262       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
39263         IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
39264 C                    we drop chain 6 and give the energy to chain 3
39265           IDHKT(6+IIGLU1)=33888
39266           XGIVE=1.D0
39267 C         WRITE(6,*)' drop chain 6 xgive=1'
39268           GO TO 7788
39269         ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
39270 C                    we drop chain 6 and give the energy to chain 3
39271 C                    and change KK11 to IDHKT(4)
39272           IDHKT(6+IIGLU1)=33888
39273           XGIVE=1.D0
39274 C         WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
39275           KK11=IDHKT(4+IIGLU1)
39276           GO TO 7788
39277         ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
39278 C                    we drop chain 6 and give the energy to chain 3
39279 C                    and change KK21 to IDHKT(4)
39280 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
39281           IDHKT(6+IIGLU1)=33888
39282           XGIVE=1.D0
39283 C         WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
39284           KK21=IDHKT(4+IIGLU1)
39285           GO TO 7788
39286         ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
39287 C                    we drop chain 6 and give the energy to chain 3
39288 C                    and change KK22 to IDHKT(4)
39289 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
39290           IDHKT(6+IIGLU1)=33888
39291           XGIVE=1.D0
39292 C         WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
39293           KK22=IDHKT(4+IIGLU1)
39294           GO TO 7788
39295         ENDIF
39296 C       IREJ=1
39297         IPCO=0
39298 C       RETURN
39299 C       WRITE(6,*)' MGSQBS1 jump back from chain 6'
39300         GO TO 3466
39301       ENDIF
39302  7788 CONTINUE
39303       IF(IPIP.GE.3)THEN
39304       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
39305      * JMOHKT(1,4+IIGLU1),
39306      * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
39307      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
39308       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
39309      * JMOHKT(1,5+IIGLU1),
39310      * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
39311      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
39312       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
39313      * JMOHKT(1,6+IIGLU1),
39314      * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
39315      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
39316       ENDIF
39317       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
39318       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
39319       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
39320       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
39321       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
39322       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
39323       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
39324       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
39325 C     IDHKT(1)   =IP11
39326       IDHKT(1)   =KK11
39327       ISTHKT(1)  =921
39328       JMOHKT(1,1)=NC1P
39329       JMOHKT(2,1)=0
39330       JDAHKT(1,1)=3+IIGLU1
39331       JDAHKT(2,1)=0
39332       PHKT(1,1)  =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
39333 C    * +0.5D0*PHKK(1,NC2P)
39334      *+XGIVE*PHKT(1,4+IIGLU1)
39335       PHKT(2,1)  =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
39336 C    * +0.5D0*PHKK(2,NC2P)
39337      *+XGIVE*PHKT(2,4+IIGLU1)
39338       PHKT(3,1)  =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
39339 C    * +0.5D0*PHKK(3,NC2P)
39340      *+XGIVE*PHKT(3,4+IIGLU1)
39341       PHKT(4,1)  =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
39342 C    * +0.5D0*PHKK(4,NC2P)
39343      *+XGIVE*PHKT(4,4+IIGLU1)
39344 C     PHKT(5,1)  =PHKK(5,NC1P)
39345       XMIST  =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
39346      *PHKT(1,1)**2)
39347       IF(XMIST.GE.0.D0)THEN
39348       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
39349      *PHKT(1,1)**2)
39350       ELSE
39351 C      WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
39352        PHKT(5,1)=0.D0
39353       ENDIF
39354       VHKT(1,1)  =VHKK(1,NC1P)
39355       VHKT(2,1)  =VHKK(2,NC1P)
39356       VHKT(3,1)  =VHKK(3,NC1P)
39357       VHKT(4,1)  =VHKK(4,NC1P)
39358       WHKT(1,1)  =WHKK(1,NC1P)
39359       WHKT(2,1)  =WHKK(2,NC1P)
39360       WHKT(3,1)  =WHKK(3,NC1P)
39361       WHKT(4,1)  =WHKK(4,NC1P)
39362 C     Add here IIGLU1 gluons to this chaina
39363       PG1=0.D0
39364       PG2=0.D0
39365       PG3=0.D0
39366       PG4=0.D0
39367       IF(IIGLU1.GE.1)THEN
39368       JJG=NC1P
39369       DO 61 IIG=2,2+IIGLU1-1
39370         KKG=JJG+IIG-1
39371         IDHKT(IIG)   =IDHKK(KKG)
39372         ISTHKT(IIG)  =921
39373         JMOHKT(1,IIG)=KKG
39374         JMOHKT(2,IIG)=0
39375         JDAHKT(1,IIG)=3+IIGLU1
39376         JDAHKT(2,IIG)=0
39377         PHKT(1,IIG)=PHKK(1,KKG)
39378         PG1=PG1+ PHKT(1,IIG)
39379         PHKT(2,IIG)=PHKK(2,KKG)
39380         PG2=PG2+ PHKT(2,IIG)
39381         PHKT(3,IIG)=PHKK(3,KKG)
39382         PG3=PG3+ PHKT(3,IIG)
39383         PHKT(4,IIG)=PHKK(4,KKG)
39384         PG4=PG4+ PHKT(4,IIG)
39385         PHKT(5,IIG)=PHKK(5,KKG)
39386         VHKT(1,IIG)  =VHKK(1,KKG)
39387         VHKT(2,IIG)  =VHKK(2,KKG)
39388         VHKT(3,IIG)  =VHKK(3,KKG)
39389         VHKT(4,IIG)  =VHKK(4,KKG)
39390         WHKT(1,IIG)  =WHKK(1,KKG)
39391         WHKT(2,IIG)  =WHKK(2,KKG)
39392         WHKT(3,IIG)  =WHKK(3,KKG)
39393         WHKT(4,IIG)  =WHKK(4,KKG)
39394    61 CONTINUE
39395       ENDIF
39396 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
39397       IF(IPIP.EQ.1)THEN
39398         IDHKT(2+IIGLU1)   =1000*KK21+100*KK22+3
39399         IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103
39400         IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103
39401         IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203
39402       ELSEIF(IPIP.EQ.2)THEN
39403         IDHKT(2+IIGLU1)   =1000*KK21+100*KK22-3
39404         IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103
39405         IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103
39406         IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203
39407       ENDIF
39408       ISTHKT(2+IIGLU1)  =922
39409       JMOHKT(1,2+IIGLU1)=NC2T
39410       JMOHKT(2,2+IIGLU1)=0
39411       JDAHKT(1,2+IIGLU1)=3+IIGLU1
39412       JDAHKT(2,2+IIGLU1)=0
39413       PHKT(1,2+IIGLU1)  =PHKK(1,NC2T)
39414      *+XGIVE*PHKT(1,5+IIGLU1)
39415       PHKT(2,2+IIGLU1)  =PHKK(2,NC2T)
39416      *+XGIVE*PHKT(2,5+IIGLU1)
39417       PHKT(3,2+IIGLU1)  =PHKK(3,NC2T)
39418      *+XGIVE*PHKT(3,5+IIGLU1)
39419       PHKT(4,2+IIGLU1)  =PHKK(4,NC2T)
39420      *+XGIVE*PHKT(4,5+IIGLU1)
39421 C     PHKT(5,2)  =PHKK(5,NC2T)
39422       XMIST=(PHKT(4,2+IIGLU1)**2-
39423      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
39424      *PHKT(1,2+IIGLU1)**2)
39425       IF(XMIST.GT.0.D0)THEN
39426       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
39427      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
39428      *PHKT(1,2+IIGLU1)**2)
39429       ELSE
39430 C     WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
39431       PHKT(5,2+IIGLU1)=0.D0
39432       ENDIF
39433       VHKT(1,2+IIGLU1)  =VHKK(1,NC2T)
39434       VHKT(2,2+IIGLU1)  =VHKK(2,NC2T)
39435       VHKT(3,2+IIGLU1)  =VHKK(3,NC2T)
39436       VHKT(4,2+IIGLU1)  =VHKK(4,NC2T)
39437       WHKT(1,2+IIGLU1)  =WHKK(1,NC2T)
39438       WHKT(2,2+IIGLU1)  =WHKK(2,NC2T)
39439       WHKT(3,2+IIGLU1)  =WHKK(3,NC2T)
39440       WHKT(4,2+IIGLU1)  =WHKK(4,NC2T)
39441       IDHKT(3+IIGLU1)   =88888
39442 C     IDHKT(3)   =1000*NNNC1+MMMC1+10
39443       ISTHKT(3+IIGLU1)  =93
39444 C     ISTHKT(3)  =KKKC1
39445       JMOHKT(1,3+IIGLU1)=1
39446       JMOHKT(2,3+IIGLU1)=2+IIGLU1
39447       JDAHKT(1,3+IIGLU1)=0
39448       JDAHKT(2,3+IIGLU1)=0
39449       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
39450       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
39451       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
39452       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
39453       PHKT(5,3+IIGLU1)
39454      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
39455      *            -PHKT(3,3+IIGLU1)**2)
39456       IF(IPIP.GE.3)THEN
39457       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
39458      * JDAHKT(1,1),
39459      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
39460       DO 71 IIG=2,2+IIGLU1-1
39461       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
39462      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
39463      * JDAHKT(1,IIG),
39464      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
39465    71 CONTINUE
39466       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
39467      &             IDHKT(2),JMOHKT(1,2+IIGLU1),
39468      * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
39469      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
39470       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
39471      * JMOHKT(1,3+IIGLU1),
39472      * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
39473      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
39474       ENDIF
39475       CHAMAL=CHAB1
39476 **NEW
39477 C     IF(IPIP.EQ.1)THEN
39478 C       IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
39479 C     ELSEIF(IPIP.EQ.2)THEN
39480 C       IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
39481 C     ENDIF
39482       IF(IPIP.EQ.1)THEN
39483         IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
39484       ELSEIF(IPIP.EQ.2)THEN
39485         IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
39486       ENDIF
39487 **
39488       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
39489 C       IREJ=1
39490         IPCO=0
39491 C       RETURN
39492 C       WRITE(6,*)' MGSQBS1 jump back from chain 3'
39493         GO TO 3466
39494       ENDIF
39495       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
39496       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
39497       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
39498       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
39499       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
39500       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
39501       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
39502       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
39503       IF(IPIP.EQ.1)THEN
39504         IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ1+3
39505         IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
39506         IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
39507         IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
39508       ELSEIF(IPIP.EQ.2)THEN
39509         IDHKT(7+IIGLU1)   =1000*IPP1+100*(-ISQ1+6)-3
39510         IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
39511         IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
39512         IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
39513 C       WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
39514       ENDIF
39515       ISTHKT(7+IIGLU1)  =921
39516       JMOHKT(1,7+IIGLU1)=NC2P
39517       JMOHKT(2,7+IIGLU1)=0
39518       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
39519       JDAHKT(2,7+IIGLU1)=0
39520 C     PHKT(1,7)  =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
39521 C     PHKT(2,7)  =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
39522 C     PHKT(3,7)  =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
39523 C     PHKT(4,7+IIGLU1)  =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
39524 **NEW
39525       IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
39526      &    WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
39527 **
39528       PHKT(1,7+IIGLU1)  =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
39529       PHKT(2,7+IIGLU1)  =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
39530       PHKT(3,7+IIGLU1)  =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
39531       PHKT(4,7+IIGLU1)  =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
39532 C     WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
39533 C    * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
39534       IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
39535 C       IREJ=1
39536 C       WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
39537         IPCO=0
39538 C       RETURN
39539         GO TO 3466
39540       ENDIF
39541 C     PHKT(5,7)  =PHKK(5,NC2P)
39542       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
39543      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
39544      *PHKT(1,7+IIGLU1)**2)
39545       VHKT(1,7+IIGLU1)  =VHKK(1,NC2P)
39546       VHKT(2,7+IIGLU1)  =VHKK(2,NC2P)
39547       VHKT(3,7+IIGLU1)  =VHKK(3,NC2P)
39548       VHKT(4,7+IIGLU1)  =VHKK(4,NC2P)
39549       WHKT(1,7+IIGLU1)  =WHKK(1,NC2P)
39550       WHKT(2,7+IIGLU1)  =WHKK(2,NC2P)
39551       WHKT(3,7+IIGLU1)  =WHKK(3,NC2P)
39552       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
39553 C     Insert here the IIGLU2 gluons
39554       PG1=0.D0
39555       PG2=0.D0
39556       PG3=0.D0
39557       PG4=0.D0
39558       IF(IIGLU2.GE.1)THEN
39559       JJG=NC2P
39560       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
39561         KKG=JJG+IIG-7-IIGLU1
39562         IDHKT(IIG)   =IDHKK(KKG)
39563         ISTHKT(IIG)  =921
39564         JMOHKT(1,IIG)=KKG
39565         JMOHKT(2,IIG)=0
39566         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
39567         JDAHKT(2,IIG)=0
39568         PHKT(1,IIG)=PHKK(1,KKG)
39569         PG1=PG1+ PHKT(1,IIG)
39570         PHKT(2,IIG)=PHKK(2,KKG)
39571         PG2=PG2+ PHKT(2,IIG)
39572         PHKT(3,IIG)=PHKK(3,KKG)
39573         PG3=PG3+ PHKT(3,IIG)
39574         PHKT(4,IIG)=PHKK(4,KKG)
39575         PG4=PG4+ PHKT(4,IIG)
39576         PHKT(5,IIG)=PHKK(5,KKG)
39577         VHKT(1,IIG)  =VHKK(1,KKG)
39578         VHKT(2,IIG)  =VHKK(2,KKG)
39579         VHKT(3,IIG)  =VHKK(3,KKG)
39580         VHKT(4,IIG)  =VHKK(4,KKG)
39581         WHKT(1,IIG)  =WHKK(1,KKG)
39582         WHKT(2,IIG)  =WHKK(2,KKG)
39583         WHKT(3,IIG)  =WHKK(3,KKG)
39584         WHKT(4,IIG)  =WHKK(4,KKG)
39585    81 CONTINUE
39586       ENDIF
39587       IDHKT(8+IIGLU1+IIGLU2)   =IP2
39588       ISTHKT(8+IIGLU1+IIGLU2)  =922
39589       JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
39590       JMOHKT(2,8+IIGLU1+IIGLU2)=0
39591       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
39592       JDAHKT(2,8+IIGLU1+IIGLU2)=0
39593 **NEW
39594       IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
39595      &    WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
39596 **
39597       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
39598       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
39599       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
39600       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
39601 C     PHKT(5,8+IIGLU1+IIGLU2)  =PHKK(5,NC1T)
39602       XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
39603      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
39604      *PHKT(1,8+IIGLU1+IIGLU2)**2)
39605       IF(XMIST.GT.0.D0)THEN
39606       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
39607      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
39608      *PHKT(1,8+IIGLU1+IIGLU2)**2)
39609       ELSE
39610 C     WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
39611       PHKT(5,8+IIGLU1+IIGLU2)=0.D0
39612       ENDIF
39613       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC1T)
39614       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC1T)
39615       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC1T)
39616       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC1T)
39617       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC1T)
39618       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC1T)
39619       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC1T)
39620       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC1T)
39621       IDHKT(9+IIGLU1+IIGLU2)   =88888
39622 C     IDHKT(9)   =1000*NNNC2+MMMC2+10
39623       ISTHKT(9+IIGLU1+IIGLU2)  =93
39624 C     ISTHKT(9)  =KKKC2
39625       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
39626       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
39627       JDAHKT(1,9+IIGLU1+IIGLU2)=0
39628       JDAHKT(2,9+IIGLU1+IIGLU2)=0
39629       PHKT(1,9+IIGLU1+IIGLU2)  =PHKT(1,7+IIGLU1)
39630      * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
39631       PHKT(2,9+IIGLU1+IIGLU2)  =PHKT(2,7+IIGLU1)
39632      * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
39633       PHKT(3,9+IIGLU1+IIGLU2)  =PHKT(3,7+IIGLU1)
39634      * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
39635       PHKT(4,9+IIGLU1+IIGLU2)  =PHKT(4,7+IIGLU1)
39636      * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
39637       PHKT(5,9+IIGLU1+IIGLU2)
39638      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
39639      * PHKT(2,9+IIGLU1+IIGLU2)**2
39640      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
39641       IF(IPIP.GE.3)THEN
39642       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
39643      * JMOHKT(1,7+IIGLU1),
39644      * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
39645      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
39646       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
39647       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
39648      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
39649      * JDAHKT(1,IIG),
39650      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
39651    91 CONTINUE
39652       WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
39653      * IDHKT(8+IIGLU1+IIGLU2),
39654      * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
39655      * JDAHKT(1,8+IIGLU1+IIGLU2),
39656      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
39657       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
39658      * IDHKT(9+IIGLU1+IIGLU2),
39659      * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
39660      * JDAHKT(1,9+IIGLU1+IIGLU2),
39661      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
39662       ENDIF
39663       CHAMAL=CHAB1
39664       IF(IPIP.EQ.1)THEN
39665         IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
39666       ELSEIF(IPIP.EQ.2)THEN
39667         IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
39668       ENDIF
39669       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
39670 C       IREJ=1
39671         IPCO=0
39672 C       RETURN
39673 C       WRITE(6,*)' MGSQBS1 jump back from chain 9',
39674 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
39675         GO TO 3466
39676       ENDIF
39677       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
39678       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
39679       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
39680       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
39681       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
39682       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
39683       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
39684       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
39685 C
39686       IGCOUN=9+IIGLU1+IIGLU2
39687       IPCO=0
39688        RETURN
39689        END
39690
39691 *$ CREATE HKKHKT.FOR
39692 *COPY HKKHKT
39693 C
39694 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
39695 C
39696       SUBROUTINE HKKHKT(I,J)
39697       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39698       SAVE
39699
39700 * event history
39701       PARAMETER (NMXHKK=200000)
39702       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39703      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39704      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39705 * extended event history
39706       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39707      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39708      &                IHIST(2,NMXHKK)
39709
39710       PARAMETER (NTMHKK= 300)
39711       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
39712      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
39713      +(4,NTMHKK)
39714 C
39715       ISTHKK(I)  =ISTHKT(J)
39716       IDHKK(I)   =IDHKT(J)
39717 C     IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
39718       IF(IDHKK(I).EQ.88888)THEN
39719 C       JMOHKK(1,I)=I-2
39720 C       JMOHKK(2,I)=I-1
39721         JMOHKK(1,I)=I-(J-JMOHKT(1,J))
39722         JMOHKK(2,I)=I-(J-JMOHKT(2,J))
39723       ELSE
39724         JMOHKK(1,I)=JMOHKT(1,J)
39725         JMOHKK(2,I)=JMOHKT(2,J)
39726       ENDIF
39727       JDAHKK(1,I)=JDAHKT(1,J)
39728       JDAHKK(2,I)=JDAHKT(2,J)
39729 C       IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
39730 C       JDAHKK(1,I)=I+2
39731 C     ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
39732 C       JDAHKK(1,I)=I+1
39733 C     ENDIF
39734       IF(JDAHKT(1,J).GT.0)THEN
39735         JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
39736       ENDIF
39737       PHKK(1,I)  =PHKT(1,J)
39738       PHKK(2,I)  =PHKT(2,J)
39739       PHKK(3,I)  =PHKT(3,J)
39740       PHKK(4,I)  =PHKT(4,J)
39741       PHKK(5,I)  =PHKT(5,J)
39742       VHKK(1,I)  =VHKT(1,J)
39743       VHKK(2,I)  =VHKT(2,J)
39744       VHKK(3,I)  =VHKT(3,J)
39745       VHKK(4,I)  =VHKT(4,J)
39746       WHKK(1,I)  =WHKT(1,J)
39747       WHKK(2,I)  =WHKT(2,J)
39748       WHKK(3,I)  =WHKT(3,J)
39749       WHKK(4,I)  =WHKT(4,J)
39750       RETURN
39751       END
39752
39753 *$ CREATE DT_DBREAK.FOR
39754 *COPY DT_DBREAK
39755 *
39756 *===dbreak=============================================================*
39757 *
39758       SUBROUTINE DT_DBREAK(MODE)
39759
39760 ************************************************************************
39761 * This is the steering subroutine for the different diquark breaking   *
39762 * mechanisms.                                                          *
39763 *                                                                      *
39764 * MODE = 1  breaking of projectile diquark in qq-q chain using         *
39765 *           a sea quark (q-qq chain) of the same projectile            *
39766 *      = 2  breaking of target     diquark in q-qq chain using         *
39767 *           a sea quark (qq-q chain) of the same target                *
39768 *      = 3  breaking of projectile diquark in qq-q chain using         *
39769 *           a sea quark (q-aq chain) of the same projectile            *
39770 *      = 4  breaking of target     diquark in q-qq chain using         *
39771 *           a sea quark (aq-q chain) of the same target                *
39772 *      = 5  breaking of projectile anti-diquark in aqaq-aq chain using *
39773 *           a sea anti-quark (aq-aqaq chain) of the same projectile    *
39774 *      = 6  breaking of target     anti-diquark in aq-aqaq chain using *
39775 *           a sea anti-quark (aqaq-aq chain) of the same target        *
39776 *      = 7  breaking of projectile anti-diquark in aqaq-aq chain using *
39777 *           a sea anti-quark (aq-q chain) of the same projectile       *
39778 *      = 8  breaking of target     anti-diquark in aq-aqaq chain using *
39779 *           a sea anti-quark (q-aq chain) of the same target           *
39780 *                                                                      *
39781 * Original version by J. Ranft.                                        *
39782 * This version dated 17.5.00  is written by S. Roesler.                *
39783 ************************************************************************
39784
39785       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
39786       SAVE
39787       PARAMETER ( LINP = 10 ,
39788      &            LOUT = 6 ,
39789      &            LDAT = 9 )
39790
39791 * event history
39792       PARAMETER (NMXHKK=200000)
39793       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
39794      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
39795      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
39796 * extended event history
39797       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
39798      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
39799      &                IHIST(2,NMXHKK)
39800 * flags for input different options
39801       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
39802       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
39803      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
39804 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
39805       PARAMETER (MAXCHN=10000)
39806       COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
39807 * diquark-breaking mechanism
39808       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
39809 * flags for particle decays
39810       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
39811      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
39812      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
39813
39814 *
39815 * chain identifiers
39816 * ( 1 = q-aq,   2 = aq-q,   3 = q-qq,   4 = qq-q,
39817 *   5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
39818       DIMENSION IDCHN1(8),IDCHN2(8)
39819       DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
39820       DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
39821 *
39822 * parton identifiers
39823 * ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
39824 *   +-51/52 = unitarity-sea, +-61/62 = gluons )
39825       DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
39826       DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
39827      &             31, 31, 31, 31, 31, 31, 31, 31,
39828      &             41, 41, 41, 41, 51, 51, 51, 51/
39829       DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
39830      &             32, 32, 32, 32, 32, 32, 32, 32,
39831      &             42, 42, 42, 42, 52, 52, 52, 52/
39832       DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
39833      &             51, 31, 41, 41, 31, 31, 31, 31,
39834      &              0, 41, 51, 51, 51, 51, 51, 51/
39835       DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
39836      &             32, 52, 42, 42, 32, 32, 32, 32,
39837      &             42,  0, 52, 52, 52, 52, 52, 52/
39838
39839       IF (NCHAIN.LE.0) RETURN
39840       DO 1 I=1,NCHAIN
39841          IDX1 = IDXCHN(1,I)
39842          IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
39843          IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
39844          IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
39845      &       .AND.
39846      &        ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
39847      &                                    (IS1P.EQ.ISP1P(MODE,3)))
39848      &       .AND.
39849      &        ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
39850      &                                    (IS1T.EQ.ISP1T(MODE,3)))
39851      &      ) THEN
39852             DO 2 J=1,NCHAIN
39853                IDX2 = IDXCHN(1,J)
39854                IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
39855                IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
39856                IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
39857      &             .AND.
39858      &              ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
39859      &                                      .OR.(IS2P.EQ.ISP2P(MODE,3)))
39860      &             .AND.
39861      &              ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
39862      &                                      .OR.(IS2T.EQ.ISP2T(MODE,3)))
39863      &            ) THEN
39864 *   find mother nucleons of the diquark to be splitted and of the
39865 *   sea-quark and reject this combination if it is not the same
39866                   IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
39867      &                (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
39868                      IANCES = 1
39869                   ELSE
39870                      IANCES = 2
39871                   ENDIF
39872                   IDXMO1 = JMOHKK(IANCES,IDX1)
39873     4             CONTINUE
39874                   IF ((JMOHKK(1,IDXMO1).NE.0).AND.
39875      &                (JMOHKK(2,IDXMO1).NE.0)) THEN
39876                      IANC = IANCES
39877                   ELSE
39878                      IANC = 1
39879                   ENDIF
39880                   IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
39881                      IDXMO1 = JMOHKK(IANC,IDXMO1)
39882                      GOTO 4
39883                   ENDIF
39884                   IDXMO2 = JMOHKK(IANCES,IDX2)
39885     5             CONTINUE
39886                   IF ((JMOHKK(1,IDXMO2).NE.0).AND.
39887      &                (JMOHKK(2,IDXMO2).NE.0)) THEN
39888                      IANC = IANCES
39889                   ELSE
39890                      IANC = 1
39891                   ENDIF
39892                   IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
39893                      IDXMO2 = JMOHKK(IANC,IDXMO2)
39894                      GOTO 5
39895                   ENDIF
39896                   IF (IDXMO1.NE.IDXMO2) GOTO 2
39897 *   quark content of projectile parton
39898                   IP1   = IDHKK(JMOHKK(1,IDX1))
39899                   IP11  = IP1/1000
39900                   IP12  = (IP1-1000*IP11)/100
39901                   IP2   = IDHKK(JMOHKK(2,IDX1))
39902                   IP21  = IP2/1000
39903                   IP22  = (IP2-1000*IP21)/100
39904 *   quark content of target parton
39905                   IT1  = IDHKK(JMOHKK(1,IDX2))
39906                   IT11 = IT1/1000
39907                   IT12 = (IT1-1000*IT11)/100
39908                   IT2  = IDHKK(JMOHKK(2,IDX2))
39909                   IT21 = IT2/1000
39910                   IT22 = (IT2-1000*IT21)/100
39911 *   split diquark and form new chains
39912                   IF (MODE.EQ.1) THEN
39913                      IF (IT1.EQ.4) GOTO 2
39914                      CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39915      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39916      &                         IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
39917                   ELSEIF (MODE.EQ.2) THEN
39918                      IF (IT2.EQ.4) GOTO 2
39919                      CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39920      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39921      &                         IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
39922                   ELSEIF (MODE.EQ.3) THEN
39923                      IF (IT1.EQ.4) GOTO 2
39924                      CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39925      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39926      &                         IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
39927                   ELSEIF (MODE.EQ.4) THEN
39928                      IF (IT2.EQ.4) GOTO 2
39929                      CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39930      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39931      &                         IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
39932                   ELSEIF (MODE.EQ.5) THEN
39933                      CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39934      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39935      &                         IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
39936                   ELSEIF (MODE.EQ.6) THEN
39937                      CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39938      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39939      &                         IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN)
39940                   ELSEIF (MODE.EQ.7) THEN
39941                      CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39942      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39943      &                         IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
39944                   ELSEIF (MODE.EQ.8) THEN
39945                      CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
39946      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
39947      &                         IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
39948                   ENDIF
39949                   IF (IREJ.GE.1) THEN
39950                      if ((ipq.lt.0).or.(ipq.ge.4))
39951      &                  write(LOUT,*) 'ipq !!!',ipq,mode
39952                      DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
39953 *   accept or reject new chains corresponding to PDBSEA
39954                   ELSE
39955                      IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
39956                         ACC   = DBRKA(1,MODE)+DBRKA(2,MODE)
39957                         REJ   = DBRKR(1,MODE)+DBRKR(2,MODE)
39958                      ELSEIF (IPQ.EQ.3) THEN
39959                         ACC   = DBRKA(3,MODE)
39960                         REJ   = DBRKR(3,MODE)
39961                      ELSE
39962                         WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
39963                         STOP
39964                      ENDIF
39965                      IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
39966                         DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
39967                         IACC = 1
39968                      ELSE
39969                         DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
39970                         IACC = 0
39971                      ENDIF
39972 *   new chains have been accepted and are now copied into HKKEVT
39973                      IF (IACC.EQ.1) THEN
39974                         IF (LEMCCK) THEN
39975                            CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
39976      &                                    PHKK(3,IDX1),PHKK(4,IDX1),
39977      &                                    1,IDUM1,IDUM2)
39978                            CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
39979      &                                    PHKK(3,IDX2),PHKK(4,IDX2),
39980      &                                    2,IDUM1,IDUM2)
39981                         ENDIF
39982                         IDHKK(IDX1) = 99888
39983                         IDHKK(IDX2) = 99888
39984                         IDXCHN(2,I) = -1
39985                         IDXCHN(2,J) = -1
39986                         DO 3 K=1,IGCOUN
39987                            NHKK = NHKK+1
39988                            CALL HKKHKT(NHKK,K)
39989                            IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
39990                               PX = -PHKK(1,NHKK)
39991                               PY = -PHKK(2,NHKK)
39992                               PZ = -PHKK(3,NHKK)
39993                               PE = -PHKK(4,NHKK)
39994                               CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
39995                            ENDIF
39996     3                   CONTINUE
39997                         IF (LEMCCK) THEN
39998                            CHKLEV = 0.1D0
39999                            CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
40000      &                                                             IREJ)
40001                            IF (IREJ.NE.0) CALL DT_EVTOUT(4)
40002                         ENDIF
40003                         GOTO 1
40004                      ENDIF
40005                   ENDIF
40006                ENDIF
40007     2       CONTINUE
40008          ENDIF
40009     1 CONTINUE
40010       RETURN
40011       END
40012
40013 *$ CREATE DT_CQPAIR.FOR
40014 *COPY DT_CQPAIR
40015 *
40016 *===cqpair=============================================================*
40017 *
40018       SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
40019
40020 ************************************************************************
40021 * This subroutine Creates a Quark-antiquark PAIR from the sea.         *
40022 *                                                                      *
40023 *   XQMAX   maxium energy fraction of quark (input)                    *
40024 *   XAQMAX  maxium energy fraction of antiquark (input)                *
40025 *   XQ      energy fraction of quark (output)                          *
40026 *   XAQ     energy fraction of antiquark (output)                      *
40027 *   IFLV    quark flavour (- antiquark flavor) (output)                *
40028 *                                                                      *
40029 * This version dated 14.5.00  is written by S. Roesler.                *
40030 ************************************************************************
40031
40032       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
40033       SAVE
40034       PARAMETER ( LINP = 10 ,
40035      &            LOUT = 6 ,
40036      &            LDAT = 9 )
40037
40038 * Lorentz-parameters of the current interaction
40039       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
40040      &                UMO,PPCM,EPROJ,PPROJ
40041
40042 *
40043       IREJ = 0
40044       XQ   = 0.0D0
40045       XAQ  = 0.0D0
40046 *
40047 * sample quark flavour
40048 *
40049 *  set seasq here (the one from DTCHAI should be used in the future)
40050       SEASQ = 0.5D0
40051       IFLV  = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
40052 *
40053 * sample energy fractions of sea pair
40054 * we first sample the energy fraction of a gluon and then split the gluon
40055 *
40056 *  maximum energy fraction of the gluon forced via input
40057       XGMAXI = XQMAX+XAQMAX
40058 *  minimum energy fraction of the gluon
40059       XTHR1 = 4.0D0 /UMO**2
40060       XTHR2 = 0.54D0/UMO**1.5D0
40061       XGMIN = MAX(XTHR1,XTHR2)
40062 *  maximum energy fraction of the gluon
40063       XGMAX = 0.3D0
40064       XGMAX = MIN(XGMAXI,XGMAX)
40065       IF (XGMIN.GE.XGMAX) THEN
40066          IREJ = 1
40067          RETURN
40068       ENDIF
40069 *
40070 *  sample energy fraction of the gluon
40071       NLOOP = 0
40072     1 CONTINUE
40073       NLOOP = NLOOP+1
40074       IF (NLOOP.GE.50) THEN
40075          IREJ = 1
40076          RETURN
40077       ENDIF
40078       XGLUON = DT_SAMSQX(XGMIN,XGMAX)
40079       EGLUON = XGLUON*UMO/2.0D0
40080 *
40081 *  split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
40082       ZMIN = MIN(0.1D0,0.5D0/EGLUON)
40083       ZMAX = 1.0D0-ZMIN
40084       RZ   = DT_RNDM(ZMAX)
40085       XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
40086       RQ   = DT_RNDM(ZMAX)
40087       IF (RQ.LT.0.5D0) THEN
40088          XQ  = XGLUON*XHLP
40089          XAQ = XGLUON-XQ
40090       ELSE
40091          XAQ = XGLUON*XHLP
40092          XQ  = XGLUON-XAQ
40093       ENDIF
40094       IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1
40095
40096       RETURN
40097       END