+++ /dev/null
-*
-* +-------------------------------------------------------------+
-* | |
-* | |
-* | DPMJET 3.0 |
-* | |
-* | |
-* | S. Roesler+), R. Engel#), J. Ranft*) |
-* | |
-* | +) CERN, TIS-RP |
-* | CH-1211 Geneva 23, Switzerland |
-* | Email: Stefan.Roesler@cern.ch |
-* | |
-* | #) University of Delaware, BRI |
-* | Newark, DE 19716, USA |
-* | |
-* | *) University of Siegen, Dept. of Physics |
-* | D-57068 Siegen, Germany |
-* | |
-* | |
-* | http://home.cern.ch/sroesler/dpmjet3.html |
-* | |
-* | |
-* | Monte Carlo models used for event generation: |
-* | PHOJET 1.12, JETSET 7.4 and LEPTO 6.5.1 |
-* | |
-* +-------------------------------------------------------------+
-*
-*
-*===init===============================================================*
-*
-CDECK ID>, DT_INIT
- SUBROUTINE DT_INIT(NCASES,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
- & IDP,IGLAU)
-
-************************************************************************
-* Initialization of event generation *
-* This version dated 7.4.98 is written by S. Roesler. *
-************************************************************************
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( LINP = 5 ,
- & LOUT = 6 ,
- & LDAT = 9 )
-
- PARAMETER (ZERO=0.0D0,ONE=1.0D0)
-
-* particle properties (BAMJET index convention)
- CHARACTER*8 ANAME
- COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
- & IICH(210),IIBAR(210),K1(210),K2(210)
-* names of hadrons used in input-cards
- CHARACTER*8 BTYPE
- COMMON /DTPAIN/ BTYPE(30)
-
- INCLUDE '(DIMPAR)'
- INCLUDE '(PAREVT)'
- INCLUDE '(EVAPAR)'
- INCLUDE '(FRBKCM)'
-
- PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
-
-* emulsion treatment
- COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
- & NCOMPO,IEMUL
-* Glauber formalism: parameters
- COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
- & BMAX(NCOMPX),BSTEP(NCOMPX),
- & SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
- & NSITEB,NSTATB
-* Glauber formalism: cross sections
- COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
- & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
- & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
- & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
- & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
- & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
- & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
- & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
- & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
- & BSLOPE,NEBINI,NQBINI
-* interface HADRIN-DPM
- COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
-* central particle production, impact parameter biasing
- COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
-* parameter for intranuclear cascade
- LOGICAL LPAULI
- COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
-* various options for treatment of partons (DTUNUC 1.x)
-* (chain recombination, Cronin,..)
- LOGICAL LCO2CR,LINTPT
- COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
- & LCO2CR,LINTPT
-* threshold values for x-sampling (DTUNUC 1.x)
- COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
- & SSMIMQ,VVMTHR
-* flags for input different options
- LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
- COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
- & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
-* nuclear potential
- LOGICAL LFERMI
- COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
- & EBINDP(2),EBINDN(2),EPOT(2,210),
- & ETACOU(2),ICOUL,LFERMI
-* n-n cross section fluctuations
- PARAMETER (NBINS = 1000)
- COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
-* flags for particle decays
- COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
- & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
- & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
-* diquark-breaking mechanism
- COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
-* nucleon-nucleon event-generator
- CHARACTER*8 CMODEL
- LOGICAL LPHOIN
- COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
-* properties of interacting particles
- COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
-* properties of photon/lepton projectiles
- COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
-* flags for diffractive interactions (DTUNUC 1.x)
- COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
-* parameters for hA-diffraction
- COMMON /DTDIHA/ DIBETA,DIALPH
-* Lorentz-parameters of the current interaction
- COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
- & UMO,PPCM,EPROJ,PPROJ
-* kinematical cuts for lepton-nucleus interactions
- COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
- & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
-* VDM parameter for photon-nucleus interactions
- COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
-* Glauber formalism: flags and parameters for statistics
- LOGICAL LPROD
- CHARACTER*8 CGLB
- COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
-* cuts for variable energy runs
- COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
-* flags for activated histograms
- COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
-
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
-
- COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5)
-
-* LEPTO
-**LUND single / double precision
- REAL CUT,PARL,TMPX,TMPY,TMPW2,TMPQ2,TMPU
- COMMON /LEPTOU/ CUT(14),LST(40),PARL(30),
- & TMPX,TMPY,TMPW2,TMPQ2,TMPU
-* LEPTO
- REAL RPPN
- COMMON /LEPTOI/ RPPN,LEPIN,INTER
-* steering flags for qel neutrino scattering modules
- COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
-* event flag
- COMMON /DTEVNO/ NEVENT,ICASCA
-
- INTEGER PYCOMP
-
-C DIMENSION XPARA(5)
- DIMENSION XDUMB(40),IPRANG(5)
-
- PARAMETER (MXCARD=58)
- CHARACTER*78 CLINE,CTITLE
- CHARACTER*60 CWHAT
- CHARACTER*8 BLANK,SDUM
- CHARACTER*10 CODE,CODEWD
- CHARACTER*72 HEADER
- LOGICAL LSTART,LEINP,LXSTAB
- DIMENSION WHAT(6),CODE(MXCARD)
- DATA CODE/
- & 'TITLE ','PROJPAR ','TARPAR ','ENERGY ',
- & 'MOMENTUM ','CMENERGY ','EMULSION ','FERMI ',
- & 'TAUFOR ','PAULI ','COULOMB ','HADRIN ',
- & 'EVAP ','EMCCHECK ','MODEL ','PHOINPUT ',
- & 'GLAUBERI ','FLUCTUAT ','CENTRAL ','RECOMBIN ',
- & 'COMBIJET ','XCUTS ','INTPT ','CRONINPT ',
- & 'SEADISTR ','SEASU3 ','DIQUARKS ','RESONANC ',
- & 'DIFFRACT ','SINGLECH ','NOFRAGME ','HADRONIZE ',
- & 'POPCORN ','PARDECAY ','BEAM ','LUND-MSTU ',
- & 'LUND-MSTJ ','LUND-MDCY ','LUND-PARJ ','LUND-PARU ',
- & 'OUTLEVEL ','FRAME ','L-TAG ','L-ETAG ',
- & 'ECMS-CUT ','VDM-PAR1 ','HISTOGRAM ','XS-TABLE ',
- & 'GLAUB-PAR ','GLAUB-INI ','VDM-PAR2 ','XS-QELPRO ',
- & 'RNDMINIT ','LEPTO-CUT ','LEPTO-LST ','LEPTO-PARL',
- & 'START ','STOP '/
- DATA BLANK /' '/
-
- DATA LSTART,LXSTAB,IFIRST /.TRUE.,.FALSE.,1/
- DATA CMEOLD /0.0D0/
-
-* --- Added by Chiara
-
- CHARACTER*100 ALIROOT
- CHARACTER*100 FILNAM
- INTEGER*4 LNROOT
- LOGICAL EXISTS
- ALIROOT=' '
-
-*---------------------------------------------------------------------
-* at the first call of INIT: initialize event generation
- EPNSAV = EPN
- IF (LSTART) THEN
- CALL DT_TITLE
-* initialization and test of the random number generator
- IF (ITRSPT.NE.1) THEN
-
- CALL FL48UT (ISRM48,ISEED1,ISEED2)
- CALL FL48IN (54217137,ISEED1,ISEED2)
-
- ENDIF
-* initialization of BAMJET, DECAY and HADRIN
- CALL DT_DDATAR
- CALL DT_DHADDE
- CALL DT_DCHANT
- CALL DT_DCHANH
-* set default values for input variables
- CALL DT_DEFAUL(EPN,PPN)
- IGLAU = 0
- IXSQEL = 0
-* flag for collision energy input
- LEINP = .FALSE.
- LSTART = .FALSE.
- ENDIF
-
-*---------------------------------------------------------------------
- 10 CONTINUE
-
-* bypass reading input cards (e.g. for use with Fluka)
-* in this case Epn is expected to carry the beam momentum
- IF (NCASES.EQ.-1) THEN
- IP = NPMASS
- IPZ = NPCHAR
- PPN = EPNSAV
- EPN = ZERO
- CMENER = ZERO
- LEINP = .TRUE.
- MKCRON = 0
- WHAT(1) = 1
- WHAT(2) = 0
- CODEWD = 'START '
- GOTO 900
- ENDIF
-
-* read control card from input-unit LINP
-C READ(LINP,'(A78)',END=9999) CLINE
-* ### Read control card from specified file
-* ### Changed by Chiara (original version LINP=5)
-* OPEN(UNIT=7,
-* + FILE='/home/oppedisa/AliRoot/new/DPMJET/inp/PbPbLHC.inp',
-* + STATUS='OLD')
-
- CALL GETENVF('ALICE_ROOT',ALIROOT)
- LNROOT = LNBLNK(ALIROOT)
-
- FILNAM=ALIROOT(1:LNROOT)//'/DPMJET/inp/ppLHC.inp'
- OPEN(UNIT=7,FILE=FILNAM,STATUS='OLD')
- OPEN(UNIT=14,FILE="nuclear.bin",STATUS='OLD')
-* OPEN(UNIT=6,FILE="dpm.out",STATUS='UNKNOWN')
-
- READ(7,'(A78)',END=9999) CLINE
-
- IF (CLINE(1:1).EQ.'*') THEN
-* comment-line
-C WRITE(LOUT,'(A78)') CLINE
- GOTO 10
- ENDIF
-C READ(CLINE,1000,END=9999) CODEWD,(WHAT(I),I=1,6),SDUM
-C1000 FORMAT(A10,6E10.0,A8)
- DO 1008 I=1,6
- WHAT(I) = ZERO
- 1008 CONTINUE
- READ(CLINE,1006,END=9999) CODEWD,CWHAT,SDUM
- 1006 FORMAT(A10,A60,A8)
- READ(CWHAT,*,END=1007) (WHAT(I),I=1,6)
- 1007 CONTINUE
- WRITE(LOUT,1001) CODEWD,(WHAT(I),I=1,6),SDUM
- 1001 FORMAT(A10,6G10.3,A8)
-
- 900 CONTINUE
-
-* check for valid control card and get card index
- ICW = 0
- DO 11 I=1,MXCARD
- IF (CODEWD.EQ.CODE(I)) ICW = I
- 11 CONTINUE
- IF (ICW.EQ.0) THEN
- WRITE(LOUT,1002) CODEWD
- 1002 FORMAT(/,1X,'---> ',A10,': invalid control-card !',/)
- GOTO 10
- ENDIF
- GOTO(
-*------------------------------------------------------------
-* TITLE , PROJPAR , TARPAR , ENERGY , MOMENTUM,
- & 100 , 110 , 120 , 130 , 140 ,
-*
-*------------------------------------------------------------
-* CMENERGY, EMULSION, FERMI , TAUFOR , PAULI ,
- & 150 , 160 , 170 , 180 , 190 ,
-*
-*------------------------------------------------------------
-* COULOMB , HADRIN , EVAP , EMCCHECK, MODEL ,
- & 200 , 210 , 220 , 230 , 240 ,
-*
-*------------------------------------------------------------
-* PHOINPUT, GLAUBERI, FLUCTUAT, CENTRAL , RECOMBIN,
- & 250 , 260 , 270 , 280 , 290 ,
-*
-*------------------------------------------------------------
-* COMBIJET, XCUTS , INTPT , CRONINPT, SEADISTR,
- & 300 , 310 , 320 , 330 , 340 ,
-*
-*------------------------------------------------------------
-* SEASU3 , DIQUARKS, RESONANC, DIFFRACT, SINGLECH,
- & 350 , 360 , 370 , 380 , 390 ,
-*
-*------------------------------------------------------------
-* NOFRAGME, HADRONIZE, POPCORN , PARDECAY, BEAM ,
- & 400 , 410 , 420 , 430 , 440 ,
-*
-*------------------------------------------------------------
-* LUND-MSTU, LUND-MSTJ, LUND-MDCY, LUND-PARJ, LUND-PARU,
- & 450 , 451 , 452 , 460 , 470 ,
-*
-*------------------------------------------------------------
-* OUTLEVEL, FRAME , L-TAG , L-ETAG , ECMS-CUT,
- & 480 , 490 , 500 , 510 , 520 ,
-*
-*------------------------------------------------------------
-* VDM-PAR1, HISTOGRAM, XS-TABLE , GLAUB-PAR, GLAUB-INI,
- & 530 , 540 , 550 , 560 , 565 ,
-*
-*------------------------------------------------------------
-* , , VDM-PAR2, XS-QELPRO, RNDMINIT ,
- & 570 , 580 , 590 ,
-*
-*------------------------------------------------------------
-* LEPTO-CUT, LEPTO-LST,LEPTO-PARL, START , STOP )
- & 600 , 610 , 620 , 630 , 640 ) , ICW
-*
-*------------------------------------------------------------
-
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = TITLE *
-* *
-* what (1..6), sdum no meaning *
-* *
-* Note: The control-card following this must consist of *
-* a string of characters usually giving the title of *
-* the run. *
-* *
-*********************************************************************
-
- 100 CONTINUE
-C READ(LINP,'(A78)') CTITLE
-* ### Read control card from specified file
-* ### Changed by Chiara (original version LINP=5)
- READ(7,'(A78)') CTITLE
-
- WRITE(LOUT,'(//,5X,A78,//)') CTITLE
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = PROJPAR *
-* *
-* what (1) = mass number of projectile nucleus default: 1 *
-* what (2) = charge of projectile nucleus default: 1 *
-* what (3..6) no meaning *
-* sdum projectile particle code word *
-* *
-* Note: If sdum is defined what (1..2) have no meaning. *
-* *
-*********************************************************************
-
- 110 CONTINUE
- IF (SDUM.EQ.BLANK) THEN
- IP = INT(WHAT(1))
- IPZ = INT(WHAT(2))
- IJPROJ = 1
- IBPROJ = 1
- ELSE
- IJPROJ = 0
- DO 111 II=1,30
- IF (SDUM.EQ.BTYPE(II)) THEN
- IP = 1
- IPZ = 1
- IF (II.EQ.26) THEN
- IJPROJ = 135
- ELSEIF (II.EQ.27) THEN
- IJPROJ = 136
- ELSEIF (II.EQ.28) THEN
- IJPROJ = 133
- ELSEIF (II.EQ.29) THEN
- IJPROJ = 134
- ELSE
- IJPROJ = II
- ENDIF
- IBPROJ = IIBAR(IJPROJ)
-* photon
- IF ((IJPROJ.EQ.7).AND.(WHAT(1).GT.ZERO)) VIRT = WHAT(1)
-* lepton
- IF (((IJPROJ.EQ. 3).OR.(IJPROJ.EQ. 4).OR.
- & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11)).AND.
- & (WHAT(1).GT.ZERO)) Q2HI = WHAT(1)
- ENDIF
- 111 CONTINUE
- IF (IJPROJ.EQ.0) THEN
- WRITE(LOUT,1110)
- 1110 FORMAT(/,1X,'invalid PROJPAR card !',/)
- GOTO 9999
- ENDIF
- ENDIF
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = TARPAR *
-* *
-* what (1) = mass number of target nucleus default: 1 *
-* what (2) = charge of target nucleus default: 1 *
-* what (3..6) no meaning *
-* sdum target particle code word *
-* *
-* Note: If sdum is defined what (1..2) have no meaning. *
-* *
-*********************************************************************
-
- 120 CONTINUE
- IF (SDUM.EQ.BLANK) THEN
- IT = INT(WHAT(1))
- ITZ = INT(WHAT(2))
- IJTARG = 1
- IBTARG = 1
- ELSE
- IJTARG = 0
- DO 121 II=1,30
- IF (SDUM.EQ.BTYPE(II)) THEN
- IT = 1
- ITZ = 1
- IJTARG = II
- IBTARG = IIBAR(IJTARG)
- ENDIF
- 121 CONTINUE
- IF (IJTARG.EQ.0) THEN
- WRITE(LOUT,1120)
- 1120 FORMAT(/,1X,'invalid TARPAR card !',/)
- GOTO 9999
- ENDIF
- ENDIF
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = ENERGY *
-* *
-* what (1) = energy (GeV) of projectile in Lab. *
-* if what(1) < 0: |what(1)| = kinetic energy *
-* default: 200 GeV *
-* if |what(2)| > 0: min. energy for variable *
-* energy runs *
-* what (2) = max. energy for variable energy runs *
-* if what(2) < 0: |what(2)| = kinetic energy *
-* *
-*********************************************************************
-
- 130 CONTINUE
- EPN = WHAT(1)
- PPN = ZERO
- CMENER = ZERO
- IF ((ABS(WHAT(2)).GT.ZERO).AND.
- & (ABS(WHAT(2)).GT.ABS(WHAT(1)))) THEN
- VARELO = WHAT(1)
- VAREHI = WHAT(2)
- EPN = VAREHI
- ENDIF
- LEINP = .TRUE.
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = MOMENTUM *
-* *
-* what (1) = momentum (GeV/c) of projectile in Lab. *
-* default: 200 GeV/c *
-* what (2..6), sdum no meaning *
-* *
-*********************************************************************
-
- 140 CONTINUE
- EPN = ZERO
- PPN = WHAT(1)
- CMENER = ZERO
- LEINP = .TRUE.
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = CMENERGY *
-* *
-* what (1) = energy in nucleon-nucleon cms. *
-* default: none *
-* what (2..6), sdum no meaning *
-* *
-*********************************************************************
-
- 150 CONTINUE
- EPN = ZERO
- PPN = ZERO
- CMENER = WHAT(1)
- LEINP = .TRUE.
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = EMULSION *
-* *
-* definition of nuclear emulsions *
-* *
-* what(1) mass number of emulsion component *
-* what(2) charge of emulsion component *
-* what(3) fraction of events in which a scattering on a *
-* nucleus of this properties is performed *
-* what(4,5,6) as what(1,2,3) but for another component *
-* default: no emulsion *
-* sdum no meaning *
-* *
-* Note: If this input-card is once used with valid parameters *
-* TARPAR is obsolete. *
-* Not the absolute values of the fractions are important *
-* but only the ratios of fractions of different comp. *
-* This control card can be repeatedly used to define *
-* emulsions consisting of up to 10 elements. *
-* *
-*********************************************************************
-
- 160 CONTINUE
- IF ((WHAT(1).GT.ZERO).AND.(WHAT(2).GT.ZERO)
- & .AND.(ABS(WHAT(3)).GT.ZERO)) THEN
- NCOMPO = NCOMPO+1
- IF (NCOMPO.GT.NCOMPX) THEN
- WRITE(LOUT,1600)
- STOP
- ENDIF
- IEMUMA(NCOMPO) = INT(WHAT(1))
- IEMUCH(NCOMPO) = INT(WHAT(2))
- EMUFRA(NCOMPO) = WHAT(3)
- IEMUL = 1
-C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
- ENDIF
- IF ((WHAT(4).GT.ZERO).AND.(WHAT(5).GT.ZERO)
- & .AND.(ABS(WHAT(6)).GT.ZERO)) THEN
- NCOMPO = NCOMPO+1
- IF (NCOMPO.GT.NCOMPX) THEN
- WRITE(LOUT,1001)
- STOP
- ENDIF
- IEMUMA(NCOMPO) = INT(WHAT(4))
- IEMUCH(NCOMPO) = INT(WHAT(5))
- EMUFRA(NCOMPO) = WHAT(6)
-C CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
- ENDIF
- 1600 FORMAT(1X,'too many emulsion components - program stopped')
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = FERMI *
-* *
-* what (1) = -1 Fermi-motion of nucleons not treated *
-* default: 1 *
-* what (2) = scale factor for Fermi-momentum *
-* default: 0.75 *
-* what (3..6), sdum no meaning *
-* *
-*********************************************************************
-
- 170 CONTINUE
- IF (WHAT(1).EQ.-1.0D0) THEN
- LFERMI = .FALSE.
- ELSE
- LFERMI = .TRUE.
- ENDIF
- XMOD = WHAT(2)
- IF (XMOD.GE.ZERO) FERMOD = XMOD
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = TAUFOR *
-* *
-* formation time supressed intranuclear cascade *
-* *
-* what (1) formation time (in fm/c) *
-* note: what(1)=10. corresponds roughly to an *
-* average formation time of 1 fm/c *
-* default: 5. fm/c *
-* what (2) number of generations followed *
-* default: 25 *
-* what (3) = 1. p_t-dependent formation zone *
-* = 2. constant formation zone *
-* default: 1 *
-* what (4) modus of selection of nucleus where the *
-* cascade if followed first *
-* = 1. proj./target-nucleus with probab. 1/2 *
-* = 2. nucleus with highest mass *
-* = 3. proj. nucleus if particle is moving in pos. z *
-* targ. nucleus if particle is moving in neg. z *
-* default: 1 *
-* what (5..6), sdum no meaning *
-* *
-*********************************************************************
-
- 180 CONTINUE
- TAUFOR = WHAT(1)
- KTAUGE = INT(WHAT(2))
- INCMOD = 1
- IF ((WHAT(3).GE.1.0D0).AND.(WHAT(3).LE.2.0D0))
- & ITAUVE = INT(WHAT(3))
- IF ((WHAT(4).GE.1.0D0).AND.(WHAT(4).LE.3.0D0))
- & INCMOD = INT(WHAT(4))
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = PAULI *
-* *
-* what (1) = -1 Pauli's principle for secondary *
-* interactions not treated *
-* default: 1 *
-* what (2..6), sdum no meaning *
-* *
-*********************************************************************
-
- 190 CONTINUE
- IF (WHAT(1).EQ.-1.0D0) THEN
- LPAULI = .FALSE.
- ELSE
- LPAULI = .TRUE.
- ENDIF
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = COULOMB *
-* *
-* what (1) = -1. Coulomb-energy treatment switched off *
-* default: 1 *
-* what (2..6), sdum no meaning *
-* *
-*********************************************************************
-
- 200 CONTINUE
- ICOUL = 1
- IF (WHAT(1).EQ.-1.0D0) THEN
- ICOUL = 0
- ELSE
- ICOUL = 1
- ENDIF
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = HADRIN *
-* *
-* HADRIN module *
-* *
-* what (1) = 0. elastic/inelastic interactions with probab. *
-* as defined by cross-sections *
-* = 1. inelastic interactions forced *
-* = 2. elastic interactions forced *
-* default: 1 *
-* what (2) upper threshold in total energy (GeV) below *
-* which interactions are sampled by HADRIN *
-* default: 5. GeV *
-* what (3..6), sdum no meaning *
-* *
-*********************************************************************
-
- 210 CONTINUE
- IWHAT = INT(WHAT(1))
- IF ((IWHAT.GE.0).AND.(IWHAT.LE.2)) INTHAD = IWHAT
- IF ((WHAT(2).GT.ZERO).AND.(WHAT(2).LT.15.0D0)) EHADTH = WHAT(2)
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = EVAP *
-* *
-* evaporation module *
-* *
-* what (1) =< -1 ==> evaporation is switched off *
-* >= 1 ==> evaporation is performed *
-* *
-* what (1) = i1 + i2*10 + i3*100 + i4*10000 *
-* (i1, i2, i3, i4 >= 0 ) *
-* *
-* i1 is the flag for selecting the T=0 level density option used *
-* = 1: standard EVAP level densities with Cook pairing *
-* energies *
-* = 2: Z,N-dependent Gilbert & Cameron level densities *
-* (default) *
-* = 3: Julich A-dependent level densities *
-* = 4: Z,N-dependent Brancazio & Cameron level densities *
-* *
-* i2 >= 1: high energy fission activated *
-* (default high energy fission activated) *
-* *
-* i3 = 0: No energy dependence for level densities *
-* = 1: Standard Ignyatuk (1975, 1st) energy dependence *
-* for level densities (default) *
-* = 2: Standard Ignyatuk (1975, 1st) energy dependence *
-* for level densities with NOT used set of parameters *
-* = 3: Standard Ignyatuk (1975, 1st) energy dependence *
-* for level densities with NOT used set of parameters *
-* = 4: Second Ignyatuk (1975, 2nd) energy dependence *
-* for level densities *
-* = 5: Second Ignyatuk (1975, 2nd) energy dependence *
-* for level densities with fit 1 Iljinov & Mebel set of *
-* parameters *
-* = 6: Second Ignyatuk (1975, 2nd) energy dependence *
-* for level densities with fit 2 Iljinov & Mebel set of *
-* parameters *
-* = 7: Second Ignyatuk (1975, 2nd) energy dependence *
-* for level densities with fit 3 Iljinov & Mebel set of *
-* parameters *
-* = 8: Second Ignyatuk (1975, 2nd) energy dependence *
-* for level densities with fit 4 Iljinov & Mebel set of *
-* parameters *
-* *
-* i4 >= 1: Original Gilbert and Cameron pairing energies used *
-* (default Cook's modified pairing energies) *
-* *
-* what (2) = ig + 10 * if (ig and if must have the same sign) *
-* *
-* ig =< -1 ==> deexcitation gammas are not produced *
-* (if the evaporation step is not performed *
-* they are never produced) *
-* if =< -1 ==> Fermi Break Up is not invoked *
-* (if the evaporation step is not performed *
-* it is never invoked) *
-* The default is: deexcitation gamma produced and Fermi break up *
-* activated for the new preequilibrium, not *
-* activated otherwise. *
-* what (3..6), sdum no meaning *
-* *
-*********************************************************************
-
- 220 CONTINUE
-
- IF (WHAT(1).LE.-1.0D0) THEN
- LEVPRT = .FALSE.
- LDEEXG = .FALSE.
- LHEAVY = .FALSE.
- GOTO 10
- ENDIF
- WHTSAV = WHAT (1)
- IF ( NINT (WHAT (1)) .GE. 10000 ) THEN
- LLVMOD = .FALSE.
- JLVHLP = NINT (WHAT (1)) / 10000
- WHAT (1) = WHAT (1) - 10000.D+00 * JLVHLP
- END IF
- IF ( NINT (WHAT (1)) .GE. 100 ) THEN
- JLVMOD = NINT (WHAT (1)) / 100
- WHAT (1) = WHAT (1) - 100.D+00 * JLVMOD
- END IF
- IF ( NINT (WHAT (1)) .GE. 10 ) THEN
- IFISS = 1
- JLVHLP = NINT (WHAT (1)) / 10
- WHAT (1) = WHAT (1) - 10.D+00 * JLVHLP
- ELSE IF ( NINT (WHTSAV) .NE. 0 ) THEN
- IFISS = 0
- END IF
- IF ( NINT (WHAT (1)) .GE. 0 ) THEN
- LEVPRT = .TRUE.
- ILVMOD = NINT (WHAT(1))
- IF ( ABS (NINT (WHAT (2))) .GE. 10 ) THEN
- LFRMBK = .TRUE.
- JLVHLP = NINT (WHAT (2)) / 10
- WHAT (2) = WHAT (2) - 10.D+00 * JLVHLP
- ELSE IF ( NINT (WHAT (2)) .NE. 0 ) THEN
- LFRMBK = .FALSE.
- END IF
- IF ( NINT (WHAT (2)) .GE. 0 ) THEN
- LDEEXG = .TRUE.
- ELSE
- LDEEXG = .FALSE.
- END IF
-**sr heavies are always put to /FKFHVY/
-C IF ( NINT (WHAT(3)) .GE. 1 ) THEN
-C LHEAVY = .TRUE.
-C ELSE
-C LHEAVY = .FALSE.
-C END IF
- LHEAVY = .TRUE.
- ELSE
- LEVPRT = .FALSE.
- LDEEXG = .FALSE.
- LHEAVY = .FALSE.
- END IF
-
- LOLDEV = .FALSE.
-
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = EMCCHECK *
-* *
-* extended energy-momentum / quantum-number conservation check *
-* *
-* what (1) = -1 extended check not performed *
-* default: 1. *
-* what (2..6), sdum no meaning *
-* *
-*********************************************************************
-
- 230 CONTINUE
- IF (WHAT(1).EQ.-1) THEN
- LEMCCK = .FALSE.
- ELSE
- LEMCCK = .TRUE.
- ENDIF
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = MODEL *
-* *
-* Model to be used to treat nucleon-nucleon interactions *
-* *
-* sdum = DTUNUC two-chain model *
-* = PHOJET multiple chains including minijets *
-* = LEPTO DIS *
-* = QNEUTRIN quasi-elastic neutrino scattering *
-* default: PHOJET *
-* *
-* if sdum = LEPTO: *
-* what (1) (variable INTER) *
-* = 1 gamma exchange *
-* = 2 W+- exchange *
-* = 3 Z0 exchange *
-* = 4 gamma/Z0 exchange *
-* *
-* if sdum = QNEUTRIN: *
-* what (1) = 0 elastic scattering on nucleon and *
-* tau does not decay (default) *
-* = 1 decay of tau into mu.. *
-* = 2 decay of tau into e.. *
-* = 10 CC events on p and n *
-* = 11 NC events on p and n *
-* *
-* what (2..6) no meaning *
-* *
-*********************************************************************
-
- 240 CONTINUE
- IF (SDUM.EQ.CMODEL(1)) THEN
- MCGENE = 1
- ELSEIF (SDUM.EQ.CMODEL(2)) THEN
- MCGENE = 2
- ELSEIF (SDUM.EQ.CMODEL(3)) THEN
- MCGENE = 3
- IF ((WHAT(1).GE.1.0D0).AND.(WHAT(1).LE.4.0D0))
- & INTER = INT(WHAT(1))
- ELSEIF (SDUM.EQ.CMODEL(4)) THEN
- MCGENE = 4
- IWHAT = INT(WHAT(1))
- IF ((IWHAT.EQ.1 ).OR.(IWHAT.EQ.2 ).OR.
- & (IWHAT.EQ.10).OR.(IWHAT.EQ.11))
- & NEUDEC = IWHAT
- ELSE
- STOP ' Unknown model !'
- ENDIF
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = PHOINPUT *
-* *
-* Start of input-section for PHOJET-specific input-cards *
-* Note: This section will not be finished before giving *
-* ENDINPUT-card *
-* what (1..6), sdum no meaning *
-* *
-*********************************************************************
-
- 250 CONTINUE
- IF (LPHOIN) THEN
-
-C CALL PHO_INIT(LINP,IREJ1)
-* ### Read control card from specified file
-* ### Changed by Chiara (original version LINP=5)
- CALL PHO_INIT(7,IREJ1)
-
- IF (IREJ1.NE.0) THEN
- WRITE(LOUT,'(1X,A)')'INIT: reading PHOJET-input failed'
- STOP
- ENDIF
- LPHOIN = .FALSE.
- ENDIF
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = GLAUBERI *
-* *
-* Pre-initialization of impact parameter selection *
-* *
-* what (1..6), sdum no meaning *
-* *
-*********************************************************************
-
- 260 CONTINUE
- IF (IFIRST.NE.99) THEN
- CALL DT_RNDMST(12,34,56,78)
- CALL DT_RNDMTE(1)
- OPEN(40,FILE='shm.out',STATUS='UNKNOWN')
-C OPEN(11,FILE='shm.dbg',STATUS='UNKNOWN')
- IFIRST = 99
- ENDIF
-
- IPPN = 8
- PLOW = 10.0D0
-C IPPN = 1
-C PLOW = 100.0D0
- PHI = 1.0D5
- APLOW = LOG10(PLOW)
- APHI = LOG10(PHI)
- ADP = (APHI-APLOW)/DBLE(IPPN)
-
- IPLOW = 1
- IDIP = 1
- IIP = 5
-C IPLOW = 1
-C IDIP = 1
-C IIP = 1
- IPRANG(1) = 1
- IPRANG(2) = 2
- IPRANG(3) = 5
- IPRANG(4) = 10
- IPRANG(5) = 20
-
- ITLOW = 30
- IDIT = 3
- IIT = 60
-C IDIT = 10
-C IIT = 21
-
- DO 473 NCIT=1,IIT
- IT = ITLOW+(NCIT-1)*IDIT
-C IPHI = IT
-C IDIP = 10
-C IIP = (IPHI-IPLOW)/IDIP
-C IF (IIP.EQ.0) IIP = 1
-C IF (IT.EQ.IPLOW) IIP = 0
-
- DO 472 NCIP=1,IIP
- IP = IPRANG(NCIP)
-CC IF (NCIP.LE.IIP) THEN
-C IP = IPLOW+(NCIP-1)*IDIP
-CC ELSE
-CC IP = IT
-CC ENDIF
- IF (IP.GT.IT) GOTO 472
-
- DO 471 NCP=1,IPPN+1
- APPN = APLOW+DBLE(NCP-1)*ADP
- PPN = 10**APPN
-
- OPEN(12,FILE='shm.sta',STATUS='UNKNOWN')
- WRITE(12,'(1X,2I5,E15.3)') IP,IT,PPN
- CLOSE(12)
-
- XLIM1 = 0.0D0
- XLIM2 = 50.0D0
- XLIM3 = ZERO
- IBIN = 50
- CALL DT_NEWHGR(XDUM,XDUM,XDUM,XDUMB,-1,IHDUM)
- CALL DT_NEWHGR(XLIM1,XLIM2,XLIM3,XDUMB,IBIN,IHSHMA)
-
- NEVFIT = 5
-C IF ((IP.GT.10).OR.(IT.GT.10)) THEN
-C NEVFIT = 5
-C ELSE
-C NEVFIT = 10
-C ENDIF
- SIGAV = 0.0D0
-
- DO 478 I=1,NEVFIT
- CALL DT_SHMAKI(IP,IDUM1,IT,IDUM1,IJPROJ,PPN,99)
- SIGAV = SIGAV+XSPRO(1,1,1)
- DO 479 J=1,50
- XC = DBLE(J)
- CALL DT_FILHGR(XC,BSITE(1,1,1,J),IHSHMA,I)
- 479 CONTINUE
- 478 CONTINUE
-
- CALL DT_EVTHIS(IDUM)
- HEADER = ' BSITE'
-C CALL OUTGEN(IHSHMA,0,0,0,0,0,HEADER,0,NEVFIT,ONE,0,1,-1)
-
-C CALL GENFIT(XPARA)
-C WRITE(40,'(2I4,E11.3,F6.0,5E11.3)')
-C & IP,IT,PPN,SIGAV/DBLE(NEVFIT),XPARA
-
- 471 CONTINUE
-
- 472 CONTINUE
-
- 473 CONTINUE
-
- STOP
-
-*********************************************************************
-* *
-* control card: codewd = FLUCTUAT *
-* *
-* Treatment of cross section fluctuations *
-* *
-* what (1) = 1 treat cross section fluctuations *
-* default: 0. *
-* what (1..6), sdum no meaning *
-* *
-*********************************************************************
-
- 270 CONTINUE
- IFLUCT = 0
- IF (WHAT(1).EQ.ONE) THEN
- IFLUCT = 1
- CALL DT_FLUINI
- ENDIF
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = CENTRAL *
-* *
-* what (1) = 1. central production forced default: 0 *
-* if what (1) < 0 and > -100 *
-* what (2) = min. impact parameter default: 0 *
-* what (3) = max. impact parameter default: b_max *
-* if what (1) < -99 *
-* what (2) = fraction of cross section default: 1 *
-* if what (1) = -1 : evaporation/fzc suppressed *
-* if what (1) < -1 : evaporation/fzc allowed *
-* *
-* what (4..6), sdum no meaning *
-* *
-*********************************************************************
-
- 280 CONTINUE
- ICENTR = INT(WHAT(1))
- IF (ICENTR.LT.0) THEN
- IF (ICENTR.GT.-100) THEN
- BIMIN = WHAT(2)
- BIMAX = WHAT(3)
- ELSE
- XSFRAC = WHAT(2)
- ENDIF
- ENDIF
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = RECOMBIN *
-* *
-* Chain recombination *
-* (recombine S-S and V-V chains to V-S chains) *
-* *
-* what (1) = -1. recombination switched off default: 1 *
-* what (2..6), sdum no meaning *
-* *
-*********************************************************************
-
- 290 CONTINUE
- IRECOM = 1
- IF (WHAT(1).EQ.-1.0D0) IRECOM = 0
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = COMBIJET *
-* *
-* chain fusion (2 q-aq --> qq-aqaq) *
-* *
-* what (1) = 1 fusion treated *
-* default: 0. *
-* what (2) minimum number of uncombined chains from *
-* single projectile or target nucleons *
-* default: 0. *
-* what (3..6), sdum no meaning *
-* *
-*********************************************************************
-
- 300 CONTINUE
- LCO2CR = .FALSE.
- IF (INT(WHAT(1)).EQ.1) LCO2CR = .TRUE.
- IF (WHAT(2).GE.ZERO) CUTOF = WHAT(2)
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = XCUTS *
-* *
-* thresholds for x-sampling *
-* *
-* what (1) defines lower threshold for val.-q x-value (CVQ) *
-* default: 1. *
-* what (2) defines lower threshold for val.-qq x-value (CDQ) *
-* default: 2. *
-* what (3) defines lower threshold for sea-q x-value (CSEA) *
-* default: 0.2 *
-* what (4) sea-q x-values in S-S chains (SSMIMA) *
-* default: 0.14 *
-* what (5) not used *
-* default: 2. *
-* what (6), sdum no meaning *
-* *
-* Note: Lower thresholds (what(1..3)) are def. as x_thr=CXXX/ECM *
-* *
-*********************************************************************
-
- 310 CONTINUE
- IF (WHAT(1).GE.0.5D0) CVQ = WHAT(1)
- IF (WHAT(2).GE.ONE) CDQ = WHAT(2)
- IF (WHAT(3).GE.0.1D0) CSEA = WHAT(3)
- IF (WHAT(4).GE.ZERO) THEN
- SSMIMA = WHAT(4)
- SSMIMQ = SSMIMA**2
- ENDIF
- IF (WHAT(5).GT.2.0D0) VVMTHR = WHAT(5)
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = INTPT *
-* *
-* what (1) = -1 intrinsic transverse momenta of partons *
-* not treated default: 1 *
-* what (2..6), sdum no meaning *
-* *
-*********************************************************************
-
- 320 CONTINUE
- IF (WHAT(1).EQ.-1.0D0) THEN
- LINTPT = .FALSE.
- ELSE
- LINTPT = .TRUE.
- ENDIF
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = CRONINPT *
-* *
-* Cronin effect (multiple scattering of partons at chain ends) *
-* *
-* what (1) = -1 Cronin effect not treated default: 1 *
-* what (2) = 0 scattering parameter default: 0.64 *
-* what (3..6), sdum no meaning *
-* *
-*********************************************************************
-
- 330 CONTINUE
- IF (WHAT(1).EQ.-1.0D0) THEN
- MKCRON = 0
- ELSE
- MKCRON = 1
- ENDIF
- CRONCO = WHAT(2)
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = SEADISTR *
-* *
-* what (1) (XSEACO) sea(x) prop. 1/x**what (1) default: 1. *
-* what (2) (UNON) default: 2. *
-* what (3) (UNOM) default: 1.5 *
-* what (4) (UNOSEA) default: 5. *
-* qdis(x) prop. (1-x)**what (1) etc. *
-* what (5..6), sdum no meaning *
-* *
-*********************************************************************
-
- 340 CONTINUE
- XSEACO = WHAT(1)
- XSEACU = 1.05D0-XSEACO
- UNON = WHAT(2)
- IF (UNON.LT.0.1D0) UNON = 2.0D0
- UNOM = WHAT(3)
- IF (UNOM.LT.0.1D0) UNOM = 1.5D0
- UNOSEA = WHAT(4)
- IF (UNOSEA.LT.0.1D0) UNOSEA = 5.0D0
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = SEASU3 *
-* *
-* Treatment of strange-quarks at chain ends *
-* *
-* what (1) (SEASQ) strange-quark supression factor *
-* iflav = 1.+rndm*(2.+SEASQ) *
-* default: 1. *
-* what (2..6), sdum no meaning *
-* *
-*********************************************************************
-
- 350 CONTINUE
- SEASQ = WHAT(1)
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = DIQUARKS *
-* *
-* what (1) = -1. sea-diquark/antidiquark-pairs not treated *
-* default: 1. *
-* what (2..6), sdum no meaning *
-* *
-*********************************************************************
-
- 360 CONTINUE
- IF (WHAT(1).EQ.-1.0D0) THEN
- LSEADI = .FALSE.
- ELSE
- LSEADI = .TRUE.
- ENDIF
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = RESONANC *
-* *
-* treatment of low mass chains *
-* *
-* what (1) = -1 low chain masses are not corrected for resonance *
-* masses (obsolete for BAMJET-fragmentation) *
-* default: 1. *
-* what (2) = -1 massless partons default: 1. (massive) *
-* default: 1. (massive) *
-* what (3) = -1 chain-system containing chain of too small *
-* mass is rejected (note: this does not fully *
-* apply to S-S chains) default: 0. *
-* what (4..6), sdum no meaning *
-* *
-*********************************************************************
-
- 370 CONTINUE
- IRESCO = 1
- IMSHL = 1
- IRESRJ = 0
- IF (WHAT(1).EQ.-ONE) IRESCO = 0
- IF (WHAT(2).EQ.-ONE) IMSHL = 0
- IF (WHAT(3).EQ.-ONE) IRESRJ = 1
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = DIFFRACT *
-* *
-* Treatment of diffractive events *
-* *
-* what (1) = (ISINGD) 0 no single diffraction *
-* 1 single diffraction included *
-* +-2 single diffractive events only *
-* +-3 projectile single diffraction only *
-* +-4 target single diffraction only *
-* -5 double pomeron exchange only *
-* (neg. sign applies to PHOJET events) *
-* default: 0. *
-* *
-* what (2) = (IDOUBD) 0 no double diffraction *
-* 1 double diffraction included *
-* 2 double diffractive events only *
-* default: 0. *
-* what (3) = 1 projectile diffraction treated (2-channel form.) *
-* default: 0. *
-* what (4) = alpha-parameter in projectile diffraction *
-* default: 0. *
-* what (5..6), sdum no meaning *
-* *
-*********************************************************************
-
- 380 CONTINUE
- IF (ABS(WHAT(1)).GT.ZERO) ISINGD = INT(WHAT(1))
- IF (ABS(WHAT(2)).GT.ZERO) IDOUBD = INT(WHAT(2))
- IF ((ISINGD.GT.1).AND.(IDOUBD.GT.1)) THEN
- WRITE(LOUT,1380)
- 1380 FORMAT(1X,'INIT: inconsistent DIFFRACT - input !',/,
- & 11X,'IDOUBD is reset to zero')
- IDOUBD = 0
- ENDIF
- IF (WHAT(3).GT.ZERO) DIBETA = WHAT(3)
- IF (WHAT(4).GT.ZERO) DIALPH = WHAT(4)
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = SINGLECH *
-* *
-* what (1) = 1. Regge contribution (one chain) included *
-* default: 0. *
-* what (2..6), sdum no meaning *
-* *
-*********************************************************************
-
- 390 CONTINUE
- ISICHA = 0
- IF (WHAT(1).EQ.ONE) ISICHA = 1
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = NOFRAGME *
-* *
-* biased chain hadronization *
-* *
-* what (1..6) = -1 no of hadronizsation of S-S chains *
-* = -2 no of hadronizsation of D-S chains *
-* = -3 no of hadronizsation of S-D chains *
-* = -4 no of hadronizsation of S-V chains *
-* = -5 no of hadronizsation of D-V chains *
-* = -6 no of hadronizsation of V-S chains *
-* = -7 no of hadronizsation of V-D chains *
-* = -8 no of hadronizsation of V-V chains *
-* = -9 no of hadronizsation of comb. chains *
-* default: complete hadronization *
-* sdum no meaning *
-* *
-*********************************************************************
-
- 400 CONTINUE
- DO 401 I=1,6
- ICHAIN = INT(WHAT(I))
- IF ((ICHAIN.LE.-1).AND.(ICHAIN.GE.-9))
- & LHADRO(ABS(ICHAIN)) = .FALSE.
- 401 CONTINUE
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = HADRONIZE *
-* *
-* hadronization model and parameter switch *
-* *
-* what (1) = 1 hadronization via BAMJET *
-* = 2 hadronization via JETSET *
-* default: 2 *
-* what (2) = 1..3 parameter set to be used *
-* JETSET: 3 sets available *
-* ( = 3 default JETSET-parameters) *
-* BAMJET: 1 set available *
-* default: 1 *
-* what (3..6), sdum no meaning *
-* *
-*********************************************************************
-
- 410 CONTINUE
- IWHAT1 = INT(WHAT(1))
- IWHAT2 = INT(WHAT(2))
- IF ((IWHAT1.EQ.1).OR.(IWHAT1.EQ.2)) IFRAG(1) = IWHAT1
- IF ((IWHAT1.EQ.2).AND.(IWHAT2.GE.1).AND.(IWHAT2.LE.3))
- & IFRAG(2) = IWHAT2
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = POPCORN *
-* *
-* "Popcorn-effect" in fragmentation and diquark breaking diagrams *
-* *
-* what (1) = (PDB) frac. of diquark fragmenting directly into *
-* baryons (PYTHIA/JETSET fragmentation) *
-* (JETSET: = 0. Popcorn mechanism switched off) *
-* default: 0.5 *
-* what (2) = probability for accepting a diquark breaking *
-* diagram involving the generation of a u/d quark- *
-* antiquark pair default: 0.0 *
-* what (3) = same a what (2), here for s quark-antiquark pair *
-* default: 0.0 *
-* what (4..6), sdum no meaning *
-* *
-*********************************************************************
-
- 420 CONTINUE
- IF (WHAT(1).GE.0.0D0) PDB = WHAT(1)
- IF (WHAT(2).GE.0.0D0) THEN
- PDBSEA(1) = WHAT(2)
- PDBSEA(2) = WHAT(2)
- ENDIF
- IF (WHAT(3).GE.0.0D0) PDBSEA(3) = WHAT(3)
- DO 421 I=1,8
- DBRKA(1,I) = DBRKR(1,I)*PDBSEA(1)/(1.D0-PDBSEA(1))
- DBRKA(2,I) = DBRKR(2,I)*PDBSEA(2)/(1.D0-PDBSEA(2))
- DBRKA(3,I) = DBRKR(3,I)*PDBSEA(3)/(1.D0-PDBSEA(3))
- 421 CONTINUE
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = PARDECAY *
-* *
-* what (1) = 1. Sigma0/Asigma0 are decaying within JETSET *
-* = 2. pion^0 decay after intranucl. cascade *
-* default: no decay *
-* what (2..6), sdum no meaning *
-* *
-*********************************************************************
-
- 430 CONTINUE
- IF (WHAT(1).EQ.ONE) ISIG0 = 1
- IF (WHAT(1).EQ.2.0D0) IPI0 = 1
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = BEAM *
-* *
-* definition of beam parameters *
-* *
-* what (1/2) > 0 : energy of beam 1/2 (GeV) *
-* < 0 : abs(what(1/2)) energy per charge of *
-* beam 1/2 (GeV) *
-* (beam 1 is directed into positive z-direction) *
-* what (3) beam crossing angle, defined as 2x angle between *
-* one beam and the z-axis (micro rad) *
-* what (4) angle with x-axis defining the collision plane *
-* what (5..6), sdum no meaning *
-* *
-* Note: this card requires previously defined projectile and *
-* target identities (PROJPAR, TARPAR) *
-* *
-*********************************************************************
-
- 440 CONTINUE
- CALL DT_BEAMPR(WHAT,PPN,1)
- EPN = ZERO
- CMENER = ZERO
- LEINP = .TRUE.
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = LUND-MSTU *
-* *
-* set parameter MSTU in JETSET-common /LUDAT1/ *
-* *
-* what (1) = index according to LUND-common block *
-* what (2) = new value of MSTU( int(what(1)) ) *
-* what (3), what(4) and what (5), what(6) further *
-* parameter in the same way as what (1) and *
-* what (2) *
-* default: default-Lund or corresponding to *
-* the set given in HADRONIZE *
-* *
-*********************************************************************
-
- 450 CONTINUE
- IF (WHAT(1).GT.ZERO) THEN
- NMSTU = NMSTU+1
- IMSTU(NMSTU) = INT(WHAT(1))
- MSTUX(NMSTU) = INT(WHAT(2))
- ENDIF
- IF (WHAT(3).GT.ZERO) THEN
- NMSTU = NMSTU+1
- IMSTU(NMSTU) = INT(WHAT(3))
- MSTUX(NMSTU) = INT(WHAT(4))
- ENDIF
- IF (WHAT(5).GT.ZERO) THEN
- NMSTU = NMSTU+1
- IMSTU(NMSTU) = INT(WHAT(5))
- MSTUX(NMSTU) = INT(WHAT(6))
- ENDIF
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = LUND-MSTJ *
-* *
-* set parameter MSTJ in JETSET-common /LUDAT1/ *
-* *
-* what (1) = index according to LUND-common block *
-* what (2) = new value of MSTJ( int(what(1)) ) *
-* what (3), what(4) and what (5), what(6) further *
-* parameter in the same way as what (1) and *
-* what (2) *
-* default: default-Lund or corresponding to *
-* the set given in HADRONIZE *
-* *
-*********************************************************************
-
- 451 CONTINUE
- IF (WHAT(1).GT.ZERO) THEN
- NMSTJ = NMSTJ+1
- IMSTJ(NMSTJ) = INT(WHAT(1))
- MSTJX(NMSTJ) = INT(WHAT(2))
- ENDIF
- IF (WHAT(3).GT.ZERO) THEN
- NMSTJ = NMSTJ+1
- IMSTJ(NMSTJ) = INT(WHAT(3))
- MSTJX(NMSTJ) = INT(WHAT(4))
- ENDIF
- IF (WHAT(5).GT.ZERO) THEN
- NMSTJ = NMSTJ+1
- IMSTJ(NMSTJ) = INT(WHAT(5))
- MSTJX(NMSTJ) = INT(WHAT(6))
- ENDIF
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = LUND-MDCY *
-* *
-* set parameter MDCY(I,1) for particle decays in JETSET-common *
-* /LUDAT3/ *
-* *
-* what (1-6) = PDG particle index of particle which should *
-* not decay *
-* default: default-Lund or forced in *
-* DT_INITJS *
-* *
-*********************************************************************
-
- 452 CONTINUE
- DO 4521 I=1,6
- IF (WHAT(I).NE.ZERO) THEN
-
- KC = PYCOMP(INT(WHAT(I)))
-
- MDCY(KC,1) = 0
- ENDIF
- 4521 CONTINUE
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = LUND-PARJ *
-* *
-* set parameter PARJ in JETSET-common /LUDAT1/ *
-* *
-* what (1) = index according to LUND-common block *
-* what (2) = new value of PARJ( int(what(1)) ) *
-* what (3), what(4) and what (5), what(6) further *
-* parameter in the same way as what (1) and *
-* what (2) *
-* default: default-Lund or corresponding to *
-* the set given in HADRONIZE *
-* *
-*********************************************************************
-
- 460 CONTINUE
- IF (WHAT(1).NE.ZERO) THEN
- NPARJ = NPARJ+1
- IPARJ(NPARJ) = INT(WHAT(1))
- PARJX(NPARJ) = WHAT(2)
- ENDIF
- IF (WHAT(3).NE.ZERO) THEN
- NPARJ = NPARJ+1
- IPARJ(NPARJ) = INT(WHAT(3))
- PARJX(NPARJ) = WHAT(4)
- ENDIF
- IF (WHAT(5).NE.ZERO) THEN
- NPARJ = NPARJ+1
- IPARJ(NPARJ) = INT(WHAT(5))
- PARJX(NPARJ) = WHAT(6)
- ENDIF
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = LUND-PARU *
-* *
-* set parameter PARJ in JETSET-common /LUDAT1/ *
-* *
-* what (1) = index according to LUND-common block *
-* what (2) = new value of PARU( int(what(1)) ) *
-* what (3), what(4) and what (5), what(6) further *
-* parameter in the same way as what (1) and *
-* what (2) *
-* default: default-Lund or corresponding to *
-* the set given in HADRONIZE *
-* *
-*********************************************************************
-
- 470 CONTINUE
- IF (WHAT(1).GT.ZERO) THEN
- NPARU = NPARU+1
- IPARU(NPARU) = INT(WHAT(1))
- PARUX(NPARU) = WHAT(2)
- ENDIF
- IF (WHAT(3).GT.ZERO) THEN
- NPARU = NPARU+1
- IPARU(NPARU) = INT(WHAT(3))
- PARUX(NPARU) = WHAT(4)
- ENDIF
- IF (WHAT(5).GT.ZERO) THEN
- NPARU = NPARU+1
- IPARU(NPARU) = INT(WHAT(5))
- PARUX(NPARU) = WHAT(6)
- ENDIF
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = OUTLEVEL *
-* *
-* output control switches *
-* *
-* what (1) = internal rejection informations default: 0 *
-* what (2) = energy-momentum conservation check output *
-* default: 0 *
-* what (3) = internal warning messages default: 0 *
-* what (4..6), sdum not yet used *
-* *
-*********************************************************************
-
- 480 CONTINUE
- DO 481 K=1,6
- IOULEV(K) = INT(WHAT(K))
- 481 CONTINUE
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = FRAME *
-* *
-* frame in which final state is given in DTEVT1 *
-* *
-* what (1) = 1 target rest frame (laboratory) *
-* = 2 nucleon-nucleon cms *
-* default: 1 *
-* *
-*********************************************************************
-
- 490 CONTINUE
- KFRAME = INT(WHAT(1))
- IF ((KFRAME.GE.1).AND.(KFRAME.LE.2)) IFRAME = KFRAME
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = L-TAG *
-* *
-* lepton tagger: *
-* definition of kinematical cuts for radiated photon and *
-* outgoing lepton detection in lepton-nucleus interactions *
-* *
-* what (1) = y_min *
-* what (2) = y_max *
-* what (3) = Q^2_min *
-* what (4) = Q^2_max *
-* what (5) = theta_min (Lab) *
-* what (6) = theta_max (Lab) *
-* default: no cuts *
-* sdum no meaning *
-* *
-*********************************************************************
-
- 500 CONTINUE
- YMIN = WHAT(1)
- YMAX = WHAT(2)
- Q2MIN = WHAT(3)
- Q2MAX = WHAT(4)
- THMIN = WHAT(5)
- THMAX = WHAT(6)
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = L-ETAG *
-* *
-* lepton tagger: *
-* what (1) = min. outgoing lepton energy (in Lab) *
-* what (2) = min. photon energy (in Lab) *
-* what (3) = max. photon energy (in Lab) *
-* default: no cuts *
-* what (2..6), sdum no meaning *
-* *
-*********************************************************************
-
- 510 CONTINUE
- ELMIN = MAX(WHAT(1),ZERO)
- EGMIN = MAX(WHAT(2),ZERO)
- EGMAX = MAX(WHAT(3),ZERO)
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = ECMS-CUT *
-* *
-* what (1) = min. c.m. energy to be sampled *
-* what (2) = max. c.m. energy to be sampled *
-* what (3) = min x_Bj to be sampled *
-* default: no cuts *
-* what (3..6), sdum no meaning *
-* *
-*********************************************************************
-
- 520 CONTINUE
- ECMIN = WHAT(1)
- ECMAX = WHAT(2)
- IF (ECMIN.GT.ECMAX) ECMIN = ECMAX
- XBJMIN = MAX(WHAT(3),ZERO)
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = VDM-PAR1 *
-* *
-* parameters in gamma-nucleus cross section calculation *
-* *
-* what (1) = Lambda^2 default: 2. *
-* what (2) lower limit in M^2 integration *
-* = 1 (3m_pi)^2 *
-* = 2 (m_rho0)^2 *
-* = 3 (m_phi)^2 default: 1 *
-* what (3) upper limit in M^2 integration *
-* = 1 s/2 *
-* = 2 s/4 *
-* = 3 s default: 3 *
-* what (4) CKMT F_2 structure function *
-* = 2212 proton *
-* = 100 deuteron default: 2212 *
-* what (5) calculation of gamma-nucleon xsections *
-* = 1 according to CKMT-parametrization of F_2 *
-* = 2 integrating SIGVP over M^2 *
-* = 3 using SIGGA *
-* = 4 PHOJET cross sections default: 4 *
-* *
-* what (6), sdum no meaning *
-* *
-*********************************************************************
-
- 530 CONTINUE
- IF (WHAT(1).GE.ZERO) RL2 = WHAT(1)
- IF ((WHAT(2).GE.1).AND.(WHAT(2).LE.3)) INTRGE(1) = INT(WHAT(2))
- IF ((WHAT(3).GE.1).AND.(WHAT(3).LE.3)) INTRGE(2) = INT(WHAT(3))
- IF ((WHAT(4).EQ.2212).OR.(WHAT(4).EQ.100)) IDPDF = INT(WHAT(4))
- IF ((WHAT(5).GE.1).AND.(WHAT(5).LE.4)) MODEGA = INT(WHAT(5))
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = HISTOGRAM *
-* *
-* activate different classes of histograms *
-* *
-* default: no histograms *
-* *
-*********************************************************************
-
- 540 CONTINUE
- DO 541 J=1,6
- IF ((WHAT(J).GE.100).AND.(WHAT(J).LE.150)) THEN
- IHISPP(INT(WHAT(J))-100) = 1
- ELSEIF ((ABS(WHAT(J)).GE.200).AND.(ABS(WHAT(J)).LE.250)) THEN
- IHISXS(INT(ABS(WHAT(J)))-200) = 1
- IF (WHAT(J).LT.ZERO) IXSTBL = 1
- ENDIF
- 541 CONTINUE
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = XS-TABLE *
-* *
-* output of cross section table for requested interaction *
-* - particle production deactivated ! - *
-* *
-* what (1) lower energy limit for tabulation *
-* > 0 Lab. frame *
-* < 0 nucleon-nucleon cms *
-* what (2) upper energy limit for tabulation *
-* > 0 Lab. frame *
-* < 0 nucleon-nucleon cms *
-* what (3) > 0 # of equidistant lin. bins in E *
-* < 0 # of equidistant log. bins in E *
-* what (4) lower limit of particle virtuality (photons) *
-* what (5) upper limit of particle virtuality (photons) *
-* what (6) > 0 # of equidistant lin. bins in Q^2 *
-* < 0 # of equidistant log. bins in Q^2 *
-* *
-*********************************************************************
-
- 550 CONTINUE
- IF (WHAT(1).EQ.99999.0D0) THEN
- IRATIO = INT(WHAT(2))
- GOTO 10
- ENDIF
- CMENER = ABS(WHAT(2))
- IF (.NOT.LXSTAB) THEN
-
- CALL BERTTP
- CALL INCINI
-
- ENDIF
- IF ((.NOT.LXSTAB).OR.(CMENER.NE.CMEOLD)) THEN
- CMEOLD = CMENER
- IF (WHAT(2).GT.ZERO)
- & CMENER = SQRT(2.0D0*AAM(1)**2+2.0D0*WHAT(2)*AAM(1))
- EPN = ZERO
- PPN = ZERO
-C WRITE(LOUT,*) 'CMENER = ',CMENER
- CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,CMENER,1)
- CALL DT_PHOINI
- ENDIF
- CALL DT_XSTABL(WHAT,IXSQEL,IRATIO)
- IXSQEL = 0
- LXSTAB = .TRUE.
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = GLAUB-PAR *
-* *
-* parameters in Glauber-formalism *
-* *
-* what (1) # of nucleon configurations sampled in integration *
-* over nuclear desity default: 1000 *
-* what (2) # of bins for integration over impact-parameter and *
-* for profile-function calculation default: 49 *
-* what (3) = 1 calculation of tot., el. and qel. cross sections *
-* default: 0 *
-* what (4) = 1 read pre-calculated impact-parameter distrib. *
-* from "sdum".glb *
-* =-1 dump pre-calculated impact-parameter distrib. *
-* into "sdum".glb *
-* = 100 read pre-calculated impact-parameter distrib. *
-* for variable projectile/target/energy runs *
-* from "sdum".glb *
-* default: 0 *
-* what (5..6) no meaning *
-* sdum if |what (4)| = 1 name of in/output-file (sdum.glb) *
-* *
-*********************************************************************
-
- 560 CONTINUE
- IF (WHAT(1).GT.ZERO) JSTATB = INT(WHAT(1))
- IF (WHAT(2).GT.ZERO) JBINSB = INT(WHAT(2))
- IF (WHAT(3).EQ.ONE) LPROD = .FALSE.
- IF ((ABS(WHAT(4)).EQ.ONE).OR.(WHAT(4).EQ.100)) THEN
- IOGLB = INT(WHAT(4))
- CGLB = SDUM
- ENDIF
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = GLAUB-INI *
-* *
-* pre-initialization of profile function *
-* *
-* what (1) lower energy limit for initialization *
-* > 0 Lab. frame *
-* < 0 nucleon-nucleon cms *
-* what (2) upper energy limit for initialization *
-* > 0 Lab. frame *
-* < 0 nucleon-nucleon cms *
-* what (3) > 0 # of equidistant lin. bins in E *
-* < 0 # of equidistant log. bins in E *
-* what (4) maximum projectile mass number for which the *
-* Glauber data are initialized for each *
-* projectile mass number *
-* (if <= mass given with the PROJPAR-card) *
-* default: 18 *
-* what (5) steps in mass number starting from what (4) *
-* up to mass number defined with PROJPAR-card *
-* for which Glauber data are initialized *
-* default: 5 *
-* what (6) no meaning *
-* sdum no meaning *
-* *
-*********************************************************************
-
- 565 CONTINUE
- IOGLB = -100
- CALL DT_GLBINI(WHAT)
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = VDM-PAR2 *
-* *
-* parameters in gamma-nucleus cross section calculation *
-* *
-* what (1) = 0 no suppression of shadowing by direct photon *
-* processes *
-* = 1 suppression .. default: 1 *
-* what (2) = 0 no suppression of shadowing by anomalous *
-* component if photon-F_2 *
-* = 1 suppression .. default: 1 *
-* what (3) = 0 no suppression of shadowing by coherence *
-* length of the photon *
-* = 1 suppression .. default: 1 *
-* what (4) = 1 longitudinal polarized photons are taken into *
-* account *
-* eps*R*Q^2/M^2 = what(4)*Q^2/M^2 default: 0 *
-* what (5..6), sdum no meaning *
-* *
-*********************************************************************
-
- 570 CONTINUE
- IF ((WHAT(1).EQ.ZERO).OR.(WHAT(1).EQ.ONE)) ISHAD(1) = INT(WHAT(1))
- IF ((WHAT(2).EQ.ZERO).OR.(WHAT(2).EQ.ONE)) ISHAD(2) = INT(WHAT(2))
- IF ((WHAT(3).EQ.ZERO).OR.(WHAT(3).EQ.ONE)) ISHAD(3) = INT(WHAT(3))
- EPSPOL = WHAT(4)
- GOTO 10
-
-*********************************************************************
-* *
-* control card: XS-QELPRO *
-* *
-* what (1..6), sdum no meaning *
-* *
-*********************************************************************
-
- 580 CONTINUE
- IXSQEL = ABS(WHAT(1))
- GOTO 10
-
-*********************************************************************
-* *
-* control card: RNDMINIT *
-* *
-* initialization of random number generator *
-* *
-* what (1..4) values for initialization (= 1..168) *
-* what (5..6), sdum no meaning *
-* *
-*********************************************************************
-
- 590 CONTINUE
- IF ((WHAT(1).LT.1.0D0).OR.(WHAT(1).GT.168.0D0)) THEN
- NA1 = 22
- ELSE
- NA1 = WHAT(1)
- ENDIF
- IF ((WHAT(2).LT.1.0D0).OR.(WHAT(2).GT.168.0D0)) THEN
- NA2 = 54
- ELSE
- NA2 = WHAT(2)
- ENDIF
- IF ((WHAT(3).LT.1.0D0).OR.(WHAT(3).GT.168.0D0)) THEN
- NA3 = 76
- ELSE
- NA3 = WHAT(3)
- ENDIF
- IF ((WHAT(4).LT.1.0D0).OR.(WHAT(4).GT.168.0D0)) THEN
- NA4 = 92
- ELSE
- NA4 = WHAT(4)
- ENDIF
- CALL DT_RNDMST(NA1,NA2,NA3,NA4)
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = LEPTO-CUT *
-* *
-* set parameter CUT in LEPTO-common /LEPTOU/ *
-* *
-* what (1) = index in CUT-array *
-* what (2) = new value of CUT( int(what(1)) ) *
-* what (3), what(4) and what (5), what(6) further *
-* parameter in the same way as what (1) and *
-* what (2) *
-* default: default-LEPTO parameters *
-* *
-*********************************************************************
-
- 600 CONTINUE
- IF (WHAT(1).GT.ZERO) CUT(INT(WHAT(1))) = WHAT(2)
- IF (WHAT(3).GT.ZERO) CUT(INT(WHAT(3))) = WHAT(4)
- IF (WHAT(5).GT.ZERO) CUT(INT(WHAT(5))) = WHAT(6)
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = LEPTO-LST *
-* *
-* set parameter LST in LEPTO-common /LEPTOU/ *
-* *
-* what (1) = index in LST-array *
-* what (2) = new value of LST( int(what(1)) ) *
-* what (3), what(4) and what (5), what(6) further *
-* parameter in the same way as what (1) and *
-* what (2) *
-* default: default-LEPTO parameters *
-* *
-*********************************************************************
-
- 610 CONTINUE
- IF (WHAT(1).GT.ZERO) LST(INT(WHAT(1))) = INT(WHAT(2))
- IF (WHAT(3).GT.ZERO) LST(INT(WHAT(3))) = INT(WHAT(4))
- IF (WHAT(5).GT.ZERO) LST(INT(WHAT(5))) = INT(WHAT(6))
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = LEPTO-PARL *
-* *
-* set parameter PARL in LEPTO-common /LEPTOU/ *
-* *
-* what (1) = index in PARL-array *
-* what (2) = new value of PARL( int(what(1)) ) *
-* what (3), what(4) and what (5), what(6) further *
-* parameter in the same way as what (1) and *
-* what (2) *
-* default: default-LEPTO parameters *
-* *
-*********************************************************************
-
- 620 CONTINUE
- IF (WHAT(1).GT.ZERO) PARL(INT(WHAT(1))) = WHAT(2)
- IF (WHAT(3).GT.ZERO) PARL(INT(WHAT(3))) = WHAT(4)
- IF (WHAT(5).GT.ZERO) PARL(INT(WHAT(5))) = WHAT(6)
- GOTO 10
-
-*********************************************************************
-* *
-* control card: codewd = START *
-* *
-* what (1) = number of events default: 100. *
-* what (2) = 0 Glauber initialization follows *
-* = 1 Glauber initialization supressed, fitted *
-* results are used instead *
-* (this does not apply if emulsion-treatment *
-* is requested) *
-* = 2 Glauber initialization is written to *
-* output-file shmakov.out *
-* = 3 Glauber initialization is read from input-file *
-* shmakov.out default: 0 *
-* what (3..6) no meaning *
-* what (3..6) no meaning *
-* *
-*********************************************************************
-
- 630 CONTINUE
-
-* check for cross-section table output only
- IF (LXSTAB) STOP
-
- NCASES = INT(WHAT(1))
- IF (NCASES.LE.0) NCASES = 100
- IGLAU = INT(WHAT(2))
- IF ((IGLAU.NE.1).AND.(IGLAU.NE.2).AND.(IGLAU.NE.3))
- & IGLAU = 0
-
- NPMASS = IP
- NPCHAR = IPZ
- NTMASS = IT
- NTCHAR = ITZ
- IDP = IJPROJ
- IDT = IJTARG
- IF (IDP.LE.0) IDP = 1
-* muon neutrinos: temporary (missing index)
-* (new patch in projpar: therefore the following this is probably not
-* necessary anymore..)
-C IF (IDP.EQ.26) IDP = 5
-C IF (IDP.EQ.27) IDP = 6
-
-* redefine collision energy
- IF (LEINP) THEN
- IF (ABS(VAREHI).GT.ZERO) THEN
- PDUM = ZERO
- IF (VARELO.LT.EHADLO) VARELO = EHADLO
- CALL DT_LTINI(IDP,IDT,VARELO,PDUM,VARCLO,1)
- PDUM = ZERO
- CALL DT_LTINI(IDP,IDT,VAREHI,PDUM,VARCHI,1)
- ENDIF
- CALL DT_LTINI(IDP,IDT,EPN,PPN,CMENER,1)
- ELSE
- WRITE(LOUT,1003)
- 1003 FORMAT(1X,'INIT: collision energy not defined!',/,
- & 1X,' -program stopped- ')
- STOP
- ENDIF
-
-* switch off evaporation (even if requested) if central coll. requ.
- IF ((ICENTR.EQ.-1).OR.(ICENTR.GT.0).OR.(XSFRAC.LT.0.5D0)) THEN
- IF (LEVPRT) THEN
- WRITE(LOUT,1004)
- 1004 FORMAT(1X,/,'Warning! Evaporation request rejected since',
- & ' central collisions forced.')
- LEVPRT = .FALSE.
- LDEEXG = .FALSE.
- LHEAVY = .FALSE.
- ENDIF
- ENDIF
-
-* initialization of evaporation-module
-
-* initialize evaporation if the code is not used as Fluka event generator
- IF (ITRSPT.NE.1) THEN
-* CALL BERTTP
-* CALL INCINI
- ENDIF
- IF (LEVPRT) LHEAVY = .TRUE.
-
-
-* save the default JETSET-parameter
- CALL DT_JSPARA(0)
-
-* force use of phojet for g-A
- IF ((IDP.EQ.7).AND.(MCGENE.NE.3)) MCGENE = 2
-* initialization of nucleon-nucleon event generator
- IF (MCGENE.EQ.2) CALL DT_PHOINI
-* initialization of LEPTO event generator
- IF (MCGENE.EQ.3) THEN
-
- STOP ' This version does not contain LEPTO !'
-
- ENDIF
-
-* initialization of quasi-elastic neutrino scattering
- IF (MCGENE.EQ.4) THEN
- IF (IJPROJ.EQ.5) THEN
- NEUTYP = 1
- ELSEIF (IJPROJ.EQ.6) THEN
- NEUTYP = 2
- ELSEIF (IJPROJ.EQ.135) THEN
- NEUTYP = 3
- ELSEIF (IJPROJ.EQ.136) THEN
- NEUTYP = 4
- ELSEIF (IJPROJ.EQ.133) THEN
- NEUTYP = 5
- ELSEIF (IJPROJ.EQ.134) THEN
- NEUTYP = 6
- ENDIF
- ENDIF
-
-* normalize fractions of emulsion components
- IF (NCOMPO.GT.0) THEN
- SUMFRA = ZERO
- DO 491 I=1,NCOMPO
- SUMFRA = SUMFRA+EMUFRA(I)
- 491 CONTINUE
- IF (SUMFRA.GT.ZERO) THEN
- DO 492 I=1,NCOMPO
- EMUFRA(I) = EMUFRA(I)/SUMFRA
- 492 CONTINUE
- ENDIF
- ENDIF
-
-* disallow Cronin's multiple scattering for nucleus-nucleus interactions
- IF ((IP.GT.1).AND.(MKCRON.GT.0)) THEN
- WRITE(LOUT,1005)
- 1005 FORMAT(/,1X,'INIT: multiple scattering disallowed',/)
- MKCRON = 0
- ENDIF
-
-* initialization of Glauber-formalism (moved to xAEVT, sr 26.3.96)
-C IF (NCOMPO.LE.0) THEN
-C CALL DT_SHMAKI(IP,IPZ,IT,ITZ,IDP,PPN,IGLAU)
-C ELSE
-C DO 493 I=1,NCOMPO
-C CALL DT_SHMAKI(IP,IPZ,IEMUMA(I),IEMUCH(I),IDP,PPN,0)
-C 493 CONTINUE
-C ENDIF
-
-* pre-tabulation of elastic cross-sections
- CALL DT_SIGTBL(JDUM,JDUM,DUM,DUM,-1)
-
- CALL DT_XTIME
-
- RETURN
-
-*********************************************************************
-* *
-* control card: codewd = STOP *
-* *
-* stop of the event generation *
-* *
-* what (1..6) no meaning *
-* *
-*********************************************************************
-
- 9999 CONTINUE
- WRITE(LOUT,9000)
- 9000 FORMAT(1X,'---> unexpected end of input !')
-
- 640 CONTINUE
- STOP
-
- END
-*
-*===kkinc==============================================================*
-*
-CDECK ID>, DT_KKINC
- SUBROUTINE DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,
- & IREJ)
-
-************************************************************************
-* Treatment of complete nucleus-nucleus or hadron-nucleus scattering *
-* This subroutine is an update of the previous version written *
-* by J. Ranft/ H.-J. Moehring. *
-* This version dated 19.11.95 is written by S. Roesler *
-************************************************************************
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( LINP = 5 ,
- & LOUT = 6 ,
- & LDAT = 9 )
-
- PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY5=1.0D-5,
- & TINY2=1.0D-2,TINY3=1.0D-3)
-
- LOGICAL LFZC
-
-* event history
-
- PARAMETER (NMXHKK=200000)
-
- COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
- & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
- & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
-* extended event history
- COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
- & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
- & IHIST(2,NMXHKK)
-* particle properties (BAMJET index convention)
- CHARACTER*8 ANAME
- COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
- & IICH(210),IIBAR(210),K1(210),K2(210)
-* properties of interacting particles
- COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
-* Lorentz-parameters of the current interaction
- COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
- & UMO,PPCM,EPROJ,PPROJ
-* flags for input different options
- LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
- COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
- & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
-* flags for particle decays
- COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
- & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
- & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
-* cuts for variable energy runs
- COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
-* Glauber formalism: flags and parameters for statistics
- LOGICAL LPROD
- CHARACTER*8 CGLB
- COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
-
- DIMENSION WHAT(6)
-
- IREJ = 0
- ILOOP = 0
- 100 CONTINUE
- IF (ILOOP.EQ.4) THEN
- WRITE(LOUT,1000) NEVHKK
- 1000 FORMAT(1X,'KKINC: event ',I8,' rejected!')
- GOTO 9999
- ENDIF
- ILOOP = ILOOP+1
-
-* variable energy-runs, recalculate parameters for LT's
- IF ((ABS(VAREHI).GT.ZERO).OR.(IOGLB.EQ.100)) THEN
- PDUM = ZERO
- CDUM = ZERO
- CALL DT_LTINI(IDP,1,EPN,PDUM,CDUM,1)
- ENDIF
- IF (EPN.GT.EPROJ) THEN
- WRITE(LOUT,'(A,E9.3,2A,E9.3,A)')
- & ' Requested energy (',EPN,'GeV) exceeds',
- & ' initialization energy (',EPROJ,'GeV) !'
- STOP
- ENDIF
-
-* re-initialize /DTPRTA/
- IP = NPMASS
- IPZ = NPCHAR
- IT = NTMASS
- ITZ = NTCHAR
- IJPROJ = IDP
- IBPROJ = IIBAR(IJPROJ)
-
-* calculate nuclear potentials (common /DTNPOT/)
- CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
-
-* initialize treatment for residual nuclei
- CALL DT_RESNCL(EPN,NLOOP,1)
-
-* sample hadron/nucleus-nucleus interaction
- CALL DT_KKEVNT(KKMAT,IREJ1)
- IF (IREJ1.GT.0) THEN
- IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKINC'
- GOTO 9999
- ENDIF
-
- IF ((NPMASS.GT.1).OR.(NTMASS.GT.1)) THEN
-
-* intranuclear cascade of final state particles for KTAUGE generations
-* of secondaries
- CALL DT_FOZOCA(LFZC,IREJ1)
- IF (IREJ1.GT.0) THEN
- IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKINC'
- GOTO 9999
- ENDIF
-
-* baryons unable to escape the nuclear potential are treated as
-* excited nucleons (ISTHKK=15,16)
- CALL DT_SCN4BA
-
-* decay of resonances produced in intranuclear cascade processes
-**sr 15-11-95 should be obsolete
-C IF (LFZC) CALL DT_DECAY1
-
- 101 CONTINUE
-* treatment of residual nuclei
- CALL DT_RESNCL(EPN,NLOOP,2)
-
-* evaporation / fission / fragmentation
-* (if intranuclear cascade was sampled only)
- IF (LFZC) THEN
- CALL DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ1)
- IF (IREJ1.GT.1) GOTO 101
- IF (IREJ1.EQ.1) GOTO 100
- ENDIF
-
- ENDIF
-
-* transform finale state into Lab.
- IFLAG = 2
- CALL DT_BEAMPR(WHAT,DUM,IFLAG)
- IF ((IFRAME.EQ.1).AND.(IFLAG.EQ.-1)) CALL DT_LT2LAB
-
- IF (IPI0.EQ.1) CALL DT_DECPI0
-
-C IF (NEVHKK.EQ.5) CALL DT_EVTOUT(4)
-
- RETURN
- 9999 CONTINUE
- IREJ = 1
- RETURN
- END
-*
-*===defaul=============================================================*
-*
-CDECK ID>, DT_DEFAUL
- SUBROUTINE DT_DEFAUL(EPN,PPN)
-
-************************************************************************
-* Variables are set to default values. *
-* This version dated 8.5.95 is written by S. Roesler. *
-************************************************************************
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
- PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
- PARAMETER (TWOPI = 6.283185307179586454D+00)
-
-* particle properties (BAMJET index convention)
- CHARACTER*8 ANAME
- COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
- & IICH(210),IIBAR(210),K1(210),K2(210)
-* nuclear potential
- LOGICAL LFERMI
- COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
- & EBINDP(2),EBINDN(2),EPOT(2,210),
- & ETACOU(2),ICOUL,LFERMI
-* interface HADRIN-DPM
- COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
-* central particle production, impact parameter biasing
- COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
-* properties of interacting particles
- COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
-* properties of photon/lepton projectiles
- COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
-
- PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
-
-* emulsion treatment
- COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
- & NCOMPO,IEMUL
-* parameter for intranuclear cascade
- LOGICAL LPAULI
- COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
-* various options for treatment of partons (DTUNUC 1.x)
-* (chain recombination, Cronin,..)
- LOGICAL LCO2CR,LINTPT
- COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
- & LCO2CR,LINTPT
-* threshold values for x-sampling (DTUNUC 1.x)
- COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
- & SSMIMQ,VVMTHR
-* flags for input different options
- LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
- COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
- & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
-* n-n cross section fluctuations
- PARAMETER (NBINS = 1000)
- COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
-* flags for particle decays
- COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
- & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
- & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
-* diquark-breaking mechanism
- COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
-* nucleon-nucleon event-generator
- CHARACTER*8 CMODEL
- LOGICAL LPHOIN
- COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
-* flags for diffractive interactions (DTUNUC 1.x)
- COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
-* VDM parameter for photon-nucleus interactions
- COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
-* Glauber formalism: flags and parameters for statistics
- LOGICAL LPROD
- CHARACTER*8 CGLB
- COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
-* kinematical cuts for lepton-nucleus interactions
- COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
- & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
-* flags for activated histograms
- COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
-* cuts for variable energy runs
- COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
-* parameters for hA-diffraction
- COMMON /DTDIHA/ DIBETA,DIALPH
-* LEPTO
- REAL RPPN
- COMMON /LEPTOI/ RPPN,LEPIN,INTER
-* steering flags for qel neutrino scattering modules
- COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
-* event flag
- COMMON /DTEVNO/ NEVENT,ICASCA
-
- DATA POTMES /0.002D0/
-
-* common /DTNPOT/
- DO 10 I=1,2
- PFERMP(I) = ZERO
- PFERMN(I) = ZERO
- EBINDP(I) = ZERO
- EBINDN(I) = ZERO
- DO 11 J=1,210
- EPOT(I,J) = ZERO
- 11 CONTINUE
-* nucleus independent meson potential
- EPOT(I,13) = POTMES
- EPOT(I,14) = POTMES
- EPOT(I,15) = POTMES
- EPOT(I,16) = POTMES
- EPOT(I,23) = POTMES
- EPOT(I,24) = POTMES
- EPOT(I,25) = POTMES
- 10 CONTINUE
-**sr 7.4.98: changed after corrected B-sampling
-C FERMOD = 0.55D0
- FERMOD = 0.68D0
- ETACOU(1) = ZERO
- ETACOU(2) = ZERO
- ICOUL = 1
- LFERMI = .TRUE.
-
-* common /HNTHRE/
- EHADTH = -99.0D0
- EHADLO = 4.06D0
- EHADHI = 6.0D0
- INTHAD = 1
- IDXTA = 2
-
-* common /DTIMPA/
- ICENTR = 0
- BIMIN = ZERO
- BIMAX = 1.0D10
- XSFRAC = 1.0D0
-
-* common /DTPRTA/
- IP = 1
- IPZ = 1
- IT = 1
- ITZ = 1
- IJPROJ = 1
- IBPROJ = 1
- IJTARG = 1
- IBTARG = 1
-* common /DTGPRO/
- VIRT = ZERO
- DO 14 I=1,4
- PGAMM(I) = ZERO
- PLEPT0(I) = ZERO
- PLEPT1(I) = ZERO
- PNUCL(I) = ZERO
- 14 CONTINUE
- IDIREC = 0
-
-* common /DTFOTI/
-**sr 7.4.98: changed after corrected B-sampling
-C TAUFOR = 4.4D0
- TAUFOR = 3.1D0
- KTAUGE = 25
- ITAUVE = 1
- INCMOD = 1
- LPAULI = .TRUE.
-
-* common /DTCHAI/
- SEASQ = ONE
- MKCRON = 1
- CRONCO = 0.64D0
- ISICHA = 0
- CUTOF = 100.0D0
- LCO2CR = .FALSE.
- IRECOM = 1
- LINTPT = .TRUE.
-
-* common /DTXCUT/
-* definition of soft quark distributions
- XSEACU = 0.05D0
- UNON = 2.0D0
- UNOM = 1.5D0
- UNOSEA = 5.0D0
-* cutoff parameters for x-sampling
- CVQ = 1.0D0
- CDQ = 2.0D0
-C CSEA = 0.3D0
- CSEA = 0.1D0
- SSMIMA = 1.2D0
- SSMIMQ = SSMIMA**2
- VVMTHR = 2.0D0
-
-* common /DTXSFL/
- IFLUCT = 0
-
-* common /DTFRPA/
- PDB = 0.15D0
- PDBSEA(1) = 0.0D0
- PDBSEA(2) = 0.0D0
- PDBSEA(3) = 0.0D0
- ISIG0 = 0
- IPI0 = 0
- NMSTU = 0
- NPARU = 0
- NMSTJ = 0
- NPARJ = 0
-
-* common /DTDIQB/
- DO 15 I=1,8
- DBRKR(1,I) = 5.0D0
- DBRKR(2,I) = 5.0D0
- DBRKR(3,I) = 10.0D0
- DBRKA(1,I) = ZERO
- DBRKA(2,I) = ZERO
- DBRKA(3,I) = ZERO
- 15 CONTINUE
- CHAM1 = 0.2D0
- CHAM3 = 0.5D0
- CHAB1 = 0.7D0
- CHAB3 = 1.0D0
-
-* common /DTFLG3/
- ISINGD = 0
- IDOUBD = 0
- IFLAGD = 0
- IDIFF = 0
-
-* common /DTMODL/
- MCGENE = 2
- CMODEL(1) = 'DTUNUC '
- CMODEL(2) = 'PHOJET '
- CMODEL(3) = 'LEPTO '
- CMODEL(4) = 'QNEUTRIN'
- LPHOIN = .TRUE.
- ELOJET = 5.0D0
-
-* common /DTLCUT/
- ECMIN = 3.5D0
- ECMAX = 1.0D10
- XBJMIN = ZERO
- ELMIN = ZERO
- EGMIN = ZERO
- EGMAX = 1.0D10
- YMIN = TINY10
- YMAX = 0.999D0
- Q2MIN = TINY10
- Q2MAX = 10.0D0
- THMIN = ZERO
- THMAX = TWOPI
- Q2LI = ZERO
- Q2HI = 1.0D10
- ECMLI = ZERO
- ECMHI = 1.0D10
-
-* common /DTVDMP/
- RL2 = 2.0D0
- INTRGE(1) = 1
- INTRGE(2) = 3
- IDPDF = 2212
- MODEGA = 4
- ISHAD(1) = 1
- ISHAD(2) = 1
- ISHAD(3) = 1
- EPSPOL = ZERO
-
-* common /DTGLGP/
- JSTATB = 1000
- JBINSB = 49
- CGLB = ' '
- IF (ITRSPT.EQ.1) THEN
- IOGLB = 100
- ELSE
- IOGLB = 0
- ENDIF
- LPROD = .TRUE.
-
-* common /DTHIS3/
- DO 16 I=1,50
- IHISPP(I) = 0
- IHISXS(I) = 0
- 16 CONTINUE
- IXSTBL = 0
-
-* common /DTVARE/
- VARELO = ZERO
- VAREHI = ZERO
- VARCLO = ZERO
- VARCHI = ZERO
-
-* common /DTDIHA/
- DIBETA = -1.0D0
- DIALPH = ZERO
-
-* common /LEPTOI/
- RPPN = 0.0
- LEPIN = 0
- INTER = 0
-
-* common /QNEUTO/
- NEUTYP = 1
- NEUDEC = 0
-
-* common /DTEVNO/
- NEVENT = 1
- IF (ITRSPT.EQ.1) THEN
- ICASCA = 1
- ELSE
- ICASCA = 0
- ENDIF
-
-* default Lab.-energy
- EPN = 200.0D0
- PPN = SQRT((EPN-AAM(IJPROJ))*(EPN+AAM(IJPROJ)))
-
- RETURN
- END
-*
-*===aaevt==============================================================*
-*
-CDECK ID>, DT_AAEVT
- SUBROUTINE DT_AAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
- & IDP,IGLAU)
-
-************************************************************************
-* This version dated 22.03.96 is written by S. Roesler. *
-************************************************************************
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( LINP = 5 ,
- & LOUT = 6 ,
- & LDAT = 9 )
-
- PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
-
-* emulsion treatment
- COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
- & NCOMPO,IEMUL
-* event flag
- COMMON /DTEVNO/ NEVENT,ICASCA
-
- CHARACTER*8 DATE,HHMMSS
- DIMENSION IDMNYR(3)
-
- KKMAT = 1
- NMSG = MAX(NEVTS/100,1)
-
-* initialization of run-statistics and histograms
- CALL DT_STATIS(1)
-
- CALL PHO_PHIST(1000,DUM)
-
-* initialization of Glauber-formalism
- IF (NCOMPO.LE.0) THEN
- CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
- ELSE
- DO 1 I=1,NCOMPO
- CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
- 1 CONTINUE
- ENDIF
- CALL DT_SIGEMU
-
- CALL IDATE(IDMNYR)
- WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
- & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
- CALL ITIME(IDMNYR)
- WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
- & IDMNYR(1),IDMNYR(2),IDMNYR(3)
- WRITE(LOUT,1001) DATE,HHMMSS
- 1001 FORMAT(/,' DT_AAEVT: Initialisation finished. ( Date: ',A8,
- & ' Time: ',A8,' )')
-
-* generate NEVTS events
- DO 2 IEVT=1,NEVTS
-
-* print run-status message
- IF (MOD(IEVT,NMSG).EQ.0) THEN
- CALL IDATE(IDMNYR)
- WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
- & IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
- CALL ITIME(IDMNYR)
- WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
- & IDMNYR(1),IDMNYR(2),IDMNYR(3)
- WRITE(LOUT,1000) IEVT-1,NEVTS,DATE,HHMMSS
- 1000 FORMAT(/,1X,I8,' out of ',I8,' events sampled ( Date: ',A,
- & ' Time: ',A,' )',/)
-C WRITE(LOUT,1000) IEVT-1
-C1000 FORMAT(1X,I8,' events sampled')
- ENDIF
- NEVENT = IEVT
-* treat nuclear emulsions
- IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
-* composite targets only
- KKMAT = -KKMAT
-* sample this event
- CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,IREJ)
-
- CALL PHO_PHIST(2000,DUM)
-
- 2 CONTINUE
-
-* print run-statistics and histograms to output-unit 6
-
- CALL PHO_PHIST(3000,DUM)
-
- CALL DT_STATIS(2)
-
- RETURN
- END
-*
-*===laevt==============================================================*
-*
-CDECK ID>, DT_LAEVT
- SUBROUTINE DT_LAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
- & IDP,IGLAU)
-
-************************************************************************
-* Interface to run DPMJET for lepton-nucleus interactions. *
-* Kinematics is sampled using the equivalent photon approximation *
-* Based on GPHERA-routine by R. Engel. *
-* This version dated 23.03.96 is written by S. Roesler. *
-************************************************************************
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( LINP = 5 ,
- & LOUT = 6 ,
- & LDAT = 9 )
-
- PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,
- & ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
- PARAMETER (TWOPI = 6.283185307179586454D+00,
- & PI = TWOPI/TWO,
- & ALPHEM = ONE/137.0D0)
-
-C CHARACTER*72 HEADER
-
-* particle properties (BAMJET index convention)
- CHARACTER*8 ANAME
- COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
- & IICH(210),IIBAR(210),K1(210),K2(210)
-* event history
-
- PARAMETER (NMXHKK=200000)
-
- COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
- & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
- & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
-* extended event history
- COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
- & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
- & IHIST(2,NMXHKK)
-* kinematical cuts for lepton-nucleus interactions
- COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
- & Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
-* properties of interacting particles
- COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
-* properties of photon/lepton projectiles
- COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
-* kinematics at lepton-gamma vertex
- COMMON /DTLGVX/ PPL0(4),PPL1(4),PPG(4),PPA(4)
-* flags for activated histograms
- COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
-
- PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
-
-* emulsion treatment
- COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
- & NCOMPO,IEMUL
-* Glauber formalism: cross sections
- COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
- & XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
- & XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
- & XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
- & XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
- & XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
- & XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
- & XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
- & XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
- & BSLOPE,NEBINI,NQBINI
-* nucleon-nucleon event-generator
- CHARACTER*8 CMODEL
- LOGICAL LPHOIN
- COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
-* flags for input different options
- LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
- COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
- & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
-* event flag
- COMMON /DTEVNO/ NEVENT,ICASCA
-
- DIMENSION XDUMB(40),BGTA(4)
-
-* LEPTO
- IF (MCGENE.EQ.3) THEN
-
- STOP ' This version does not contain LEPTO !'
-
- ENDIF
-
- KKMAT = 1
- NMSG = MAX(NEVTS/10,1)
-
-* mass of incident lepton
- AMLPT = AAM(IDP)
- AMLPT2 = AMLPT**2
- IDPPDG = IDT_IPDGHA(IDP)
-
-* consistency of kinematical limits
- Q2MIN = MAX(Q2MIN,TINY10)
- Q2MAX = MAX(Q2MAX,TINY10)
- YMIN = MIN(MAX(YMIN,TINY10),0.999D0)
- YMAX = MIN(MAX(YMAX,TINY10),0.999D0)
-
-* total energy of the lepton-nucleon system
- PTOTLN = SQRT( (PLEPT0(1)+PNUCL(1))**2+(PLEPT0(2)+PNUCL(2))**2
- & +(PLEPT0(3)+PNUCL(3))**2 )
- ETOTLN = PLEPT0(4)+PNUCL(4)
- ECMLN = SQRT((ETOTLN-PTOTLN)*(ETOTLN+PTOTLN))
- ECMAX = MIN(ECMAX,ECMLN)
- WRITE(LOUT,1003) ECMIN,ECMAX,YMIN,YMAX,Q2MIN,Q2MAX,EGMIN,
- & THMIN,THMAX,ELMIN
- 1003 FORMAT(1X,'LAEVT:',16X,'kinematical cuts',/,22X,
- & '------------------',/,9X,'W (min) =',
- & F7.1,' GeV (max) =',F7.1,' GeV',/,9X,'y (min) =',
- & F7.3,8X,'(max) =',F7.3,/,9X,'Q^2 (min) =',F7.1,
- & ' GeV^2 (max) =',F7.1,' GeV^2',/,' (Lab) E_g (min) ='
- & ,F7.1,' GeV',/,' (Lab) theta (min) =',F7.4,8X,'(max) =',
- & F7.4,' for E_lpt >',F7.1,' GeV',/)
-
-* Lorentz-parameter for transf. into Lab
- BGTA(1) = PNUCL(1)/AAM(1)
- BGTA(2) = PNUCL(2)/AAM(1)
- BGTA(3) = PNUCL(3)/AAM(1)
- BGTA(4) = PNUCL(4)/AAM(1)
-* LT of incident lepton into Lab and dump it in DTEVT1
- CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
- & PLEPT0(1),PLEPT0(2),PLEPT0(3),PLEPT0(4),
- & PLTOT,PPL0(1),PPL0(2),PPL0(3),PPL0(4))
- CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
- & PNUCL(1),PNUCL(2),PNUCL(3),PNUCL(4),
- & PLTOT,PPA(1),PPA(2),PPA(3),PPA(4))
-* maximum energy of photon nucleon system
- PTOTGN = SQRT((YMAX*PPL0(1)+PPA(1))**2+(YMAX*PPL0(2)+PPA(2))**2
- & +(YMAX*PPL0(3)+PPA(3))**2)
- ETOTGN = YMAX*PPL0(4)+PPA(4)
- EGNMAX = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
- EGNMAX = MIN(EGNMAX,ECMAX)
-* minimum energy of photon nucleon system
- PTOTGN = SQRT((YMIN*PPL0(1)+PPA(1))**2+(YMIN*PPL0(2)+PPA(2))**2
- & +(YMIN*PPL0(3)+PPA(3))**2)
- ETOTGN = YMIN*PPL0(4)+PPA(4)
- EGNMIN = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
- EGNMIN = MAX(EGNMIN,ECMIN)
-
-* limits for Glauber-initialization
- Q2LI = Q2MIN
- Q2HI = MAX(Q2LI,MIN(Q2HI,Q2MAX))
- ECMLI = MAX(EGNMIN,THREE)
- ECMHI = EGNMAX
- WRITE(LOUT,1004) EGNMIN,EGNMAX,ECMLI,ECMHI,Q2LI,Q2HI
- 1004 FORMAT(1X,'resulting limits:',/,9X,'W (min) =',F7.1,
- & ' GeV (max) =',F7.1,' GeV',/,/,' limits for ',
- & 'Glauber-initialization:',/,9X,'W (min) =',F7.1,
- & ' GeV (max) =',F7.1,' GeV',/,9X,'Q^2 (min) =',F7.1,
- & ' GeV^2 (max) =',F7.1,' GeV^2',/)
-* initialization of Glauber-formalism
- IF (NCOMPO.LE.0) THEN
- CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
- ELSE
- DO 9 I=1,NCOMPO
- CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
- 9 CONTINUE
- ENDIF
- CALL DT_SIGEMU
-
-* initialization of run-statistics and histograms
- CALL DT_STATIS(1)
-
- CALL PHO_PHIST(1000,DUM)
-
-* maximum photon-nucleus cross section
- I1 = 1
- I2 = 1
- RAT = ONE
- IF (EGNMAX.GE.ECMNN(NEBINI)) THEN
- I1 = NEBINI
- I2 = NEBINI
- RAT = ONE
- ELSEIF (EGNMAX.GT.ECMNN(1)) THEN
- DO 5 I=2,NEBINI
- IF (EGNMAX.LT.ECMNN(I)) THEN
- I1 = I-1
- I2 = I
- RAT = (EGNMAX-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
- GOTO 6
- ENDIF
- 5 CONTINUE
- 6 CONTINUE
- ENDIF
- SIGMAX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
- EGNXX = EGNMAX
- I1 = 1
- I2 = 1
- RAT = ONE
- IF (EGNMIN.GE.ECMNN(NEBINI)) THEN
- I1 = NEBINI
- I2 = NEBINI
- RAT = ONE
- ELSEIF (EGNMIN.GT.ECMNN(1)) THEN
- DO 7 I=2,NEBINI
- IF (EGNMIN.LT.ECMNN(I)) THEN
- I1 = I-1
- I2 = I
- RAT = (EGNMIN-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
- GOTO 8
- ENDIF
- 7 CONTINUE
- 8 CONTINUE
- ENDIF
- SIGXX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
- IF (SIGXX.GT.SIGMAX) EGNXX = EGNMIN
- SIGMAX = MAX(SIGMAX,SIGXX)
- WRITE(LOUT,'(9X,A,F8.3,A)') 'Sigma_tot (max) =',SIGMAX,' mb'
-
-* plot photon flux table
- AYMIN = LOG(YMIN)
- AYMAX = LOG(YMAX)
- AYRGE = AYMAX-AYMIN
- MAXTAB = 50
- ADY = LOG(YMAX/YMIN)/DBLE(MAXTAB-1)
-C WRITE(LOUT,'(/,1X,A)') 'LAEVT: photon flux '
- DO 1 I=1,MAXTAB
- Y = EXP(AYMIN+ADY*DBLE(I-1))
- Q2LOW = MAX(Q2MIN,AMLPT2*Y**2/(ONE-Y))
- FF1 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
- & -TWO*AMLPT2*Y*(ONE/Q2LOW-ONE/Q2MAX))
- FF2 = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
- & -TWO*(ONE-Y)/Y*(ONE-Q2LOW/Q2MAX))
-C WRITE(LOUT,'(5X,3E15.4)') Y,FF1,FF2
- 1 CONTINUE
-
-* maximum residual weight for flux sampling (dy/y)
- YY = YMIN
- Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
- WGHMAX = (ONE+(ONE-YY)**2)*LOG(Q2MAX/Q2LOW)
- & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
-
- CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY0)
- CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY1)
- CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY2)
- CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ0)
- CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ1)
- CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ2)
- CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE0)
- CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE1)
- CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE2)
- CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU0)
- CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU1)
- CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU2)
- XBLOW = 0.001D0
- CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX0)
- CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX1)
- CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX2)
-
- ITRY = 0
- ITRW = 0
- NC0 = 0
- NC1 = 0
-
-* generate events
- DO 2 IEVT=1,NEVTS
- IF (MOD(IEVT,NMSG).EQ.0) THEN
-C OPEN(LDAT,FILE='/scrtch3/hr/sroesler/statusd5.out',
-C & STATUS='UNKNOWN')
- WRITE(LOUT,'(1X,I8,A)') IEVT-1,' events sampled'
-C CLOSE(LDAT)
- ENDIF
- NEVENT = IEVT
-
- 100 CONTINUE
- ITRY = ITRY+1
-
-* sample y
- 101 CONTINUE
- ITRW = ITRW+1
- YY = EXP(AYRGE*DT_RNDM(RAT)+AYMIN)
- Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
- Q2LOG = LOG(Q2MAX/Q2LOW)
- WGH = (ONE+(ONE-YY)**2)*Q2LOG
- & -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
- IF (WGHMAX.LT.WGH) WRITE(LOUT,1000) YY,WGHMAX,WGH
- 1000 FORMAT(1X,'LAEVT: weight error!',3E12.5)
- IF (DT_RNDM(YY)*WGHMAX.GT.WGH) GOTO 101
-
-* sample Q2
- YEFF = ONE+(ONE-YY)**2
- 102 CONTINUE
- Q2 = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
- WGH = (YEFF-TWO*(ONE-YY)*Q2LOW/Q2)/YEFF
- IF (WGH.LT.DT_RNDM(Q2)) GOTO 102
-
-c NC0 = NC0+1
-c CALL DT_FILHGR(YY,ONE,IHFLY0,NC0)
-c CALL DT_FILHGR(Q2,ONE,IHFLQ0,NC0)
-
-* kinematics at lepton-photon vertex
-* scattered electron
- YQ2 = SQRT((ONE-YY)*Q2)
- Q2E = Q2/(4.0D0*PLEPT0(4))
- E1Y = (ONE-YY)*PLEPT0(4)
- CALL DT_DSFECF(SIF,COF)
- PLEPT1(1) = YQ2*COF
- PLEPT1(2) = YQ2*SIF
- PLEPT1(3) = E1Y-Q2E
- PLEPT1(4) = E1Y+Q2E
-C THETA = ACOS( (E1Y-Q2E)/(E1Y+Q2E) )
-* radiated photon
- PGAMM(1) = -PLEPT1(1)
- PGAMM(2) = -PLEPT1(2)
- PGAMM(3) = PLEPT0(3)-PLEPT1(3)
- PGAMM(4) = PLEPT0(4)-PLEPT1(4)
-* E_cm cut
- PTOTGN = SQRT( (PGAMM(1)+PNUCL(1))**2+(PGAMM(2)+PNUCL(2))**2
- & +(PGAMM(3)+PNUCL(3))**2 )
- ETOTGN = PGAMM(4)+PNUCL(4)
- ECMGN = (ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)
- IF (ECMGN.LT.0.1D0) GOTO 101
- ECMGN = SQRT(ECMGN)
- IF ((ECMGN.LT.ECMIN).OR.(ECMGN.GT.ECMAX)) GOTO 101
-
-* Lorentz-transformation into nucleon-rest system
- CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
- & PGAMM(1),PGAMM(2),PGAMM(3),PGAMM(4),
- & PGTOT,PPG(1),PPG(2),PPG(3),PPG(4))
- CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
- & PLEPT1(1),PLEPT1(2),PLEPT1(3),PLEPT1(4),
- & PLTOT,PPL1(1),PPL1(2),PPL1(3),PPL1(4))
-* temporary checks..
- Q2TMP = ABS(PPG(4)**2-PGTOT**2)
- IF (ABS(Q2-Q2TMP).GT.0.01D0) WRITE(LOUT,1001) Q2,Q2TMP
- 1001 FORMAT(1X,'LAEVT: inconsistent kinematics (Q2,Q2TMP) ',
- & 2F10.4)
- ECMTMP = SQRT((PPG(4)+AAM(1)-PGTOT)*(PPG(4)+AAM(1)+PGTOT))
- IF (ABS(ECMGN-ECMTMP).GT.TINY10) WRITE(LOUT,1002) ECMGN,ECMTMP
- 1002 FORMAT(1X,'LAEVT: inconsistent kinematics (ECMGN,ECMTMP) ',
- & 2F10.2)
- YYTMP = PPG(4)/PPL0(4)
- IF (ABS(YY-YYTMP).GT.0.01D0) WRITE(LOUT,1005) YY,YYTMP
- 1005 FORMAT(1X,'LAEVT: inconsistent kinematics (YY,YYTMP) ',
- & 2F10.4)
-
-* lepton tagger (Lab)
- THETA = ACOS( PPL1(3)/PLTOT )
- IF (PPL1(4).GT.ELMIN) THEN
- IF ((THETA.LT.THMIN).OR.(THETA.GT.THMAX)) GOTO 101
- ENDIF
-* photon energy-cut (Lab)
- IF (PPG(4).LT.EGMIN) GOTO 101
- IF (PPG(4).GT.EGMAX) GOTO 101
-* x_Bj cut
- XBJ = ABS(Q2/(1.876D0*PPG(4)))
- IF (XBJ.LT.XBJMIN) GOTO 101
-
- NC0 = NC0+1
- CALL DT_FILHGR( Q2,ONE,IHFLQ0,NC0)
- CALL DT_FILHGR( YY,ONE,IHFLY0,NC0)
- CALL DT_FILHGR( XBJ,ONE,IHFLX0,NC0)
- CALL DT_FILHGR(PPG(4),ONE,IHFLU0,NC0)
- CALL DT_FILHGR( ECMGN,ONE,IHFLE0,NC0)
-
-* rotation angles against z-axis
- COD = PPG(3)/PGTOT
-C SID = SQRT((ONE-COD)*(ONE+COD))
- PPT = SQRT(PPG(1)**2+PPG(2)**2)
- SID = PPT/PGTOT
- COF = ONE
- SIF = ZERO
- IF (PGTOT*SID.GT.TINY10) THEN
- COF = PPG(1)/(SID*PGTOT)
- SIF = PPG(2)/(SID*PGTOT)
- ANORF = SQRT(COF*COF+SIF*SIF)
- COF = COF/ANORF
- SIF = SIF/ANORF
- ENDIF
-
- IF (IXSTBL.EQ.0) THEN
-* change to photon projectile
- IJPROJ = 7
-* set virtuality
- VIRT = Q2
-* re-initialize LTs with new kinematics
-* !!PGAMM ist set in cms (ECMGN) along z
- EPN = ZERO
- PPN = ZERO
- CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,ECMGN,0)
-* Introduced by Chiara -> force CMS-system
-* IFRAME = 2
-* to force Lab-system
- IFRAME = 1
-* get emulsion component if requested
- IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
-* convolute with cross section
- CALL DT_SIGGAT(Q2LOW,EGNXX,STOTX,KKMAT)
- CALL DT_SIGGAT(Q2,ECMGN,STOT,KKMAT)
- IF (STOTX.LT.STOT) WRITE(LOUT,'(1X,A,/,6E12.3)')
- & 'LAEVT: warning STOTX<STOT ! ',Q2LOW,EGNMAX,STOTX,
- & Q2,ECMGN,STOT
- IF (DT_RNDM(Q2)*STOTX.GT.STOT) GOTO 100
- NC1 = NC1+1
- CALL DT_FILHGR( Q2,ONE,IHFLQ1,NC1)
- CALL DT_FILHGR( YY,ONE,IHFLY1,NC1)
- CALL DT_FILHGR( XBJ,ONE,IHFLX1,NC1)
- CALL DT_FILHGR(PPG(4),ONE,IHFLU1,NC1)
- CALL DT_FILHGR( ECMGN,ONE,IHFLE1,NC1)
-* composite targets only
- KKMAT = -KKMAT
-* sample this event
- CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IJPROJ,EPN,KKMAT,
- & IREJ)
-* rotate momenta of final state particles back in photon-nucleon syst.
- DO 4 I=NPOINT(4),NHKK
- IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
- & (ISTHKK(I).EQ.1001)) THEN
- PX = PHKK(1,I)
- PY = PHKK(2,I)
- PZ = PHKK(3,I)
- CALL DT_MYTRAN(1,PX,PY,PZ,COD,SID,COF,SIF,
- & PHKK(1,I),PHKK(2,I),PHKK(3,I))
- ENDIF
- 4 CONTINUE
- ENDIF
-
- CALL DT_FILHGR( Q2,ONE,IHFLQ2,NC1)
- CALL DT_FILHGR( YY,ONE,IHFLY2,NC1)
- CALL DT_FILHGR( XBJ,ONE,IHFLX2,NC1)
- CALL DT_FILHGR(PPG(4),ONE,IHFLU2,NC1)
- CALL DT_FILHGR( ECMGN,ONE,IHFLE2,NC1)
-
-* dump this event to histograms
-
- CALL PHO_PHIST(2000,DUM)
-
- 2 CONTINUE
-
- WGY = ALPHEM/TWOPI*WGHMAX*DBLE(ITRY)/DBLE(ITRW)
- WGY = WGY*LOG(YMAX/YMIN)
- WEIGHT = WGY*SIGMAX*DBLE(NEVTS)/DBLE(ITRY)
-
-C HEADER = ' LAEVT: Q^2 distribution 0'
-C CALL DT_OUTHGR(IHFLQ0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
-C HEADER = ' LAEVT: Q^2 distribution 1'
-C CALL DT_OUTHGR(IHFLQ1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
-C HEADER = ' LAEVT: Q^2 distribution 2'
-C CALL DT_OUTHGR(IHFLQ2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
-C HEADER = ' LAEVT: y distribution 0'
-C CALL DT_OUTHGR(IHFLY0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
-C HEADER = ' LAEVT: y distribution 1'
-C CALL DT_OUTHGR(IHFLY1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
-C HEADER = ' LAEVT: y distribution 2'
-C CALL DT_OUTHGR(IHFLY2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
-C HEADER = ' LAEVT: x distribution 0'
-C CALL DT_OUTHGR(IHFLX0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
-C HEADER = ' LAEVT: x distribution 1'
-C CALL DT_OUTHGR(IHFLX1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
-C HEADER = ' LAEVT: x distribution 2'
-C CALL DT_OUTHGR(IHFLX2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
-C HEADER = ' LAEVT: E_g distribution 0'
-C CALL DT_OUTHGR(IHFLU0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
-C HEADER = ' LAEVT: E_g distribution 1'
-C CALL DT_OUTHGR(IHFLU1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
-C HEADER = ' LAEVT: E_g distribution 2'
-C CALL DT_OUTHGR(IHFLU2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
-C HEADER = ' LAEVT: E_c distribution 0'
-C CALL DT_OUTHGR(IHFLE0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
-C HEADER = ' LAEVT: E_c distribution 1'
-C CALL DT_OUTHGR(IHFLE1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
-C HEADER = ' LAEVT: E_c distribution 2'
-C CALL DT_OUTHGR(IHFLE2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
-
-* print run-statistics and histograms to output-unit 6
-
- CALL PHO_PHIST(3000,DUM)
-
- IF (IXSTBL.EQ.0) CALL DT_STATIS(2)
-
- RETURN
- END
-*
-*===dtuini=============================================================*
-*
-CDECK ID>, DT_DTUINI
- SUBROUTINE DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
- & IDP,IEMU)
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
-
-* emulsion treatment
- COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
- & NCOMPO,IEMUL
-* Glauber formalism: flags and parameters for statistics
- LOGICAL LPROD
- CHARACTER*8 CGLB
- COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
-
- CALL DT_INIT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IGLAU)
- CALL DT_STATIS(1)
-
- CALL PHO_PHIST(1000,DUM)
-
- IF (NCOMPO.LE.0) THEN
- CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
- ELSE
- DO 1 I=1,NCOMPO
- CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
- 1 CONTINUE
- ENDIF
- IF (IOGLB.NE.100) CALL DT_SIGEMU
- IEMU = IEMUL
-
- RETURN
- END
-*
-*===dtuout=============================================================*
-*
-CDECK ID>, DT_DTUOUT
- SUBROUTINE DT_DTUOUT
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- CALL PHO_PHIST(3000,DUM)
-
- CALL DT_STATIS(2)
-
- RETURN
- END
-*
-*===beam===============================================================*
-*
-CDECK ID>, DT_BEAMPR
- SUBROUTINE DT_BEAMPR(WHAT,PLAB,MODE)
-
-************************************************************************
-* Initialization of event generation *
-* This version dated 7.4.98 is written by S. Roesler. *
-************************************************************************
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( LINP = 5 ,
- & LOUT = 6 ,
- & LDAT = 9 )
-
- PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
- PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
-
- LOGICAL LBEAM
-
-* event history
-
- PARAMETER (NMXHKK=200000)
-
- COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
- & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
- & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
-* extended event history
- COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
- & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
- & IHIST(2,NMXHKK)
-* properties of interacting particles
- COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
-* particle properties (BAMJET index convention)
- CHARACTER*8 ANAME
- COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
- & IICH(210),IIBAR(210),K1(210),K2(210)
-* beam momenta
- COMMON /DTBEAM/ P1(4),P2(4)
-
-C DIMENSION WHAT(6),P1(4),P2(4),P1CMS(4),P2CMS(4)
- DIMENSION WHAT(6),P1CMS(4),P2CMS(4)
-
- DATA LBEAM /.FALSE./
-
- GOTO (1,2) MODE
-
- 1 CONTINUE
-
- E1 = WHAT(1)
- IF (E1.LT.ZERO) E1 = DBLE(IPZ)/DBLE(IP)*ABS(WHAT(1))
- E2 = WHAT(2)
- IF (E2.LT.ZERO) E2 = DBLE(ITZ)/DBLE(IT)*ABS(WHAT(2))
- PP1 = SQRT( (E1+AAM(IJPROJ))*(E1-AAM(IJPROJ)) )
- PP2 = SQRT( (E2+AAM(IJTARG))*(E2-AAM(IJTARG)) )
- TH = 1.D-6*WHAT(3)/2.D0
- PH = WHAT(4)*BOG
- P1(1) = PP1*SIN(TH)*COS(PH)
- P1(2) = PP1*SIN(TH)*SIN(PH)
- P1(3) = PP1*COS(TH)
- P1(4) = E1
- P2(1) = PP2*SIN(TH)*COS(PH)
- P2(2) = PP2*SIN(TH)*SIN(PH)
- P2(3) = -PP2*COS(TH)
- P2(4) = E2
- ECM = SQRT( (P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
- & -(P1(3)+P2(3))**2 )
- ELAB = (ECM**2-AAM(IJPROJ)**2-AAM(IJTARG)**2)/(2.0D0*AAM(IJTARG))
- PLAB = SQRT( (ELAB+AAM(IJPROJ))*(ELAB-AAM(IJPROJ)) )
- BGX = (P1(1)+P2(1))/ECM
- BGY = (P1(2)+P2(2))/ECM
- BGZ = (P1(3)+P2(3))/ECM
- BGE = (P1(4)+P2(4))/ECM
- CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P1(1),P1(2),P1(3),P1(4),
- & P1TOT,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4))
- CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P2(1),P2(2),P2(3),P2(4),
- & P2TOT,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4))
- COD = P1CMS(3)/P1TOT
-C SID = SQRT((ONE-COD)*(ONE+COD))
- PPT = SQRT(P1CMS(1)**2+P1CMS(2)**2)
- SID = PPT/P1TOT
- COF = ONE
- SIF = ZERO
- IF (P1TOT*SID.GT.TINY10) THEN
- COF = P1CMS(1)/(SID*P1TOT)
- SIF = P1CMS(2)/(SID*P1TOT)
- ANORF = SQRT(COF*COF+SIF*SIF)
- COF = COF/ANORF
- SIF = SIF/ANORF
- ENDIF
-**check
-C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
-C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
-C WRITE(LOUT,'(5E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),P1TOT
-C WRITE(LOUT,'(5E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),P2TOT
-C PAX = ZERO
-C PAY = ZERO
-C PAZ = P1TOT
-C PAE = SQRT(AAM(IJPROJ)**2+PAZ**2)
-C PBX = ZERO
-C PBY = ZERO
-C PBZ = -P2TOT
-C PBE = SQRT(AAM(IJTARG)**2+PBZ**2)
-C WRITE(LOUT,'(4E15.4)') PAX,PAY,PAZ,PAE
-C WRITE(LOUT,'(4E15.4)') PBX,PBY,PBZ,PBE
-C CALL DT_MYTRAN(1,PAX,PAY,PAZ,COD,SID,COF,SIF,
-C & P1CMS(1),P1CMS(2),P1CMS(3))
-C CALL DT_MYTRAN(1,PBX,PBY,PBZ,COD,SID,COF,SIF,
-C & P2CMS(1),P2CMS(2),P2CMS(3))
-C WRITE(LOUT,'(4E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4)
-C WRITE(LOUT,'(4E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4)
-C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),
-C & P1TOT,P1(1),P1(2),P1(3),P1(4))
-C CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),
-C & P2TOT,P2(1),P2(2),P2(3),P2(4))
-C WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
-C WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
-C STOP
-**
-
- LBEAM = .TRUE.
-
- RETURN
-
- 2 CONTINUE
-
- IF (LBEAM) THEN
- IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
- DO 20 I=NPOINT(4),NHKK
- IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
- & (ISTHKK(I).EQ.1001)) THEN
- CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I),
- & COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS)
- PECMS = PHKK(4,I)
- CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS,
- & PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I))
- ENDIF
- 20 CONTINUE
- ELSE
- MODE = -1
- ENDIF
-
- RETURN
- END
-*
-*===eventb=============================================================*
-*
-CDECK ID>, DT_EVENTB
- SUBROUTINE DT_EVENTB(NCSY,IREJ)
-
-************************************************************************
-* Treatment of nucleon-nucleon interactions with full two-component *
-* Dual Parton Model. *
-* NCSY number of nucleon-nucleon interactions *
-* IREJ rejection flag *
-* This version dated 14.01.2000 is written by S. Roesler *
-************************************************************************
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( LINP = 5 ,
- & LOUT = 6 ,
- & LDAT = 9 )
-
- PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
-
-* event history
-
- PARAMETER (NMXHKK=200000)
-
- COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
- & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
- & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
-* extended event history
- COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
- & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
- & IHIST(2,NMXHKK)
-*! uncomment this line for internal phojet-fragmentation
-C #include "dtu_dtevtp.inc"
-* particle properties (BAMJET index convention)
- CHARACTER*8 ANAME
- COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
- & IICH(210),IIBAR(210),K1(210),K2(210)
-* flags for input different options
- LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
- COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
- & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
-* rejection counter
- COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
- & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
- & IREXCI(3),IRDIFF(2),IRINC
-* properties of interacting particles
- COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
-* properties of photon/lepton projectiles
- COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
-* various options for treatment of partons (DTUNUC 1.x)
-* (chain recombination, Cronin,..)
- LOGICAL LCO2CR,LINTPT
- COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
- & LCO2CR,LINTPT
-* statistics
- COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
- & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
- & ICEVTG(8,0:30)
-* DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
- COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
-* Glauber formalism: collision properties
- COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
- & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
-* flags for diffractive interactions (DTUNUC 1.x)
- COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
-* statistics: double-Pomeron exchange
- COMMON /DTFLG2/ INTFLG,IPOPO
-* flags for particle decays
- COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
- & IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
- & NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
-* nucleon-nucleon event-generator
- CHARACTER*8 CMODEL
- LOGICAL LPHOIN
- COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
-C nucleon-nucleus / nucleus-nucleus interface to DPMJET
- INTEGER IDEQP,IDEQB,IHFLD,IHFLS
- DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
- COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
- & IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C initial state parton radiation (internal part)
- INTEGER MXISR3,MXISR4
- PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
- INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
- DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
- COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
- & ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
- & IFL1(2,MXISR3),IFL2(2,MXISR3),
- & IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-C general process information
- INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
- COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
-
- DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4),
- & PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4),
- & PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4),
- & KPRON(15),ISINGL(2000)
-
-* initial values for max. number of phojet scatterings and dtunuc chains
-* to be fragmented with one pyexec call
- DATA MXPHFR,MXDTFR /10,100/
-
- IREJ = 0
-* pointer to first parton of the first chain in dtevt common
- NPOINT(3) = NHKK+1
-* special flag for double-Pomeron statistics
- IPOPO = 1
-* counter for low-mass (DTUNUC) interactions
- NDTUSC = 0
-* counter for interactions treated by PHOJET
- NPHOSC = 0
-
-* scan interactions for single nucleon-nucleon interactions
-* (this has to be checked here because Cronin modifies parton momenta)
- NC = NPOINT(2)
- IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! '
- DO 8 I=1,NCSY
- ISINGL(I) = 0
- MOP = JMOHKK(1,NC)
- MOT = JMOHKK(1,NC+1)
- DIFF1 = ABS(PHKK(4,MOP)-PHKK(4, NC)-PHKK(4,NC+2))
- DIFF2 = ABS(PHKK(4,MOT)-PHKK(4,NC+1)-PHKK(4,NC+3))
- IF ((DIFF1.LT.TINY10).AND.(DIFF2.LT.TINY10)) ISINGL(I) = 1
- NC = NC+4
- 8 CONTINUE
-
-* multiple scattering of chain ends
- IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
- IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
-
-* switch to PHOJET-settings for JETSET parameter
- CALL DT_INITJS(1)
-
-* loop over nucleon-nucleon interaction
- NC = NPOINT(2)
- DO 2 I=1,NCSY
-*
-* pick up one nucleon-nucleon interaction from DTEVT1
-* ppnn / ptnn - momenta of the interacting nucleons (cms)
-* ptotnn - total momentum of the interacting nucleons (cms)
-* pp1,2 / pt1,2 - momenta of the four partons
-* pp / pt - total momenta of the proj / targ partons
-* ptot - total momentum of the four partons
- MOP = JMOHKK(1,NC)
- MOT = JMOHKK(1,NC+1)
- DO 3 K=1,4
- PPNN(K) = PHKK(K,MOP)
- PTNN(K) = PHKK(K,MOT)
- PTOTNN(K) = PPNN(K)+PTNN(K)
- PP1(K) = PHKK(K,NC)
- PT1(K) = PHKK(K,NC+1)
- PP2(K) = PHKK(K,NC+2)
- PT2(K) = PHKK(K,NC+3)
- PP(K) = PP1(K)+PP2(K)
- PT(K) = PT1(K)+PT2(K)
- PTOT(K) = PP(K)+PT(K)
- 3 CONTINUE
-*
-*-----------------------------------------------------------------------
-* this is a complete nucleon-nucleon interaction
-*
- IF (ISINGL(I).EQ.1) THEN
-*
-* initialize PHOJET-variables for remnant/valence-partons
- IHFLD(1,1) = 0
- IHFLD(1,2) = 0
- IHFLD(2,1) = 0
- IHFLD(2,2) = 0
- IHFLS(1) = 1
- IHFLS(2) = 1
-* save current settings of PHOJET process and min. bias flags
- DO 9 K=1,11
- KPRON(K) = IPRON(K,1)
- 9 CONTINUE
- ISWSAV = ISWMDL(2)
-*
-* check if forced sampling of diffractive interaction requested
- IF (ISINGD.LT.-1) THEN
- DO 90 K=1,11
- IPRON(K,1) = 0
- 90 CONTINUE
- IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-3)) IPRON(5,1) = 1
- IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-4)) IPRON(6,1) = 1
- IF (ISINGD.EQ.-5) IPRON(4,1) = 1
- ENDIF
-*
-* for photons: a direct/anomalous interaction is not sampled
-* in PHOJET but already in Glauber-formalism. Here we check if such
-* an interaction is requested
- IF (IJPROJ.EQ.7) THEN
-* first switch off direct interactions
- IPRON(8,1) = 0
-* this is a direct interactions
- IF (IDIREC.EQ.1) THEN
- DO 12 K=1,11
- IPRON(K,1) = 0
- 12 CONTINUE
- IPRON(8,1) = 1
-* this is an anomalous interactions
-* (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) )
- ELSEIF (IDIREC.EQ.2) THEN
- ISWMDL(2) = 0
- ENDIF
- ELSE
- IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! '
- ENDIF
-*
-* make sure that total momenta of partons, pp and pt, are on mass
-* shell (Cronin may have srewed this up..)
- CALL DT_MASHEL(PP,PT,PHKK(5,MOP),PHKK(5,MOT),PPNN,PTNN,IR1)
- IF (IR1.NE.0) THEN
- IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)')
- & 'EVENTB: mass shell correction rejected'
- GOTO 9999
- ENDIF
-*
-* initialize the incoming particles in PHOJET
- IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
-
- CALL PHO_SETPAR(1,22,0,VIRT)
-
- ELSE
-
- CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO)
-
- ENDIF
-
- CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO)
-
-*
-* initialize rejection loop counter for anomalous processes
- IRJANO = 0
- 800 CONTINUE
- IRJANO = IRJANO+1
-*
-* temporary fix for ifano problem
- IFANO(1) = 0
- IFANO(2) = 0
-*
-* generate complete hadron/nucleon/photon-nucleon event with PHOJET
-
- CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1)
-
-*
-* for photons: special consistency check for anomalous interactions
- IF (IJPROJ.EQ.7) THEN
- IF (IRJANO.LT.30) THEN
- IF (IFANO(1).NE.0) THEN
-* here, an anomalous interaction was generated. Check if it
-* was also requested. Otherwise reject this event.
- IF (IDIREC.EQ.0) GOTO 800
- ELSE
-* here, an anomalous interaction was not generated. Check if it
-* was requested in which case we need to reject this event.
- IF (IDIREC.EQ.2) GOTO 800
- ENDIF
- ELSE
- WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ',
- & IRJANO,IDIREC,NEVHKK
- ENDIF
- ENDIF
-*
-* copy back original settings of PHOJET process and min. bias flags
- DO 10 K=1,11
- IPRON(K,1) = KPRON(K)
- 10 CONTINUE
- ISWMDL(2) = ISWSAV
-*
-* check if PHOJET has rejected this event
- IF (IREJ1.NE.0) THEN
-C IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
- WRITE(LOUT,'(1X,A,I4)')
- & 'EVENTB: chain system rejected',IDIREC
-
- CALL PHO_PREVNT(0)
-
- GOTO 9999
- ENDIF
-*
-* copy partons and strings from PHOJET common back into DTEVT for
-* external fragmentation
- MO1 = NC
- MO2 = NC+3
-*! uncomment this line for internal phojet-fragmentation
-C CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1)
- NPHOSC = NPHOSC+1
- CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1)
- IF (IREJ1.NE.0) THEN
- IF (IOULEV(1).GT.0)
- & WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1'
- GOTO 9999
- ENDIF
-*
-* update statistics counter
- ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1
-*
-*-----------------------------------------------------------------------
-* this interaction involves "remnants"
-*
- ELSE
-*
-* total mass of this system
- PPTOT = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2)
- AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT)
- IF (AMTOT2.LT.ZERO) THEN
- AMTOT = ZERO
- ELSE
- AMTOT = SQRT(AMTOT2)
- ENDIF
-*
-* systems with masses larger than elojet are treated with PHOJET
- IF (AMTOT.GT.ELOJET) THEN
-*
-* initialize PHOJET-variables for remnant/valence-partons
-* projectile parton flavors and valence flag
- IHFLD(1,1) = IDHKK(NC)
- IHFLD(1,2) = IDHKK(NC+2)
- IHFLS(1) = 0
- IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7)
- & .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1
-* target parton flavors and valence flag
- IHFLD(2,1) = IDHKK(NC+1)
- IHFLD(2,2) = IDHKK(NC+3)
- IHFLS(2) = 0
- IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5)
- & .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1
-* flag signalizing PHOJET how to treat the remnant:
-* iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld
-* iremn > -1 valence remnant: PHOJET assumes flavors according
-* to mother particle
- IREMN1 = IHFLS(1)-1
- IREMN2 = IHFLS(2)-1
-*
-* initialize the incoming particles in PHOJET
- IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
-
- CALL PHO_SETPAR(1,22,IREMN1,VIRT)
-
- ELSE
-
- CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO)
-
- ENDIF
-
- CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO)
-
-*
-* calculate Lorentz parameter of the nucleon-nucleon cm-system
- PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2)
- AMNN = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) )
- BGX = PTOTNN(1)/AMNN
- BGY = PTOTNN(2)/AMNN
- BGZ = PTOTNN(3)/AMNN
- GAM = PTOTNN(4)/AMNN
-* transform interacting nucleons into nucleon-nucleon cm-system
- CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
- & PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS,
- & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4))
- CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
- & PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS,
- & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4))
-* transform (total) momenta of the proj and targ partons into
-* nucleon-nucleon cm-system
- CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
- & PP(1),PP(2),PP(3),PP(4),
- & PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4))
- CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
- & PT(1),PT(2),PT(3),PT(4),
- & PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4))
-* energy fractions of the proj and targ partons
- XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE)
- XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE)
-***
-* testprint
-c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
-c & (PPTCMS(2)+PTTCMS(2))**2 +
-c & (PPTCMS(3)+PTTCMS(3))**2 )
-c EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
-c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
-c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
-c & (PPSUB(2)+PTSUB(2))**2 +
-c & (PPSUB(3)+PTSUB(3))**2 )
-c EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
-c & (PPSUB(4)+PTSUB(4)+PTOTSU) )
-***
-*
-* save current settings of PHOJET process and min. bias flags
- DO 7 K=1,11
- KPRON(K) = IPRON(K,1)
- 7 CONTINUE
-* disallow direct photon int. (does not make sense here anyway)
- IPRON(8,1) = 0
-* disallow double pomeron processes (due to technical problems
-* in PHOJET, needs to be solved sometime)
- IPRON(4,1) = 0
-* disallow diffraction for sea-diquarks
- IF ((IABS(IHFLD(1,1)).GT.1100).AND.
- & (IABS(IHFLD(1,2)).GT.1100)) THEN
- IPRON(3,1) = 0
- IPRON(6,1) = 0
- ENDIF
- IF ((IABS(IHFLD(2,1)).GT.1100).AND.
- & (IABS(IHFLD(2,2)).GT.1100)) THEN
- IPRON(3,1) = 0
- IPRON(5,1) = 0
- ENDIF
-*
-* we need massless partons: transform them on mass shell
- XMP = ZERO
- XMT = ZERO
- DO 6 K=1,4
- PPTMP(K) = PPSUB(K)
- PTTMP(K) = PTSUB(K)
- 6 CONTINUE
- CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1)
- PPSUTO = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2)
- PTSUTO = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2)
- PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+
- & (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2)
-* total energy of the subsysten after mass transformation
-* (should be the same as before..)
- SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)*
- & (PPSUB(4)+PTSUB(4)+PSUTOT) )
-*
-* after mass shell transformation the x_sub - relation has to be
-* corrected. We therefore create "pseudo-momenta" of mother-nucleons.
-*
-* The old version was to scale based on the original x_sub and the
-* 4-momenta of the subsystem. At very high energy this could lead to
-* "pseudo-cm energies" of the parent system considerably exceeding
-* the true cm energy. Now we keep the true cm energy and calculate
-* new x_sub instead.
-C old version PPTCMS(4) = PPSUB(4)/XPSUB
- PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4))
- XPSUB = PPSUB(4)/PPTCMS(4)
- IF (IJPROJ.EQ.7) THEN
- AMP2 = PHKK(5,MOT)**2
- PTOT1 = SQRT(PPTCMS(4)**2-AMP2)
- ELSE
-*???????
- PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP))
- & *(PPTCMS(4)+PHKK(5,MOP)))
-C PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT))
-C & *(PPTCMS(4)+PHKK(5,MOT)))
- ENDIF
-C old version PTTCMS(4) = PTSUB(4)/XTSUB
- PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4))
- XTSUB = PTSUB(4)/PTTCMS(4)
- PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT))
- & *(PTTCMS(4)+PHKK(5,MOT)))
- DO 4 K=1,3
- PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO
- PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO
- 4 CONTINUE
-***
-* testprint
-*
-* ppnn / ptnn - momenta of the int. nucleons (cms, negl. Fermi)
-* ptotnn - total momentum of the int. nucleons (cms, negl. Fermi)
-* pptcms/ pttcms - momenta of the interacting nucleons (cms)
-* pp1,2 / pt1,2 - momenta of the four partons
-*
-* pp / pt - total momenta of the pr/ta partons (cms, negl. Fermi)
-* ptot - total momentum of the four partons (cms, negl. Fermi)
-* ppsub / ptsub - total momenta of the proj / targ partons (cms)
-*
-c PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
-c & (PPTCMS(2)+PTTCMS(2))**2 +
-c & (PPTCMS(3)+PTTCMS(3))**2 )
-c ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
-c & (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
-c PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
-c & (PPSUB(2)+PTSUB(2))**2 +
-c & (PPSUB(3)+PTSUB(3))**2 )
-c ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
-c & (PPSUB(4)+PTSUB(4)+PTOTSU) )
-c IF (ENEWCM/EOLDCM.GT.1.1D0) THEN
-c WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM
-c WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU
-c WRITE(*,*) ' XPSUB, XTSUB : ',XPSUB,XTSUB
-c ENDIF
-c BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM
-c BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM
-c BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM
-c BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM
-* transform interacting nucleons into nucleon-nucleon cm-system
-c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
-c & PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT,
-c & PPNEW1,PPNEW2,PPNEW3,PPNEW4)
-c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
-c & PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT,
-c & PTNEW1,PTNEW2,PTNEW3,PTNEW4)
-c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
-c & PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT,
-c & PPSUB1,PPSUB2,PPSUB3,PPSUB4)
-c CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
-c & PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT,
-c & PTSUB1,PTSUB2,PTSUB3,PTSUB4)
-c PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 +
-c & (PPNEW2+PTNEW2)**2 +
-c & (PPNEW3+PTNEW3)**2 )
-c ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) *
-c & (PPNEW4+PTNEW4+PTSTCM) )
-c PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 +
-c & (PPSUB2+PTSUB2)**2 +
-c & (PPSUB3+PTSUB3)**2 )
-c ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) *
-c & (PPSUB4+PTSUB4+PTSTSU) )
-C WRITE(*,*) ' mother cmE :'
-C WRITE(*,*) ETSTCM,ENEWCM
-C WRITE(*,*) ' subsystem cmE :'
-C WRITE(*,*) ETSTSU,ENEWSU
-C WRITE(*,*) ' projectile mother :'
-C WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4
-C WRITE(*,*) ' target mother :'
-C WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4
-C WRITE(*,*) ' projectile subsystem:'
-C WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4
-C WRITE(*,*) ' target subsystem:'
-C WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4
-C WRITE(*,*) ' projectile subsystem should be:'
-C WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0,
-C & XPSUB*ETSTCM/2.0D0
-C WRITE(*,*) ' target subsystem should be:'
-C WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0,
-C & XTSUB*ETSTCM/2.0D0
-C WRITE(*,*) ' subsystem cmE should be: '
-C WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB
-***
-*
-* generate complete remnant - nucleon/remnant event with PHOJET
-
- CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1)
-
-*
-* copy back original settings of PHOJET process flags
- DO 11 K=1,11
- IPRON(K,1) = KPRON(K)
- 11 CONTINUE
-*
-* check if PHOJET has rejected this event
- IF (IREJ1.NE.0) THEN
- IF (IOULEV(1).GT.0)
- & WRITE(LOUT,'(1X,A)') 'EVENTB: chain system rejected'
- WRITE(LOUT,*)
- & 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT
-
- CALL PHO_PREVNT(0)
-
- GOTO 9999
- ENDIF
-*
-* copy partons and strings from PHOJET common back into DTEVT for
-* external fragmentation
- MO1 = NC
- MO2 = NC+3
-*! uncomment this line for internal phojet-fragmentation
-C CALL DT_GETFSP(MO1,MO2,PP,PT,1)
- NPHOSC = NPHOSC+1
- CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1)
- IF (IREJ1.NE.0) THEN
- IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
- & 'EVENTB: chain system rejected 2'
- GOTO 9999
- ENDIF
-*
-* update statistics counter
- ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1
-*
-*-----------------------------------------------------------------------
-* two-chain approx. for smaller systems
-*
- ELSE
-*
- NDTUSC = NDTUSC+1
-* special flag for double-Pomeron statistics
- IPOPO = 0
-*
-* pick up flavors at the ends of the two chains
- IFP1 = IDHKK(NC)
- IFT1 = IDHKK(NC+1)
- IFP2 = IDHKK(NC+2)
- IFT2 = IDHKK(NC+3)
-* ..and the indices of the mothers
- MOP1 = NC
- MOT1 = NC+1
- MOP2 = NC+2
- MOT2 = NC+3
- CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
- & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
-*
-* check if this chain system was rejected
- IF (IREJ1.GT.0) THEN
- IF (IOULEV(1).GT.0) THEN
- WRITE(LOUT,*) 'rejected 1 in EVENTB'
- WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)')
- & IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT
- ENDIF
- IRHHA = IRHHA+1
- GOTO 9999
- ENDIF
-* the following lines are for sea-sea chains rejected in GETCSY
- IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1
- ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1
- ENDIF
-*
- ENDIF
-*
-* update statistics counter
- ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1
-*
- NC = NC+4
-*
- 2 CONTINUE
-*
-*-----------------------------------------------------------------------
-* treatment of low-mass chains (if there are any)
-*
- IF (NDTUSC.GT.0) THEN
-*
-* correct chains of very low masses for possible resonances
- IF (IRESCO.EQ.1) THEN
- CALL DT_EVTRES(IREJ1)
- IF (IREJ1.GT.0) THEN
- IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB'
- IRRES(1) = IRRES(1)+1
- GOTO 9999
- ENDIF
- ENDIF
-* fragmentation of low-mass chains
-*! uncomment this line for internal phojet-fragmentation
-* (of course it will still be fragmented by DPMJET-routines but it
-* has to be done here instead of further below)
-C CALL DT_EVTFRA(IREJ1)
-C IF (IREJ1.GT.0) THEN
-C IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB'
-C IRFRAG = IRFRAG+1
-C GOTO 9999
-C ENDIF
- ELSE
-*! uncomment this line for internal phojet-fragmentation
-C NPOINT(4) = NHKK+1
- IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
- ENDIF
-*
-*-----------------------------------------------------------------------
-* new di-quark breaking mechanisms
-*
- MXLEFT = 2
- CALL DT_CHASTA(0)
- IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
- & .OR.(PDBSEA(3).GT.0.0D0)) THEN
- CALL DT_DIQBRK
- MXLEFT = 4
- ENDIF
-*
-*-----------------------------------------------------------------------
-* hadronize this event
-*
-* hadronize PHOJET chain systems
- NPYMAX = 0
- NPJE = NPHOSC/MXPHFR
- IF (MXPHFR.LT.MXLEFT) MXLEFT = 2
- IF (NPJE.GT.1) THEN
- NLEFT = NPHOSC-NPJE*MXPHFR
- DO 20 JFRG=1,NPJE
- NFRG = JFRG*MXPHFR
- IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN
- CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
- IF (IREJ1.GT.0) GOTO 22
- NLEFT = 0
- ELSE
- CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1)
- IF (IREJ1.GT.0) GOTO 22
- ENDIF
- IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
- 20 CONTINUE
- IF (NLEFT.GT.0) THEN
- CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
- IF (IREJ1.GT.0) GOTO 22
- IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
- ENDIF
- ELSE
- CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
- IF (IREJ1.GT.0) GOTO 22
- IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
- ENDIF
-*
-* check max. filling level of jetset common and
-* reduce mxphfr if necessary
- IF (NPYMAX.GT.3000) THEN
- IF (NPYMAX.GT.3500) THEN
- MXPHFR = MAX(1,MXPHFR-2)
- ELSE
- MXPHFR = MAX(1,MXPHFR-1)
- ENDIF
-C WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR
- ENDIF
-*
-* hadronize DTUNUC chain systems
- 23 CONTINUE
- IBACK = MXDTFR
- CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2)
- IF (IREJ2.GT.0) GOTO 22
-*
-* check max. filling level of jetset common and
-* reduce mxdtfr if necessary
- IF (NPYMEM.GT.3000) THEN
- IF (NPYMEM.GT.3500) THEN
- MXDTFR = MAX(1,MXDTFR-20)
- ELSE
- MXDTFR = MAX(1,MXDTFR-10)
- ENDIF
-C WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR
- ENDIF
-*
- IF (IBACK.EQ.-1) GOTO 23
-*
- 22 CONTINUE
-C CALL DT_EVTFRG(1,IREJ1)
-C CALL DT_EVTFRG(2,IREJ2)
- IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN
- IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB'
- IRFRAG = IRFRAG+1
- GOTO 9999
- ENDIF
-*
-* get final state particles from /DTEVTP/
-*! uncomment this line for internal phojet-fragmentation
-C CALL DT_GETFSP(IDUM,IDUM,PP,PT,2)
-
- IF (IJPROJ.NE.7)
- & CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3)
-C IF (IREJ3.NE.0) GOTO 9999
-
- RETURN
-
- 9999 CONTINUE
- IREVT = IREVT+1
- IREJ = 1
- RETURN
- END
-*
-*===getpje=============================================================*
-*
-CDECK ID>, DT_GETPJE
- SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ)
-
-************************************************************************
-* This subroutine copies PHOJET partons and strings from POEVT1 into *
-* DTEVT1. *
-* MO1,MO2 indices of first and last mother-parton in DTEVT1 *
-* PP,PT 4-momenta of projectile/target being handled by *
-* PHOJET *
-* This version dated 11.12.99 is written by S. Roesler *
-************************************************************************
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( LINP = 5 ,
- & LOUT = 6 ,
- & LDAT = 9 )
-
- PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1,
- & ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0)
-
- LOGICAL LFLIP
-
-* event history
-
- PARAMETER (NMXHKK=200000)
-
- COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
- & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
- & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
-* extended event history
- COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
- & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
- & IHIST(2,NMXHKK)
-* Lorentz-parameters of the current interaction
- COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
- & UMO,PPCM,EPROJ,PPROJ
-* DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
- COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
-* flags for input different options
- LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
- COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
- & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
-* statistics: double-Pomeron exchange
- COMMON /DTFLG2/ INTFLG,IPOPO
-* statistics
- COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
- & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
- & ICEVTG(8,0:30)
-* rejection counter
- COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
- & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
- & IREXCI(3),IRDIFF(2),IRINC
-
-C standard particle data interface
- INTEGER NMXHEP
-
- PARAMETER (NMXHEP=4000)
-
- INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
- DOUBLE PRECISION PHEP,VHEP
- COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- & JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
- & VHEP(4,NMXHEP)
-C extension to standard particle data interface (PHOJET specific)
- INTEGER IMPART,IPHIST,ICOLOR
- COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
-
-C color string configurations including collapsed strings and hadrons
- INTEGER MSTR
- PARAMETER (MSTR=500)
- INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
- COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
- & IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
- & NNCH(MSTR),IBHAD(MSTR),ISTR
-C general process information
- INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
- COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C event debugging information
- INTEGER NMAXD
- PARAMETER (NMAXD=100)
- INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
- & KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
- COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
- & KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
-
- DIMENSION PP(4),PT(4)
- DATA MAXLOP /10000/
-
- INHKK = NHKK
- LFLIP = .TRUE.
- 1 CONTINUE
- NPVAL = 0
- NTVAL = 0
- IREJ = 0
-
-* store initial momenta for energy-momentum conservation check
- IF (LEMCCK) THEN
- CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2)
- CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2)
- ENDIF
-* copy partons and strings from POEVT1 into DTEVT1
- DO 11 I=1,ISTR
-C IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN
- IF (NCODE(I).EQ.-99) THEN
- IDXSTG = NPOS(1,I)
- IDSTG = IDHEP(IDXSTG)
- PX = PHEP(1,IDXSTG)
- PY = PHEP(2,IDXSTG)
- PZ = PHEP(3,IDXSTG)
- PE = PHEP(4,IDXSTG)
- IF (MODE.LT.0) THEN
- ISTAT = 70000+IPJE
- CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE,
- & 11,IDSTG,0)
- IF (LEMCCK) THEN
- PX = -PX
- PY = -PY
- PZ = -PZ
- PE = -PE
- CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
- ENDIF
- ELSE
- CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
- & PPX,PPY,PPZ,PPE)
- ISTAT = 70000+IPJE
- CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE,
- & 11,IDSTG,0)
- IF (LEMCCK) THEN
- PX = -PPX
- PY = -PPY
- PZ = -PPZ
- PE = -PPE
- CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
- ENDIF
- ENDIF
- NOBAM(NHKK) = 0
- IHIST(1,NHKK) = IPHIST(1,IDXSTG)
- IHIST(2,NHKK) = 0
- ELSEIF (NCODE(I).GE.0) THEN
-* indices of partons and string in POEVT1
- IDX1 = ABS(JMOHEP(1,NPOS(1,I)))
- IDX2 = ABS(JMOHEP(2,NPOS(1,I)))
- IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN
- WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2,
- & ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! '
- STOP ' GETPJE 1'
- ENDIF
- IDXSTG = NPOS(1,I)
-* find "mother" string of the string
- IDXMS1 = ABS(JMOHEP(1,IDX1))
- IDXMS2 = ABS(JMOHEP(1,IDX2))
- IF (IDXMS1.NE.IDXMS2) THEN
- IDXMS1 = IDXSTG
- IDXMS2 = IDXSTG
-C STOP ' GETPJE: IDXMS1.NE.IDXMS2 !'
- ENDIF
-* search POEVT1 for the original hadron of the parton
- ILOOP = 0
- IPOM1 = 0
- 14 CONTINUE
- ILOOP = ILOOP+1
-
- IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1
-
- IDXMS1 = ABS(JMOHEP(1,IDXMS1))
- IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND.
- & (ILOOP.LT.MAXLOP)) GOTO 14
- IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! '
- IPOM2 = 0
- ILOOP = 0
- 15 CONTINUE
- ILOOP = ILOOP+1
-
- IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1
-
- IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN
- IDXMS2 = ABS(JMOHEP(2,IDXMS2))
- ELSE
- IDXMS2 = ABS(JMOHEP(1,IDXMS2))
- ENDIF
- IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND.
- & (ILOOP.LT.MAXLOP)) GOTO 15
- IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! '
-* parton 1
- IF (IDXMS1.EQ.1) THEN
- ISPTN1 = ISTHKK(MO1)
- M1PTN1 = MO1
- M2PTN1 = MO1+2
- ELSE
- ISPTN1 = ISTHKK(MO2)
- M1PTN1 = MO2-2
- M2PTN1 = MO2
- ENDIF
-* parton 2
- IF (IDXMS2.EQ.1) THEN
- ISPTN2 = ISTHKK(MO1)
- M1PTN2 = MO1
- M2PTN2 = MO1+2
- ELSE
- ISPTN2 = ISTHKK(MO2)
- M1PTN2 = MO2-2
- M2PTN2 = MO2
- ENDIF
-* check for mis-identified mothers and switch mother indices if necessary
- IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6)
- & .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND.
- & (LFLIP)) THEN
- IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN
- ISPTN1 = ISTHKK(MO1)
- M1PTN1 = MO1
- M2PTN1 = MO1+2
- ISPTN2 = ISTHKK(MO2)
- M1PTN2 = MO2-2
- M2PTN2 = MO2
- ELSE
- ISPTN1 = ISTHKK(MO2)
- M1PTN1 = MO2-2
- M2PTN1 = MO2
- ISPTN2 = ISTHKK(MO1)
- M1PTN2 = MO1
- M2PTN2 = MO1+2
- ENDIF
- ENDIF
-* register partons in temporary common
-* parton at chain end
- PX = PHEP(1,IDX1)
- PY = PHEP(2,IDX1)
- PZ = PHEP(3,IDX1)
- PE = PHEP(4,IDX1)
-* flag only partons coming from Pomeron with 41/42
-C IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN
- IF (IPOM1.NE.0) THEN
- ISTX = ABS(ISPTN1)/10
- IMO = ABS(ISPTN1)-10*ISTX
- ISPTN1 = -(40+IMO)
- ELSE
- IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN
- ISTX = ABS(ISPTN1)/10
- IMO = ABS(ISPTN1)-10*ISTX
- IF ((IDHEP(IDX1).EQ.21).OR.
- & (ABS(IPHIST(1,IDX1)).GE.100)) THEN
- ISPTN1 = -(60+IMO)
- ELSE
- ISPTN1 = -(50+IMO)
- ENDIF
- ENDIF
- ENDIF
- IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1
- IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1
- IF (MODE.LT.0) THEN
- CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY,
- & PZ,PE,0,0,0)
- ELSE
- CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
- & PPX,PPY,PPZ,PPE)
- CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY,
- & PPZ,PPE,0,0,0)
- ENDIF
- IHIST(1,NHKK) = IPHIST(1,IDX1)
- IHIST(2,NHKK) = 0
- DO 19 KK=1,4
- VHKK(KK,NHKK) = VHKK(KK,M2PTN1)
- WHKK(KK,NHKK) = WHKK(KK,M1PTN1)
- 19 CONTINUE
- VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB
- WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB
- M1STRG = NHKK
-* gluon kinks
- NGLUON = IDX2-IDX1-1
- IF (NGLUON.GT.0) THEN
- DO 17 IGLUON=1,NGLUON
- IDX = IDX1+IGLUON
- IDXMS = ABS(JMOHEP(1,IDX))
- IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN
- ILOOP = 0
- 16 CONTINUE
- ILOOP = ILOOP+1
- IDXMS = ABS(JMOHEP(1,IDXMS))
- IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND.
- & (ILOOP.LT.MAXLOP)) GOTO 16
- IF (ILOOP.EQ.MAXLOP)
- & WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! '
- ENDIF
- IF (IDXMS.EQ.1) THEN
- ISPTN = ISTHKK(MO1)
- M1PTN = MO1
- M2PTN = MO1+2
- ELSE
- ISPTN = ISTHKK(MO2)
- M1PTN = MO2-2
- M2PTN = MO2
- ENDIF
- PX = PHEP(1,IDX)
- PY = PHEP(2,IDX)
- PZ = PHEP(3,IDX)
- PE = PHEP(4,IDX)
- IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN
- ISTX = ABS(ISPTN)/10
- IMO = ABS(ISPTN)-10*ISTX
- IF ((IDHEP(IDX).EQ.21).OR.
- & (ABS(IPHIST(1,IDX)).GE.100)) THEN
- ISPTN = -(60+IMO)
- ELSE
- ISPTN = -(50+IMO)
- ENDIF
- ENDIF
- IF (ISPTN.EQ.-21) NPVAL = NPVAL+1
- IF (ISPTN.EQ.-22) NTVAL = NTVAL+1
- IF (MODE.LT.0) THEN
- CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
- & PX,PY,PZ,PE,0,0,0)
- ELSE
- CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
- & PPX,PPY,PPZ,PPE)
- CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
- & PPX,PPY,PPZ,PPE,0,0,0)
- ENDIF
- IHIST(1,NHKK) = IPHIST(1,IDX)
- IHIST(2,NHKK) = 0
- DO 20 KK=1,4
- VHKK(KK,NHKK) = VHKK(KK,M2PTN)
- WHKK(KK,NHKK) = WHKK(KK,M1PTN)
- 20 CONTINUE
- VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB
- WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB
- 17 CONTINUE
- ENDIF
-* parton at chain end
- PX = PHEP(1,IDX2)
- PY = PHEP(2,IDX2)
- PZ = PHEP(3,IDX2)
- PE = PHEP(4,IDX2)
-* flag only partons coming from Pomeron with 41/42
-C IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN
- IF (IPOM2.NE.0) THEN
- ISTX = ABS(ISPTN2)/10
- IMO = ABS(ISPTN2)-10*ISTX
- ISPTN2 = -(40+IMO)
- ELSE
- IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN
- ISTX = ABS(ISPTN2)/10
- IMO = ABS(ISPTN2)-10*ISTX
- IF ((IDHEP(IDX2).EQ.21).OR.
- & (ABS(IPHIST(1,IDX2)).GE.100)) THEN
- ISPTN2 = -(60+IMO)
- ELSE
- ISPTN2 = -(50+IMO)
- ENDIF
- ENDIF
- ENDIF
- IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1
- IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1
- IF (MODE.LT.0) THEN
- CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
- & PX,PY,PZ,PE,0,0,0)
- ELSE
- CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
- & PPX,PPY,PPZ,PPE)
- CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
- & PPX,PPY,PPZ,PPE,0,0,0)
- ENDIF
- IHIST(1,NHKK) = IPHIST(1,IDX2)
- IHIST(2,NHKK) = 0
- DO 21 KK=1,4
- VHKK(KK,NHKK) = VHKK(KK,M2PTN2)
- WHKK(KK,NHKK) = WHKK(KK,M1PTN2)
- 21 CONTINUE
- VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB
- WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB
- M2STRG = NHKK
-* register string
- JSTRG = 100*IPROCE+NCODE(I)
- PX = PHEP(1,IDXSTG)
- PY = PHEP(2,IDXSTG)
- PZ = PHEP(3,IDXSTG)
- PE = PHEP(4,IDXSTG)
- IF (MODE.LT.0) THEN
- ISTAT = 70000+IPJE
- CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
- & PX,PY,PZ,PE,0,0,0)
- IF (LEMCCK) THEN
- PX = -PX
- PY = -PY
- PZ = -PZ
- PE = -PE
- CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
- ENDIF
- ELSE
- CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
- & PPX,PPY,PPZ,PPE)
- ISTAT = 70000+IPJE
- CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
- & PPX,PPY,PPZ,PPE,0,0,0)
- IF (LEMCCK) THEN
- PX = -PPX
- PY = -PPY
- PZ = -PPZ
- PE = -PPE
- CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
- ENDIF
- ENDIF
- NOBAM(NHKK) = 0
- IHIST(1,NHKK) = 0
- IHIST(2,NHKK) = 0
- DO 18 KK=1,4
- VHKK(KK,NHKK) = VHKK(KK,MO2)
- WHKK(KK,NHKK) = WHKK(KK,MO1)
- 18 CONTINUE
- VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
- WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
- ENDIF
- 11 CONTINUE
-
- IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN
- NHKK = INHKK
- LFLIP = .FALSE.
- GOTO 1
- ENDIF
-
- IF (LEMCCK) THEN
- IF (UMO.GT.1.0D5) THEN
- CHKLEV = 1.0D0
- ELSE
- CHKLEV = TINY1
- ENDIF
- CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2)
-
- IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0)
-
- ENDIF
-
-* internal statistics
-* dble-Po statistics.
- IF (IPROCE.NE.4) IPOPO = 0
-
- INTFLG = IPROCE
- IDCHSY = IDCH(MO1)
- IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN
- ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1
- ELSE
- WRITE(LOUT,1000) IPROCE,NEVHKK,MO1
- 1000 FORMAT(1X,'GETFSP: warning! incons. process id. (',I2,
- & ') at evt(chain) ',I6,'(',I2,')')
- ENDIF
- IF (IPROCE.EQ.5) THEN
- IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN
- ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1
- ELSE
-C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
- 1001 FORMAT(1X,'GETFSP: warning! incons. diffrac. id. ',
- & '(IPROCE,IDIFR1,IDIFR2=',3I3,')')
- ENDIF
- ELSEIF (IPROCE.EQ.6) THEN
- IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
- ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1
- ELSE
-C WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
- ENDIF
- ELSEIF (IPROCE.EQ.7) THEN
- IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND.
- & (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
- IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1))
- & ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1
- IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2))
- & ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1
- IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2))
- & ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1
- IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1))
- & ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1
- ELSE
- WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
- ENDIF
- ENDIF
- IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3))
- & THEN
- ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
- ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
- ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
- ENDIF
- ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM
- ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM
- ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG
- ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG)
- ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO)
-
- RETURN
-
- 9999 CONTINUE
- IREJ = 1
- RETURN
- END
-*
-*===phoini=============================================================*
-*
-CDECK ID>, DT_PHOINI
- SUBROUTINE DT_PHOINI
-
-************************************************************************
-* Initialization PHOJET-event generator for nucleon-nucleon interact. *
-* This version dated 16.11.95 is written by S. Roesler *
-* Last change: s.r. 21.01.01 *
-************************************************************************
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( LINP = 5 ,
- & LOUT = 6 ,
- & LDAT = 9 )
-
- PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
-
-* nucleon-nucleon event-generator
- CHARACTER*8 CMODEL
- LOGICAL LPHOIN
- COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
-* particle properties (BAMJET index convention)
- CHARACTER*8 ANAME
- COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
- & IICH(210),IIBAR(210),K1(210),K2(210)
-* Lorentz-parameters of the current interaction
- COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
- & UMO,PPCM,EPROJ,PPROJ
-* properties of interacting particles
- COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
-* properties of photon/lepton projectiles
- COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
-
- PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
-
-* emulsion treatment
- COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
- & NCOMPO,IEMUL
-* VDM parameter for photon-nucleus interactions
- COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
-* nuclear potential
- LOGICAL LFERMI
- COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
- & EBINDP(2),EBINDN(2),EPOT(2,210),
- & ETACOU(2),ICOUL,LFERMI
-* Glauber formalism: flags and parameters for statistics
- LOGICAL LPROD
- CHARACTER*8 CGLB
- COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
-*
-* parameters for cascade calculations:
-* maximum mumber of PDF's which can be defined in phojet (limited
-* by the dimension of ipdfs in pho_setpdf)
- PARAMETER (MAXPDF = 20)
-* PDF parametrization and number of set for the first 30 hadrons in
-* the bamjet-code list
-* negative numbers mean that the PDF is set in phojet,
-* zero stands for "not a hadron"
- DIMENSION IPARPD(30),ISETPD(30)
-* PDF parametrization
- DATA IPARPD /
- & -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5,
- & 5, 5,-5, 5, 5, 0, 0, 0, 0, 0/
-* number of set
- DATA ISETPD /
- & -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6,
- & 6, 6,-2, 2, 2, 0, 0, 0, 0, 0/
-
-**PHOJET105a
-C COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
-C PARAMETER ( MAXPRO = 16 )
-C PARAMETER ( MAXTAB = 20 )
-C COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO),
-C & MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB
-C CHARACTER*8 MDLNA
-C COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
-C COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15)
-**PHOJET110
-C global event kinematics and particle IDs
- INTEGER IFPAP,IFPAB
- DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
- COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
-C hard cross sections and MC selection weights
- INTEGER Max_pro_2
- PARAMETER ( Max_pro_2 = 16 )
- INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
- & MH_acc_1,MH_acc_2
- DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
- COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
- & HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
- & HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
- & MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
- & MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
-C model switches and parameters
- CHARACTER*8 MDLNA
- INTEGER ISWMDL,IPAMDL
- DOUBLE PRECISION PARMDL
- COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
-C general process information
- INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
- COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
-**
- DIMENSION PP(4),PT(4)
-
- LOGICAL LSTART
- DATA LSTART /.TRUE./
-
- IJP = IJPROJ
- IJT = IJTARG
- Q2 = VIRT
-* lepton-projectiles: initialize real photon instead
- IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN
- IJP = 7
- Q2 = ZERO
- ENDIF
-
- IF (LPHOIN) CALL PHO_INIT(-1,IDUM)
-
-* switch Reggeon off
-C IPAMDL(3)= 0
- IF (IP.EQ.1) THEN
- IFPAP(1) = IDT_IPDGHA(IJP)
- IFPAB(1) = IJP
- ELSE
- IFPAP(1) = 2212
- IFPAB(1) = IDT_ICIHAD(IFPAP(1))
- ENDIF
- PMASS(1) = AAM(IFPAB(1))-SQRT(Q2)
- PVIRT(1) = PMASS(1)**2
- IF (IT.EQ.1) THEN
- IFPAP(2) = IDT_IPDGHA(IJT)
- IFPAB(2) = IJT
- ELSE
- IFPAP(2) = 2212
- IFPAB(2) = IDT_ICIHAD(IFPAP(2))
- ENDIF
- PMASS(2) = AAM(IFPAB(2))
- PVIRT(2) = ZERO
- DO 1 K=1,4
- PP(K) = ZERO
- PT(K) = ZERO
- 1 CONTINUE
-* get max. possible momenta of incoming particles to be used for PHOJET ini.
- PPF = ZERO
- PTF = ZERO
- SCPF= 1.5D0
- IF (UMO.GE.1.E5) THEN
- SCPF= 5.0D0
- ENDIF
- IF (NCOMPO.GT.0) THEN
- DO 2 I=1,NCOMPO
- IF (IT.GT.1) THEN
- CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0)
- ELSE
- CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0)
- ENDIF
- PPFTMP = MAX(PFERMP(1),PFERMN(1))
- PTFTMP = MAX(PFERMP(2),PFERMN(2))
- IF (PPFTMP.GT.PPF) PPF = PPFTMP
- IF (PTFTMP.GT.PTF) PTF = PTFTMP
- 2 CONTINUE
- ELSE
- CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
- PPF = MAX(PFERMP(1),PFERMN(1))
- PTF = MAX(PFERMP(2),PFERMN(2))
- ENDIF
- PTF = -PTF
- PPF = SCPF*PPF
- PTF = SCPF*PTF
- IF (IJP.EQ.7) THEN
- AMP2 = SIGN(PMASS(1)**2,PMASS(1))
- PP(3) = PPCM
- PP(4) = SQRT(AMP2+PP(3)**2)
- ELSE
- EPF = SQRT(PPF**2+PMASS(1)**2)
- CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2)
- ENDIF
- ETF = SQRT(PTF**2+PMASS(2)**2)
- CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3)
- ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
- & (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
- IF (LSTART) THEN
-C *** Commented by Chiara
-C WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP
- 1001 FORMAT(
- & ' DT_PHOINI: PHOJET initialized for projectile A,Z = ',
- & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
-C *** Commented by Chiara
-C IF (NCOMPO.GT.0) THEN
-C WRITE(LOUT,1002) SCPF,PTF,PT
-C ELSE
-C WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT
-C ENDIF
- 1002 FORMAT(
- & ' DT_PHOINI: PHOJET initialized for target emulsion ',
- & /,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
- 1003 FORMAT(
- & ' DT_PHOINI: PHOJET initialized for target A,Z = ',
- & I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,' p(max) = ',4E10.3)
-C *** Commented by Chiara
-C WRITE(LOUT,1004) ECMINI
- 1004 FORMAT(' E_cm = ',E10.3)
- IF (IJP.EQ.8) WRITE(LOUT,1005)
- 1005 FORMAT(
- & ' DT_PHOINI: warning! proton parameters used for neutron',
- & ' projectile')
- LSTART = .FALSE.
- ENDIF
-* switch off new diffractive cross sections at low energies for nuclei
-* (temporary solution)
- IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN
- WRITE(LOUT,'(1X,A)')
- & ' DT_PHOINI: model-switch 30 for nuclei re-set !'
- CALL PHO_SETMDL(30,0,1)
- ENDIF
-*
-C IF (IJP.EQ.7) THEN
-C AMP2 = SIGN(PMASS(1)**2,PMASS(1))
-C PP(3) = PPCM
-C PP(4) = SQRT(AMP2+PP(3)**2)
-C ELSE
-C PFERMX = ZERO
-C IF (IP.GT.1) PFERMX = 0.5D0
-C EFERMX = SQRT(PFERMX**2+PMASS(1)**2)
-C CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2)
-C ENDIF
-C PFERMX = ZERO
-C IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0
-C EFERMX = SQRT(PFERMX**2+PMASS(2)**2)
-C CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3)
-**sr 26.10.96
- ISAV = IPAMDL(13)
- IF ((ISHAD(2).EQ.1).AND.
- & ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR.
- & (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1
-**
-
- CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1)
-
-**sr 26.10.96
- IPAMDL(13) = ISAV
-**
-*
-* patch for cascade calculations:
-* define parton distribution functions for other hadrons, i.e. other
-* then defined already in phojet
- IF (IOGLB.EQ.100) THEN
- WRITE(LOUT,1006)
- 1006 FORMAT(/,1X,'PHOINI: additional parton distribution functions',
- & ' assiged (ID,IPAR,ISET)',/)
- NPDF = 0
- DO 3 I=1,30
- IF (IPARPD(I).NE.0) THEN
- NPDF = NPDF+1
- IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !'
- IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN
- IDPDG = IDT_IPDGHA(I)
- IPAR = IPARPD(I)
- ISET = ISETPD(I)
- WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET
- CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1)
- ENDIF
- ENDIF
- 3 CONTINUE
- ENDIF
-
-C CALL PHO_PHIST(-1,SIGMAX)
-
- IF (IREJ1.NE.0) THEN
- WRITE(LOUT,1000)
- 1000 FORMAT(1X,'PHOINI: PHOJET event-initialization failed!')
- STOP
- ENDIF
-
- RETURN
- END
-
-*
-*===eventd=============================================================*
-*
-CDECK ID>, DT_EVENTD
- SUBROUTINE DT_EVENTD(IREJ)
-
-************************************************************************
-* Quasi-elastic neutrino nucleus scattering. *
-* This version dated 29.04.00 is written by S. Roesler. *
-************************************************************************
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( LINP = 5 ,
- & LOUT = 6 ,
- & LDAT = 9 )
-
- PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5)
- PARAMETER (SQTINF=1.0D+15)
-
- LOGICAL LFIRST
-
-* event history
-
- PARAMETER (NMXHKK=200000)
-
- COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
- & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
- & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
-* extended event history
- COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
- & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
- & IHIST(2,NMXHKK)
-* flags for input different options
- LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
- COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
- & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
-
- PARAMETER (MAXLND=4000)
- COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
-
-* properties of interacting particles
- COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
-* Lorentz-parameters of the current interaction
- COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
- & UMO,PPCM,EPROJ,PPROJ
-* nuclear potential
- LOGICAL LFERMI
- COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
- & EBINDP(2),EBINDN(2),EPOT(2,210),
- & ETACOU(2),ICOUL,LFERMI
-* steering flags for qel neutrino scattering modules
- COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
- COMMON /QNPOL/ POLARX(4),PMODUL
-
- INTEGER PYK
-
- DATA LFIRST /.TRUE./
-
- IREJ = 0
-
- IF (LFIRST) THEN
- LFIRST = .FALSE.
- CALL DT_MASS_INI
- ENDIF
-
-* JETSET parameter
- CALL DT_INITJS(0)
-
-* interacting target nucleon
- LTYP = NEUTYP
- IF (NEUDEC.LE.9) THEN
- IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN
- NUCTYP = 2112
- NUCTOP = 2
- ELSE
- NUCTYP = 2212
- NUCTOP = 1
- ENDIF
- ELSE
- RTYP = DT_RNDM(RTYP)
- ZFRAC = DBLE(ITZ)/DBLE(IT)
- IF (RTYP.LE.ZFRAC) THEN
- NUCTYP = 2212
- NUCTOP = 1
- ELSE
- NUCTYP = 2112
- NUCTOP = 2
- ENDIF
- ENDIF
-
-* select first nucleon in list with matching id and reset all other
-* nucleons which have been marked as "wounded" by ININUC
- IFOUND = 0
- DO 1 I=1,NHKK
- IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN
- ISTHKK(I) = 12
- IFOUND = 1
- IDX = I
- ELSE
- IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14
- ENDIF
- 1 CONTINUE
- IF (IFOUND.EQ.0)
- & STOP ' EVENTD: interacting target nucleon not found! '
-
-* correct position of proj. lepton: assume position of target nucleon
- DO 3 I=1,4
- VHKK(I,1) = VHKK(I,IDX)
- WHKK(I,1) = WHKK(I,IDX)
- 3 CONTINUE
-
-* load initial momenta for conservation check
- IF (LEMCCK) THEN
- CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM)
- CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX),
- & 2,IDUM,IDUM)
- ENDIF
-
-* quasi-elastic scattering
- IF (NEUDEC.LT.9) THEN
- CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),
- & PHKK(4,IDX),PHKK(5,IDX))
-* CC event on p or n
- ELSEIF (NEUDEC.EQ.10) THEN
- CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX),
- & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
-* NC event on p or n
- ELSEIF (NEUDEC.EQ.11) THEN
- CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX),
- & PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
- ENDIF
-
-* get final state particles from Lund-common and write them into HKKEVT
- NPOINT(1) = NHKK+1
- NPOINT(4) = NHKK+1
-
- NLINES = PYK(0,1)
-
- NHKK0 = NHKK+1
- DO 4 I=4,NLINES
- IF (K(I,1).EQ.1) THEN
- ID = K(I,2)
- PX = P(I,1)
- PY = P(I,2)
- PZ = P(I,3)
- PE = P(I,4)
- CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0)
- IDBJ = IDT_ICIHAD(ID)
- EKIN = PHKK(4,NHKK)-PHKK(5,NHKK)
- IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN
- IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16
- ENDIF
- VHKK(1,NHKK) = VHKK(1,IDX)
- VHKK(2,NHKK) = VHKK(2,IDX)
- VHKK(3,NHKK) = VHKK(3,IDX)
- VHKK(4,NHKK) = VHKK(4,IDX)
-C IF (I.EQ.4) THEN
-C WHKK(1,NHKK) = POLARX(1)
-C WHKK(2,NHKK) = POLARX(2)
-C WHKK(3,NHKK) = POLARX(3)
-C WHKK(4,NHKK) = POLARX(4)
-C ELSE
- WHKK(1,NHKK) = WHKK(1,IDX)
- WHKK(2,NHKK) = WHKK(2,IDX)
- WHKK(3,NHKK) = WHKK(3,IDX)
- WHKK(4,NHKK) = WHKK(4,IDX)
-C ENDIF
- IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
- ENDIF
- 4 CONTINUE
-
- IF (LEMCCK) THEN
- CHKLEV = TINY5
- CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1)
- IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
- ENDIF
-
-* transform momenta into cms (as required for inc etc.)
- DO 5 I=NHKK0,NHKK
- IF (ISTHKK(I).EQ.1) THEN
- CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3)
- PHKK(3,I) = PZ
- PHKK(4,I) = PE
- ENDIF
- 5 CONTINUE
-
- RETURN
- END
-*
-*===kkevnt=============================================================*
-*
-CDECK ID>, DT_KKEVNT
- SUBROUTINE DT_KKEVNT(KKMAT,IREJ)
-
-************************************************************************
-* Treatment of complete nucleus-nucleus or hadron-nucleus scattering *
-* without nuclear effects (one event). *
-* This subroutine is an update of the previous version (KKEVT) written *
-* by J. Ranft/ H.-J. Moehring. *
-* This version dated 20.04.95 is written by S. Roesler *
-************************************************************************
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( LINP = 5 ,
- & LOUT = 6 ,
- & LDAT = 9 )
-
- PARAMETER (ZERO=0.0D0,TINY10=1.0D-10)
-
- PARAMETER ( MAXNCL = 260,
-
- & MAXVQU = MAXNCL,
- & MAXSQU = 20*MAXVQU,
- & MAXINT = MAXVQU+MAXSQU)
-* event history
-
- PARAMETER (NMXHKK=200000)
-
- COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
- & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
- & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
-* extended event history
- COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
- & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
- & IHIST(2,NMXHKK)
-* flags for input different options
- LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
- COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
- & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
-* rejection counter
- COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
- & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
- & IREXCI(3),IRDIFF(2),IRINC
-* statistics
- COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
- & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
- & ICEVTG(8,0:30)
-* properties of interacting particles
- COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
-* Lorentz-parameters of the current interaction
- COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
- & UMO,PPCM,EPROJ,PPROJ
-* flags for diffractive interactions (DTUNUC 1.x)
- COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
-* interface HADRIN-DPM
- COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
-* nucleon-nucleon event-generator
- CHARACTER*8 CMODEL
- LOGICAL LPHOIN
- COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
-* coordinates of nucleons
- COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
-* interface between Glauber formalism and DPM
- COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
- & INTER1(MAXINT),INTER2(MAXINT)
-* Glauber formalism: collision properties
- COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
- & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
-* central particle production, impact parameter biasing
- COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
-**temporary
-* statistics: Glauber-formalism
- COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
-**
-
- DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/
-
- IREJ = 0
- ICREQU = ICREQU+1
- NC = 0
-
- 1 CONTINUE
- ICSAMP = ICSAMP+1
- NC = NC+1
- IF (MOD(NC,10).EQ.0) THEN
- WRITE(LOUT,1000) NEVHKK
- 1000 FORMAT(1X,'KKEVNT: event ',I8,' rejected!')
- GOTO 9999
- ENDIF
-
-* initialize DTEVT1/DTEVT2
- CALL DT_EVTINI
-
-* We need the following only in order to sample nucleon coordinates.
-* However we don't have parameters (cross sections, slope etc.)
-* for neutrinos available. Therefore switch projectile to proton
-* in this case.
- IF (MCGENE.EQ.4) THEN
- JJPROJ = 1
- ELSE
- JJPROJ = IJPROJ
- ENDIF
-
- 10 CONTINUE
- IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR.
-* make sure that Glauber-formalism is called each time the interaction
-* configuration changed
- & (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR.
- & (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN
-* sample number of nucleon-nucleon coll. according to Glauber-form.
- CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT)
-* --- Added by Chiara to monit impact parameter generation
-* PRINT *,' Impact parameter generation : b = ', BIMPAC, 'fm'
- NWTSAM = NN
- NWASAM = NP
- NWBSAM = NT
- NEVOLD = NEVHKK
- IPOLD = IP
- ITOLD = IT
- JJPOLD = JJPROJ
- EPROLD = EPROJ
- ENDIF
-
-* force diffractive particle production in h-K interactions
- IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND.
- & (IP.EQ.1).AND.(NN.NE.1)) THEN
- NEVOLD = 0
- GOTO 10
- ENDIF
-
-* check number of involved proj. nucl. (NP) if central prod.is requested
- IF (ICENTR.GT.0) THEN
- CALL DT_CHKCEN(IP,IT,NP,NT,IBACK)
- IF (IBACK.GT.0) GOTO 10
- ENDIF
-
-* get initial nucleon-configuration in projectile and target
-* rest-system (including Fermi-momenta if requested)
- CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1)
- MODE = 2
- IF (EPROJ.LE.EHADTH) MODE = 3
- CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE)
-
- IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN
-
-* activate HADRIN at low energies (implemented for h-N scattering only)
- IF (EPROJ.LE.EHADHI) THEN
- IF (EHADTH.LT.ZERO) THEN
-* smooth transition btwn. DPM and HADRIN
- FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO)
- RR = DT_RNDM(FRAC)
- IF (RR.GT.FRAC) THEN
- IF (IP.EQ.1) THEN
- CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
- IF (IREJ1.GT.0) GOTO 1
- RETURN
- ELSE
- WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
- ENDIF
- ENDIF
- ELSE
-* fixed threshold for onset of production via HADRIN
- IF (EPROJ.LE.EHADTH) THEN
- IF (IP.EQ.1) THEN
- CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
- IF (IREJ1.GT.0) GOTO 1
- RETURN
- ELSE
- WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- 1001 FORMAT(1X,'KKEVNT: warning! interaction of proj. (m=',
- & I3,') with target (m=',I3,')',/,11X,
- & 'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1,
- & 'GeV) cannot be handled')
-
-* sampling of momentum-x fractions & flavors of chain ends
- CALL DT_SPLPTN(NN)
-
-* Lorentz-transformation of wounded nucleons into nucl.-nucl. cms
- CALL DT_NUC2CM
-
-* collect momenta of chain ends and put them into DTEVT1
- CALL DT_GETPTN(IP,NN,NCSY,IREJ1)
- IF (IREJ1.NE.0) GOTO 1
-
- ENDIF
-
-* handle chains including fragmentation (two-chain approximation)
- IF (MCGENE.EQ.1) THEN
-* two-chain approximation
- CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1)
- IF (IREJ1.NE.0) THEN
- IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT'
- GOTO 1
- ENDIF
- ELSEIF (MCGENE.EQ.2) THEN
-* multiple-Po exchange including minijets
- CALL DT_EVENTB(NCSY,IREJ1)
- IF (IREJ1.NE.0) THEN
- IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT'
- GOTO 1
- ENDIF
- ELSEIF (MCGENE.EQ.3) THEN
-
- STOP ' This version does not contain LEPTO !'
-
- ELSEIF (MCGENE.EQ.4) THEN
-* quasi-elastic neutrino scattering
- CALL DT_EVENTD(IREJ1)
- IF (IREJ1.NE.0) THEN
- IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT'
- GOTO 1
- ENDIF
- ELSE
- WRITE(LOUT,1002) MCGENE
- 1002 FORMAT(1X,'KKEVNT: warning! event-generator',I4,
- & ' not available - program stopped')
- STOP
- ENDIF
-
- RETURN
-
- 9999 CONTINUE
- IREJ = 1
- RETURN
- END
-*
-*===chkcen=============================================================*
-*
-CDECK ID>, DT_CHKCEN
- SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK)
-
-************************************************************************
-* Check of number of involved projectile nucleons if central production*
-* is requested. *
-* Adopted from a part of the old KKEVT routine which was written by *
-* J. Ranft/H.-J.Moehring. *
-* This version dated 13.01.95 is written by S. Roesler *
-************************************************************************
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( LINP = 5 ,
- & LOUT = 6 ,
- & LDAT = 9 )
-
-* statistics
- COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
- & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
- & ICEVTG(8,0:30)
-* central particle production, impact parameter biasing
- COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
-
- IBACK = 0
-
-* old version
- IF (ICENTR.EQ.2) THEN
- IF (IP.LT.IT) THEN
- IF (IP.LE.8) THEN
- IF (NP.LT.IP-1) IBACK = 1
- ELSEIF (IP.LE.16) THEN
- IF (NP.LT.IP-2) IBACK = 1
- ELSEIF (IP.LE.32) THEN
- IF (NP.LT.IP-3) IBACK = 1
- ELSEIF (IP.GE.33) THEN
- IF (NP.LT.IP-5) IBACK = 1
- ENDIF
- ELSEIF (IP.EQ.IT) THEN
- IF (IP.EQ.32) THEN
- IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
- ELSE
- IF (NP.LT.IP-IP/8) IBACK = 1
- ENDIF
- ELSEIF (ABS(IP-IT).LT.3) THEN
- IF (NP.LT.IP-IP/8) IBACK = 1
- ENDIF
- ELSE
-* new version (DPMJET, 5.6.99)
- IF (IP.LT.IT) THEN
- IF (IP.LE.8) THEN
- IF (NP.LT.IP-1) IBACK = 1
- ELSEIF (IP.LE.16) THEN
- IF (NP.LT.IP-2) IBACK = 1
- ELSEIF (IP.LT.32) THEN
- IF (NP.LT.IP-3) IBACK = 1
- ELSEIF (IP.GE.32) THEN
- IF (IT.LE.150) THEN
-* Example: S-Ag
- IF (NP.LT.IP-1) IBACK = 1
- ELSE
-* Example: S-Au
- IF (NP.LT.IP) IBACK = 1
- ENDIF
- ENDIF
- ELSEIF (IP.EQ.IT) THEN
-* Example: S-S
- IF (IP.EQ.32) THEN
- IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
-* Example: Pb-Pb
- ELSE
- IF (NP.LT.IP-IP/4) IBACK = 1
- ENDIF
- ELSEIF (ABS(IP-IT).LT.3) THEN
- IF (NP.LT.IP-IP/8) IBACK = 1
- ENDIF
- ENDIF
-
- ICCPRO = ICCPRO+1
-
- RETURN
- END
-*
-*===ininuc=============================================================*
-*
-CDECK ID>, DT_ININUC
- SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE)
-
-************************************************************************
-* Samples initial configuration of nucleons in nucleus with mass NMASS *
-* including Fermi-momenta (if reqested). *
-* ID BAMJET-code for hadrons (instead of nuclei) *
-* NMASS mass number of nucleus (number of nucleons) *
-* NCH charge of nucleus *
-* COORD(3,NMASS) coordinates of nucleons inside nucleus in fm *
-* JS(NMASS) > 0 nucleon undergoes nucleon-nucleon interact. *
-* IMODE = 1 projectile nucleus *
-* = 2 target nucleus *
-* = 3 target nucleus (E_lab<E_thr for HADRIN) *
-* Adopted from a part of the old KKEVT routine which was written by *
-* J. Ranft/H.-J.Moehring. *
-* This version dated 13.01.95 is written by S. Roesler *
-************************************************************************
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( LINP = 5 ,
- & LOUT = 6 ,
- & LDAT = 9 )
-
- PARAMETER (FM2MM=1.0D-12)
-
- PARAMETER ( MAXNCL = 260,
-
- & MAXVQU = MAXNCL,
- & MAXSQU = 20*MAXVQU,
- & MAXINT = MAXVQU+MAXSQU)
-* event history
-
- PARAMETER (NMXHKK=200000)
-
- COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
- & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
- & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
-* extended event history
- COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
- & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
- & IHIST(2,NMXHKK)
-* flags for input different options
- LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
- COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
- & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
-* auxiliary common for chain system storage (DTUNUC 1.x)
- COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
-* nuclear potential
- LOGICAL LFERMI
- COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
- & EBINDP(2),EBINDN(2),EPOT(2,210),
- & ETACOU(2),ICOUL,LFERMI
-* properties of photon/lepton projectiles
- COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
-* particle properties (BAMJET index convention)
- CHARACTER*8 ANAME
- COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
- & IICH(210),IIBAR(210),K1(210),K2(210)
-* Glauber formalism: collision properties
- COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
- & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
-* flavors of partons (DTUNUC 1.x)
- COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
- & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
- & IPSQ(MAXSQU),IPSQ2(MAXSQU),
- & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
- & ITSQ(MAXSQU),ITSQ2(MAXSQU),
- & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
- & KKPROJ(MAXVQU),KKTARG(MAXVQU)
-* interface HADRIN-DPM
- COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
-
- DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL)
-
-* number of neutrons
- NNEU = NMASS-NCH
-* initializations
- NP = 0
- NN = 0
- DO 1 K=1,4
- PFTOT(K) = 0.0D0
- 1 CONTINUE
- MODE = IMODE
- IF (IMODE.GT.2) MODE = 2
-**sr 29.5. new NPOINT(1)-definition
-C IF (IMODE.GE.2) NPOINT(1) = NHKK+1
-**
- NHADRI = 0
- NC = NHKK
-
-* get initial configuration
- DO 2 I=1,NMASS
- NHKK = NHKK+1
- IF (JS(I).GT.0) THEN
- ISTHKK(NHKK) = 10+MODE
- IF (IMODE.EQ.3) THEN
-* additional treatment if HADRIN-generator is requested
- NHADRI = NHADRI+1
- IF (NHADRI.EQ.1) IDXTA = NHKK
- IF (NHADRI.GT.1) ISTHKK(NHKK) = 14
- ENDIF
- ELSE
- ISTHKK(NHKK) = 12+MODE
- ENDIF
- IF (NMASS.GE.2) THEN
-* treatment for nuclei
- FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS)
- RR = DT_RNDM(FRAC)
- IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN
- IDX = 8
- NN = NN+1
- ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN
- IDX = 1
- NP = NP+1
- ELSEIF (NN.LT.NNEU) THEN
- IDX = 8
- NN = NN+1
- ELSEIF (NP.LT.NCH) THEN
- IDX = 1
- NP = NP+1
- ENDIF
- IDHKK(NHKK) = IDT_IPDGHA(IDX)
- IDBAM(NHKK) = IDX
- IF (MODE.EQ.1) THEN
- IPOSP(I) = NHKK
- KKPROJ(I) = IDX
- ELSE
- IPOST(I) = NHKK
- KKTARG(I) = IDX
- ENDIF
- IF (IDX.EQ.1) THEN
- PFER = PFERMP(MODE)
- PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1))
- ELSE
- PFER = PFERMN(MODE)
- PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8))
- ENDIF
- CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX)
- DO 3 K=1,4
- PFTOT(K) = PFTOT(K)+PF(K)
- PHKK(K,NHKK) = PF(K)
- 3 CONTINUE
- PHKK(5,NHKK) = AAM(IDX)
- ELSE
-* treatment for hadrons
-
- IDHKK(NHKK) = IDT_IPDGHA(ID)
- IDBAM(NHKK) = ID
- PHKK(4,NHKK) = AAM(ID)
- PHKK(5,NHKK) = AAM(ID)
-
-C * VDM assumption
-C IF (IDHKK(NHKK).EQ.22) THEN
-C PHKK(4,NHKK) = AAM(33)
-C PHKK(5,NHKK) = AAM(33)
-C ENDIF
- IF (MODE.EQ.1) THEN
- IPOSP(I) = NHKK
- KKPROJ(I) = ID
- PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
- ELSE
- IPOST(I) = NHKK
- KKTARG(I) = ID
- ENDIF
- ENDIF
- DO 4 K=1,3
- VHKK(K,NHKK) = COORD(K,I)*FM2MM
- WHKK(K,NHKK) = COORD(K,I)*FM2MM
- 4 CONTINUE
- IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM
- IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM
- VHKK(4,NHKK) = 0.0D0
- WHKK(4,NHKK) = 0.0D0
- 2 CONTINUE
-
-* balance Fermi-momenta
- IF (NMASS.GE.2) THEN
- DO 5 I=1,NMASS
- NC = NC+1
- DO 6 K=1,3
- PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
- 6 CONTINUE
- PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
- & PHKK(2,NC)**2+PHKK(3,NC)**2)
- 5 CONTINUE
- ENDIF
-
- RETURN
- END
-*
-*===fer4m==============================================================*
-*
-CDECK ID>, DT_FER4M
- SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
-
-************************************************************************
-* Sampling of nucleon Fermi-momenta from distributions at T=0. *
-* processed by S. Roesler, 17.10.95 *
-************************************************************************
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( LINP = 5 ,
- & LOUT = 6 ,
- & LDAT = 9 )
-
- LOGICAL LSTART
-
-* particle properties (BAMJET index convention)
- CHARACTER*8 ANAME
- COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
- & IICH(210),IIBAR(210),K1(210),K2(210)
-* nuclear potential
- LOGICAL LFERMI
- COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
- & EBINDP(2),EBINDN(2),EPOT(2,210),
- & ETACOU(2),ICOUL,LFERMI
-
- DATA LSTART /.TRUE./
-
- ILOOP = 0
- IF (LFERMI) THEN
- IF (LSTART) THEN
- WRITE(LOUT,1000)
- 1000 FORMAT(/,1X,'FER4M: sampling of Fermi-momenta activated')
- LSTART = .FALSE.
- ENDIF
- 1 CONTINUE
- CALL DT_DFERMI(PABS)
- PABS = PFERM*PABS
-C IF (PABS.GE.PBIND) THEN
-C ILOOP = ILOOP+1
-C IF (MOD(ILOOP,500).EQ.0) THEN
-C WRITE(LOUT,1001) PABS,PBIND,ILOOP
-C1001 FORMAT(1X,'FER4M: Fermi-mom. corr. for binding',
-C & ' energy ',2E12.3,I6)
-C ENDIF
-C GOTO 1
-C ENDIF
- CALL DT_DPOLI(POLC,POLS)
- CALL DT_DSFECF(SFE,CFE)
- CXTA = POLS*CFE
- CYTA = POLS*SFE
- CZTA = POLC
- ET = SQRT(PABS*PABS+AAM(KT)**2)
- PXT = CXTA*PABS
- PYT = CYTA*PABS
- PZT = CZTA*PABS
- ELSE
- ET = AAM(KT)
- PXT = 0.0D0
- PYT = 0.0D0
- PZT = 0.0D0
- ENDIF
-
- RETURN
- END
-*
-*===nuc2cm=============================================================*
-*
-CDECK ID>, DT_NUC2CM
- SUBROUTINE DT_NUC2CM
-
-************************************************************************
-* Lorentz-transformation of all wounded nucleons from Lab. to nucl.- *
-* nucl. cms. (This subroutine replaces NUCMOM.) *
-* This version dated 15.01.95 is written by S. Roesler *
-************************************************************************
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( LINP = 5 ,
- & LOUT = 6 ,
- & LDAT = 9 )
-
- PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
-
-* event history
-
- PARAMETER (NMXHKK=200000)
-
- COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
- & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
- & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
-* extended event history
- COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
- & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
- & IHIST(2,NMXHKK)
-* statistics
- COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
- & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
- & ICEVTG(8,0:30)
-* properties of photon/lepton projectiles
- COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
-* particle properties (BAMJET index convention)
- CHARACTER*8 ANAME
- COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
- & IICH(210),IIBAR(210),K1(210),K2(210)
-* Glauber formalism: collision properties
- COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
- & NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
-**temporary
-* statistics: Glauber-formalism
- COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
-**
-
- ICWP = 0
- ICWT = 0
- NWTACC = 0
- NWAACC = 0
- NWBACC = 0
-
- NPOINT(1) = NHKK+1
- NEND = NHKK
- DO 1 I=1,NEND
- IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN
- IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1
- IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1
- MODE = ISTHKK(I)-9
-C IF (IDHKK(I).EQ.22) THEN
-C* VDM assumption
-C PEIN = AAM(33)
-C IDB = 33
-C ELSE
-C PEIN = PHKK(4,I)
-C IDB = IDBAM(I)
-C ENDIF
-C CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
-C & PX,PY,PZ,PE,IDB,MODE)
- IF (PHKK(5,I).GT.ZERO) THEN
- CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
- & PX,PY,PZ,PE,IDBAM(I),MODE)
- ELSE
- PX = PGAMM(1)
- PY = PGAMM(2)
- PZ = PGAMM(3)
- PE = PGAMM(4)
- ENDIF
- IST = ISTHKK(I)-2
- ID = IDHKK(I)
-C* VDM assumption
-C IF (ID.EQ.22) ID = 113
- CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0)
- IF (ISTHKK(I).EQ.11) ICWP = ICWP+1
- IF (ISTHKK(I).EQ.12) ICWT = ICWT+1
- ENDIF
- 1 CONTINUE
-
- NWTACC = MAX(NWAACC,NWBACC)
- ICDPR = ICDPR+ICWP
- ICDTA = ICDTA+ICWT
-**temporary
- IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
- CALL DT_EVTOUT(4)
- STOP
- ENDIF
-
- RETURN
- END
-*
-*===splptn=============================================================*
-*
-CDECK ID>, DT_SPLPTN
- SUBROUTINE DT_SPLPTN(NN)
-
-************************************************************************
-* SamPLing of ParToN momenta and flavors. *
-* This version dated 15.01.95 is written by S. Roesler *
-************************************************************************
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( LINP = 5 ,
- & LOUT = 6 ,
- & LDAT = 9 )
-
-* Lorentz-parameters of the current interaction
- COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
- & UMO,PPCM,EPROJ,PPROJ
-
-* sample flavors of sea-quarks
- CALL DT_SPLFLA(NN,1)
-
-* sample x-values of partons at chain ends
- ECM = UMO
- CALL DT_XKSAMP(NN,ECM)
-
-* samle flavors
- CALL DT_SPLFLA(NN,2)
-
- RETURN
- END
-*
-*===splfla=============================================================*
-*
-CDECK ID>, DT_SPLFLA
- SUBROUTINE DT_SPLFLA(NN,MODE)
-
-************************************************************************
-* SamPLing of FLAvors of partons at chain ends. *
-* This subroutine replaces FLKSAA/FLKSAM. *
-* NN number of nucleon-nucleon interactions *
-* MODE = 1 sea-flavors *
-* = 2 valence-flavors *
-* Based on the original version written by J. Ranft/H.-J. Moehring. *
-* This version dated 16.01.95 is written by S. Roesler *
-************************************************************************
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( LINP = 5 ,
- & LOUT = 6 ,
- & LDAT = 9 )
-
- PARAMETER ( MAXNCL = 260,
-
- & MAXVQU = MAXNCL,
- & MAXSQU = 20*MAXVQU,
- & MAXINT = MAXVQU+MAXSQU)
-* flavors of partons (DTUNUC 1.x)
- COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
- & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
- & IPSQ(MAXSQU),IPSQ2(MAXSQU),
- & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
- & ITSQ(MAXSQU),ITSQ2(MAXSQU),
- & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
- & KKPROJ(MAXVQU),KKTARG(MAXVQU)
-* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
- COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
- & IXPV,IXPS,IXTV,IXTS,
- & INTVV1(MAXVQU),INTVV2(MAXVQU),
- & INTSV1(MAXVQU),INTSV2(MAXVQU),
- & INTVS1(MAXVQU),INTVS2(MAXVQU),
- & INTSS1(MAXSQU),INTSS2(MAXSQU),
- & INTDV1(MAXVQU),INTDV2(MAXVQU),
- & INTVD1(MAXVQU),INTVD2(MAXVQU),
- & INTDS1(MAXSQU),INTDS2(MAXSQU),
- & INTSD1(MAXSQU),INTSD2(MAXSQU)
-* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
- COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
- & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
-* particle properties (BAMJET index convention)
- CHARACTER*8 ANAME
- COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
- & IICH(210),IIBAR(210),K1(210),K2(210)
-* various options for treatment of partons (DTUNUC 1.x)
-* (chain recombination, Cronin,..)
- LOGICAL LCO2CR,LINTPT
- COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
- & LCO2CR,LINTPT
-
- IF (MODE.EQ.1) THEN
-* sea-flavors
- DO 1 I=1,NN
- IPSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
- IPSAQ(I) = -IPSQ(I)
- 1 CONTINUE
- DO 2 I=1,NN
- ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
- ITSAQ(I)= -ITSQ(I)
- 2 CONTINUE
- ELSEIF (MODE.EQ.2) THEN
-* valence flavors
- DO 3 I=1,IXPV
- CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
- 3 CONTINUE
- DO 4 I=1,IXTV
- CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
- 4 CONTINUE
- ENDIF
-
- RETURN
- END
-*
-*===getptn=============================================================*
-*
-CDECK ID>, DT_GETPTN
- SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
-
-************************************************************************
-* This subroutine collects partons at chain ends from temporary *
-* commons and puts them into DTEVT1. *
-* This version dated 15.01.95 is written by S. Roesler *
-************************************************************************
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( LINP = 5 ,
- & LOUT = 6 ,
- & LDAT = 9 )
-
- PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
-
- LOGICAL LCHK
-
- PARAMETER ( MAXNCL = 260,
-
- & MAXVQU = MAXNCL,
- & MAXSQU = 20*MAXVQU,
- & MAXINT = MAXVQU+MAXSQU)
-* event history
-
- PARAMETER (NMXHKK=200000)
-
- COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
- & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
- & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
-* extended event history
- COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
- & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
- & IHIST(2,NMXHKK)
-* flags for input different options
- LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
- COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
- & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
-* auxiliary common for chain system storage (DTUNUC 1.x)
- COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
-* statistics
- COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
- & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
- & ICEVTG(8,0:30)
-* flags for diffractive interactions (DTUNUC 1.x)
- COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
-* x-values of partons (DTUNUC 1.x)
- COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
- & XTVQ(MAXVQU),XTVD(MAXVQU),
- & XPSQ(MAXSQU),XPSAQ(MAXSQU),
- & XTSQ(MAXSQU),XTSAQ(MAXSQU)
-* flavors of partons (DTUNUC 1.x)
- COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
- & ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
- & IPSQ(MAXSQU),IPSQ2(MAXSQU),
- & IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
- & ITSQ(MAXSQU),ITSQ2(MAXSQU),
- & ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
- & KKPROJ(MAXVQU),KKTARG(MAXVQU)
-* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
- COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
- & IXPV,IXPS,IXTV,IXTS,
- & INTVV1(MAXVQU),INTVV2(MAXVQU),
- & INTSV1(MAXVQU),INTSV2(MAXVQU),
- & INTVS1(MAXVQU),INTVS2(MAXVQU),
- & INTSS1(MAXSQU),INTSS2(MAXSQU),
- & INTDV1(MAXVQU),INTDV2(MAXVQU),
- & INTVD1(MAXVQU),INTVD2(MAXVQU),
- & INTDS1(MAXSQU),INTDS2(MAXSQU),
- & INTSD1(MAXSQU),INTSD2(MAXSQU)
-* auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
- COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
- & IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
-
- DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
-
- DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
-
- IREJ = 0
- NCSY = 0
- NPOINT(2) = NHKK+1
-
-* sea-sea chains
- DO 10 I=1,NSS
- IF (ISKPCH(1,I).EQ.99) GOTO 10
- ICCHAI(1,1) = ICCHAI(1,1)+2
- IDXP = INTSS1(I)
- IDXT = INTSS2(I)
- MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
- MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
- DO 11 K=1,4
- PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
- PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
- PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
- PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
- 11 CONTINUE
- PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
- & +(PP1(3)+PT1(3))**2)
- ECH = PP1(4)+PT1(4)
- AM1 = (ECH+PTOCH)*(ECH-PTOCH)
- PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
- & +(PP2(3)+PT2(3))**2)
- ECH = PP2(4)+PT2(4)
- AM2 = (ECH+PTOCH)*(ECH-PTOCH)
- IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
- AM1 = SQRT(AM1)
- AM2 = SQRT(AM2)
- IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
-C WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
- 5000 FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
- ENDIF
- ELSE
- WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
- ENDIF
- IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
- IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
- IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
- IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
- CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
- & 0,0,1)
- CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
- & 0,0,1)
- CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
- & 0,0,1)
- CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
- & 0,0,1)
- NCSY = NCSY+1
- 10 CONTINUE
-
-* disea-sea chains
- DO 20 I=1,NDS
- IF (ISKPCH(2,I).EQ.99) GOTO 20
- ICCHAI(1,2) = ICCHAI(1,2)+2
- IDXP = INTDS1(I)
- IDXT = INTDS2(I)
- MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
- MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
- DO 21 K=1,4
- PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
- PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
- PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
- PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
- 21 CONTINUE
- PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
- & +(PP1(3)+PT1(3))**2)
- ECH = PP1(4)+PT1(4)
- AM1 = (ECH+PTOCH)*(ECH-PTOCH)
- PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
- & +(PP2(3)+PT2(3))**2)
- ECH = PP2(4)+PT2(4)
- AM2 = (ECH+PTOCH)*(ECH-PTOCH)
- IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
- AM1 = SQRT(AM1)
- AM2 = SQRT(AM2)
- IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
-C WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
- 5001 FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
- ENDIF
- ELSE
- WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
- ENDIF
- IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
- IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
- IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2)
- IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
- CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
- & 0,0,2)
- CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
- & 0,0,2)
- CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
- & 0,0,2)
- CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
- & 0,0,2)
- NCSY = NCSY+1
- 20 CONTINUE
-
-* sea-disea chains
- DO 30 I=1,NSD
- IF (ISKPCH(3,I).EQ.99) GOTO 30
- ICCHAI(1,3) = ICCHAI(1,3)+2
- IDXP = INTSD1(I)
- IDXT = INTSD2(I)
- MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
- MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
- DO 31 K=1,4
- PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
- PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
- PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
- PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
- 31 CONTINUE
- PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
- & +(PP1(3)+PT1(3))**2)
- ECH = PP1(4)+PT1(4)
- AM1 = (ECH+PTOCH)*(ECH-PTOCH)
- PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
- & +(PP2(3)+PT2(3))**2)
- ECH = PP2(4)+PT2(4)
- AM2 = (ECH+PTOCH)*(ECH-PTOCH)
- IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
- AM1 = SQRT(AM1)
- AM2 = SQRT(AM2)
- IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
-C WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
- 5002 FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
- ENDIF
- ELSE
- WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
- ENDIF
- IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
- IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
- IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
- IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
- CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
- & 0,0,3)
- CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
- & 0,0,3)
- CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
- & 0,0,3)
- CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
- & 0,0,3)
- NCSY = NCSY+1
- 30 CONTINUE
-
-* disea-valence chains
- DO 50 I=1,NDV
- IF (ISKPCH(5,I).EQ.99) GOTO 50
- ICCHAI(1,5) = ICCHAI(1,5)+2
- IDXP = INTDV1(I)
- IDXT = INTDV2(I)
- MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
- MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
- DO 51 K=1,4
- PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
- PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
- PT1(K) = XTVQ(IDXT) *PHKK(K,MOT)
- PT2(K) = XTVD(IDXT) *PHKK(K,MOT)
- 51 CONTINUE
- PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
- & +(PP1(3)+PT1(3))**2)
- ECH = PP1(4)+PT1(4)
- AM1 = (ECH+PTOCH)*(ECH-PTOCH)
- PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
- & +(PP2(3)+PT2(3))**2)
- ECH = PP2(4)+PT2(4)
- AM2 = (ECH+PTOCH)*(ECH-PTOCH)
- IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
- AM1 = SQRT(AM1)
- AM2 = SQRT(AM2)
- IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
-C WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
- 5003 FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
- ENDIF
- ELSE
- WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
- ENDIF
- IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
- IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
- IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2)
- IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
- CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
- & 0,0,5)
- CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
- & 0,0,5)
- CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
- & 0,0,5)
- CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
- & 0,0,5)
- NCSY = NCSY+1
- 50 CONTINUE
-
-* valence-sea chains
- DO 60 I=1,NVS
- IF (ISKPCH(6,I).EQ.99) GOTO 60
- ICCHAI(1,6) = ICCHAI(1,6)+2
- IDXP = INTVS1(I)
- IDXT = INTVS2(I)
- MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
- MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
- DO 61 K=1,4
- PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
- PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
- PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
- PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
- 61 CONTINUE
- IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
- IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
- IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
- IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
- CALL DT_CHKCSY(IFP1,IFT1,LCHK)
- IF (LCHK) THEN
- CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
- & 0,0,6)
- CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
- & 0,0,6)
- CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
- & 0,0,6)
- CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
- & 0,0,6)
- PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
- & +(PP1(3)+PT1(3))**2)
- ECH = PP1(4)+PT1(4)
- AM1 = (ECH+PTOCH)*(ECH-PTOCH)
- PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
- & +(PP2(3)+PT2(3))**2)
- ECH = PP2(4)+PT2(4)
- AM2 = (ECH+PTOCH)*(ECH-PTOCH)
- ELSE
- CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
- & 0,0,6)
- CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
- & 0,0,6)
- CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
- & 0,0,6)
- CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
- & 0,0,6)
- PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
- & +(PP1(3)+PT2(3))**2)
- ECH = PP1(4)+PT2(4)
- AM2 = (ECH+PTOCH)*(ECH-PTOCH)
- PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
- & +(PP2(3)+PT1(3))**2)
- ECH = PP2(4)+PT1(4)
- AM1 = (ECH+PTOCH)*(ECH-PTOCH)
- ENDIF
- IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
- AM1 = SQRT(AM1)
- AM2 = SQRT(AM2)
- IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
-C WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
- 5004 FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
- ENDIF
- ELSE
- WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
- ENDIF
- NCSY = NCSY+1
- 60 CONTINUE
-
-* sea-valence chains
- DO 40 I=1,NSV
- IF (ISKPCH(4,I).EQ.99) GOTO 40
- ICCHAI(1,4) = ICCHAI(1,4)+2
- IDXP = INTSV1(I)
- IDXT = INTSV2(I)
- MOP = JDAHKK(1,IPOSP(IFROSP(IDXP)))
- MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
- DO 41 K=1,4
- PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
- PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
- PT1(K) = XTVD(IDXT) *PHKK(K,MOT)
- PT2(K) = XTVQ(IDXT) *PHKK(K,MOT)
- 41 CONTINUE
- PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
- & +(PP1(3)+PT1(3))**2)
- ECH = PP1(4)+PT1(4)
- AM1 = (ECH+PTOCH)*(ECH-PTOCH)
- PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
- & +(PP2(3)+PT2(3))**2)
- ECH = PP2(4)+PT2(4)
- AM2 = (ECH+PTOCH)*(ECH-PTOCH)
- IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
- AM1 = SQRT(AM1)
- AM2 = SQRT(AM2)
- IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
-C WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
- 5005 FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
- ENDIF
- ELSE
- WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
- ENDIF
- IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
- IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
- IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
- IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
- CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
- & 0,0,4)
- CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
- & 0,0,4)
- CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
- & 0,0,4)
- CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
- & 0,0,4)
- NCSY = NCSY+1
- 40 CONTINUE
-
-* valence-disea chains
- DO 70 I=1,NVD
- IF (ISKPCH(7,I).EQ.99) GOTO 70
- ICCHAI(1,7) = ICCHAI(1,7)+2
- IDXP = INTVD1(I)
- IDXT = INTVD2(I)
- MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
- MOT = JDAHKK(1,IPOST(IFROST(IDXT)))
- DO 71 K=1,4
- PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
- PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
- PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
- PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
- 71 CONTINUE
- IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
- IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
- IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
- IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
- CALL DT_CHKCSY(IFP1,IFT1,LCHK)
- IF (LCHK) THEN
- CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
- & 0,0,7)
- CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
- & 0,0,7)
- CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
- & 0,0,7)
- CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
- & 0,0,7)
- PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
- & +(PP1(3)+PT1(3))**2)
- ECH = PP1(4)+PT1(4)
- AM1 = (ECH+PTOCH)*(ECH-PTOCH)
- PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
- & +(PP2(3)+PT2(3))**2)
- ECH = PP2(4)+PT2(4)
- AM2 = (ECH+PTOCH)*(ECH-PTOCH)
- ELSE
- CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
- & 0,0,7)
- CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
- & 0,0,7)
- CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
- & 0,0,7)
- CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
- & 0,0,7)
- PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
- & +(PP1(3)+PT2(3))**2)
- ECH = PP1(4)+PT2(4)
- AM1 = (ECH+PTOCH)*(ECH-PTOCH)
- PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
- & +(PP2(3)+PT1(3))**2)
- ECH = PP2(4)+PT1(4)
- AM2 = (ECH+PTOCH)*(ECH-PTOCH)
- ENDIF
- IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
- AM1 = SQRT(AM1)
- AM2 = SQRT(AM2)
- IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
-C WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
- 5006 FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
- ENDIF
- ELSE
- WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
- ENDIF
- NCSY = NCSY+1
- 70 CONTINUE
-
-* valence-valence chains
- DO 80 I=1,NVV
- IF (ISKPCH(8,I).EQ.99) GOTO 80
- ICCHAI(1,8) = ICCHAI(1,8)+2
- IDXP = INTVV1(I)
- IDXT = INTVV2(I)
- MOP = JDAHKK(1,IPOSP(IFROVP(IDXP)))
- MOT = JDAHKK(1,IPOST(IFROVT(IDXT)))
- DO 81 K=1,4
- PP1(K) = XPVQ(IDXP)*PHKK(K,MOP)
- PP2(K) = XPVD(IDXP)*PHKK(K,MOP)
- PT1(K) = XTVD(IDXT)*PHKK(K,MOT)
- PT2(K) = XTVQ(IDXT)*PHKK(K,MOT)
- 81 CONTINUE
- IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
- IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
- IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
- IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
-
-* check for diffractive event
- IDIFF = 0
- IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
- & (IP.EQ.1).AND.(NN.EQ.1)) THEN
- DO 800 K=1,4
- PP(K) = PP1(K)+PP2(K)
- PT(K) = PT1(K)+PT2(K)
- 800 CONTINUE
- ISTCK = NHKK
- CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
- & IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
-C IF (IREJ1.NE.0) GOTO 9999
- IF (IREJ1.NE.0) THEN
- IDIFF = 0
- NHKK = ISTCK
- ENDIF
- ELSE
- IDIFF = 0
- ENDIF
-
- IF (IDIFF.EQ.0) THEN
-* valence-valence chain system
- CALL DT_CHKCSY(IFP1,IFT1,LCHK)
- IF (LCHK) THEN
-* baryon-baryon
- CALL DT_EVTPUT(-21,IFP1,MOP,0,
- & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
- CALL DT_EVTPUT(-22,IFT1,MOT,0,
- & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
- CALL DT_EVTPUT(-21,IFP2,MOP,0,
- & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
- CALL DT_EVTPUT(-22,IFT2,MOT,0,
- & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
- PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
- & +(PP1(3)+PT1(3))**2)
- ECH = PP1(4)+PT1(4)
- AM1 = (ECH+PTOCH)*(ECH-PTOCH)
- PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
- & +(PP2(3)+PT2(3))**2)
- ECH = PP2(4)+PT2(4)
- AM2 = (ECH+PTOCH)*(ECH-PTOCH)
- ELSE
-* antibaryon-baryon
- CALL DT_EVTPUT(-21,IFP1,MOP,0,
- & PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
- CALL DT_EVTPUT(-22,IFT2,MOT,0,
- & PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
- CALL DT_EVTPUT(-21,IFP2,MOP,0,
- & PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
- CALL DT_EVTPUT(-22,IFT1,MOT,0,
- & PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
- PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
- & +(PP1(3)+PT2(3))**2)
- ECH = PP1(4)+PT2(4)
- AM1 = (ECH+PTOCH)*(ECH-PTOCH)
- PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
- & +(PP2(3)+PT1(3))**2)
- ECH = PP2(4)+PT1(4)
- AM2 = (ECH+PTOCH)*(ECH-PTOCH)
- ENDIF
- IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
- AM1 = SQRT(AM1)
- AM2 = SQRT(AM2)
- IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
-C WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
- 5007 FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
- ENDIF
- ELSE
- WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
- ENDIF
- NCSY = NCSY+1
- ENDIF
- 80 CONTINUE
- IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
-
-* energy-momentum & flavor conservation check
- IF (ABS(IDIFF).NE.1) THEN
- IF (IDIFF.NE.0) THEN
- IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0,
- & 1,3,10,IREJ)
- ELSE
- IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
- & 1,3,10,IREJ)
- ENDIF
- IF (IREJ.NE.0) THEN
- CALL DT_EVTOUT(4)
- STOP
- ENDIF
- ENDIF
-
- RETURN
-
- 9999 CONTINUE
- IREJ = 1
- RETURN
- END
-*
-*===chkcsy=============================================================*
-*
-CDECK ID>, DT_CHKCSY
- SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
-
-************************************************************************
-* CHeCk Chain SYstem for consistency of partons at chain ends. *
-* ID1,ID2 PDG-numbers of partons at chain ends *
-* LCHK = .true. consistent chain *
-* = .false. inconsistent chain *
-* This version dated 18.01.95 is written by S. Roesler *
-************************************************************************
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( LINP = 5 ,
- & LOUT = 6 ,
- & LDAT = 9 )
-
- LOGICAL LCHK
-
- LCHK = .TRUE.
-
-* q-aq chain
- IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN
- IF (ID1*ID2.GT.0) LCHK = .FALSE.
-* q-qq, aq-aqaq chain
- ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR.
- & ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN
- IF (ID1*ID2.LT.0) LCHK = .FALSE.
-* qq-aqaq chain
- ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
- IF (ID1*ID2.GT.0) LCHK = .FALSE.
- ENDIF
-
- RETURN
- END
-*
-*===eventa=============================================================*
-*
-CDECK ID>, DT_EVENTA
- SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
-
-************************************************************************
-* Treatment of nucleon-nucleon interactions in a two-chain *
-* approximation. *
-* (input) ID BAMJET-index of projectile hadron (in case of *
-* h-K scattering) *
-* IP/IT mass number of projectile/target nucleus *
-* NCSY number of two chain systems *
-* IREJ rejection flag *
-* This version dated 15.01.95 is written by S. Roesler *
-************************************************************************
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( LINP = 5 ,
- & LOUT = 6 ,
- & LDAT = 9 )
-
- PARAMETER (TINY10=1.0D-10)
-
-* event history
-
- PARAMETER (NMXHKK=200000)
-
- COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
- & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
- & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
-* extended event history
- COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
- & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
- & IHIST(2,NMXHKK)
-* rejection counter
- COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
- & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
- & IREXCI(3),IRDIFF(2),IRINC
-* flags for diffractive interactions (DTUNUC 1.x)
- COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
-* particle properties (BAMJET index convention)
- CHARACTER*8 ANAME
- COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
- & IICH(210),IIBAR(210),K1(210),K2(210)
-* flags for input different options
- LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
- COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
- & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
-* various options for treatment of partons (DTUNUC 1.x)
-* (chain recombination, Cronin,..)
- LOGICAL LCO2CR,LINTPT
- COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
- & LCO2CR,LINTPT
-
- DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
-
- IREJ = 0
- NPOINT(3) = NHKK+1
-
-* skip following treatment for low-mass diffraction
- IF (ABS(IFLAGD).EQ.1) THEN
- NPOINT(3) = NPOINT(2)
- GOTO 5
- ENDIF
-
-* multiple scattering of chain ends
- IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
- IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
-
- NC = NPOINT(2)
-* get a two-chain system from DTEVT1
- DO 3 I=1,NCSY
- IFP1 = IDHKK(NC)
- IFT1 = IDHKK(NC+1)
- IFP2 = IDHKK(NC+2)
- IFT2 = IDHKK(NC+3)
- DO 4 K=1,4
- PP1(K) = PHKK(K,NC)
- PT1(K) = PHKK(K,NC+1)
- PP2(K) = PHKK(K,NC+2)
- PT2(K) = PHKK(K,NC+3)
- 4 CONTINUE
- MOP1 = NC
- MOT1 = NC+1
- MOP2 = NC+2
- MOT2 = NC+3
- CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
- & IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
- IF (IREJ1.GT.0) THEN
- IRHHA = IRHHA+1
- IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
- GOTO 9999
- ENDIF
- NC = NC+4
- 3 CONTINUE
-
-* meson/antibaryon projectile:
-* sample single-chain valence-valence systems (Reggeon contrib.)
- IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN
- IF (IIBAR(ID).LE.0) CALL DT_VV2SCH
- ENDIF
-
- IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
-* check DTEVT1 for remaining resonance mass corrections
- CALL DT_EVTRES(IREJ1)
- IF (IREJ1.GT.0) THEN
- IRRES(1) = IRRES(1)+1
- IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA'
- GOTO 9999
- ENDIF
- ENDIF
-
-* assign p_t to two-"chain" systems consisting of two resonances only
-* since only entries for chains will be affected, this is obsolete
-* in case of JETSET-fragmetation
- CALL DT_RESPT
-
-* combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
- IF (LCO2CR) CALL DT_COM2CR
-
- 5 CONTINUE
-
-* fragmentation of the complete event
-**uncomment for internal phojet-fragmentation
-C CALL DT_EVTFRA(IREJ1)
- CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
- IF (IREJ1.GT.0) THEN
- IRFRAG = IRFRAG+1
- IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
- GOTO 9999
- ENDIF
-
-* decay of possible resonances (should be obsolete)
- CALL DT_DECAY1
-
- RETURN
-
- 9999 CONTINUE
- IREVT = IREVT+1
- IREJ = 1
- RETURN
- END
-*
-*===getcsy=============================================================*
-*
-CDECK ID>, DT_GETCSY
- SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
- & IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
-
-************************************************************************
-* This version dated 15.01.95 is written by S. Roesler *
-************************************************************************
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( LINP = 5 ,
- & LOUT = 6 ,
- & LDAT = 9 )
-
- PARAMETER (TINY10=1.0D-10)
-
-* event history
-
- PARAMETER (NMXHKK=200000)
-
- COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
- & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
- & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
-* extended event history
- COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
- & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
- & IHIST(2,NMXHKK)
-* rejection counter
- COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
- & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
- & IREXCI(3),IRDIFF(2),IRINC
-* flags for input different options
- LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
- COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
- & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
-* flags for diffractive interactions (DTUNUC 1.x)
- COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
-
- DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
- & IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
-
- IREJ = 0
-
-* get quark content of partons
- DO 1 I=1,2
- IFP1(I) = 0
- IFP2(I) = 0
- IFT1(I) = 0
- IFT2(I) = 0
- 1 CONTINUE
- IFP1(1) = IDT_IPDG2B(IFPR1,1,2)
- IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2)
- IFP2(1) = IDT_IPDG2B(IFPR2,1,2)
- IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2)
- IFT1(1) = IDT_IPDG2B(IFTA1,1,2)
- IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2)
- IFT2(1) = IDT_IPDG2B(IFTA2,1,2)
- IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2)
-
-* get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
- IDCH1 = 2
- IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1
- IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3
- IDCH2 = 2
- IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1
- IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3
-
-* store initial configuration for energy-momentum cons. check
- IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
-
-* sample intrinsic p_t at chain-ends
- CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2,
- & PT1,IFTA1,IFT1,PT2,IFTA2,IFT2,
- & AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1)
- IF (IREJ1.NE.0) THEN
- IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY'
- IRPT = IRPT+1
- GOTO 9999
- ENDIF
-
-C IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
-C IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
-C* check second chain for resonance
-C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
-C & AMCH2,AMCH2N,IDCH2,IREJ1)
-C IF (IREJ1.NE.0) GOTO 9999
-C IF (IDR2.NE.0) THEN
-C CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
-C & AMCH2,AMCH2N,AMCH1,IREJ1)
-C IF (IREJ1.NE.0) GOTO 9999
-C ENDIF
-C* check first chain for resonance
-C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
-C & AMCH1,AMCH1N,IDCH1,IREJ1)
-C IF (IREJ1.NE.0) GOTO 9999
-C IF (IDR1.NE.0) IDR1 = 100*IDR1
-C ELSE
-C* check first chain for resonance
-C CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
-C & AMCH1,AMCH1N,IDCH1,IREJ1)
-C IF (IREJ1.NE.0) GOTO 9999
-C IF (IDR1.NE.0) THEN
-C CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
-C & AMCH1,AMCH1N,AMCH2,IREJ1)
-C IF (IREJ1.NE.0) GOTO 9999
-C ENDIF
-C* check second chain for resonance
-C CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
-C & AMCH2,AMCH2N,IDCH2,IREJ1)
-C IF (IREJ1.NE.0) GOTO 9999
-C IF (IDR2.NE.0) IDR2 = 100*IDR2
-C ENDIF
-C ENDIF
-
- IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
-* check chains for resonances
- CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
- & AMCH1,AMCH1N,IDCH1,IREJ1)
- IF (IREJ1.NE.0) GOTO 9999
- CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
- & AMCH2,AMCH2N,IDCH2,IREJ1)
- IF (IREJ1.NE.0) GOTO 9999
-* change kinematics corresponding to resonance-masses
- IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN
- CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
- & AMCH1,AMCH1N,AMCH2,IREJ1)
- IF (IREJ1.GT.0) GOTO 9999
- IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
- CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
- & AMCH2,AMCH2N,IDCH2,IREJ1)
- IF (IREJ1.NE.0) GOTO 9999
- IF (IDR2.NE.0) IDR2 = 100*IDR2
- ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN
- CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
- & AMCH2,AMCH2N,AMCH1,IREJ1)
- IF (IREJ1.GT.0) GOTO 9999
- IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
- CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
- & AMCH1,AMCH1N,IDCH1,IREJ1)
- IF (IREJ1.NE.0) GOTO 9999
- IF (IDR1.NE.0) IDR1 = 100*IDR1
- ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN
- AMDIF1 = ABS(AMCH1-AMCH1N)
- AMDIF2 = ABS(AMCH2-AMCH2N)
- IF (AMDIF2.LT.AMDIF1) THEN
- CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
- & AMCH2,AMCH2N,AMCH1,IREJ1)
- IF (IREJ1.GT.0) GOTO 9999
- IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
- CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),
- & IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1)
- IF (IREJ1.NE.0) GOTO 9999
- IF (IDR1.NE.0) IDR1 = 100*IDR1
- ELSE
- CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
- & AMCH1,AMCH1N,AMCH2,IREJ1)
- IF (IREJ1.GT.0) GOTO 9999
- IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
- CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),
- & IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1)
- IF (IREJ1.NE.0) GOTO 9999
- IF (IDR2.NE.0) IDR2 = 100*IDR2
- ENDIF
- ENDIF
- ENDIF
-
-* store final configuration for energy-momentum cons. check
- IF (LEMCCK) THEN
- CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM)
- CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
- IF (IREJ1.NE.0) GOTO 9999
- ENDIF
-
-* put partons and chains into DTEVT1
- DO 10 I=1,4
- PCH1(I) = PP1(I)+PT1(I)
- PCH2(I) = PP2(I)+PT2(I)
- 10 CONTINUE
- CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2),
- & PP1(3),PP1(4),0,0,0)
- CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2),
- & PT1(3),PT1(4),0,0,0)
- KCH = 100+IDCH(MOP1)*10+1
- CALL DT_EVTPUT(KCH,88888,-2,-1,
- & PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1))
- CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2),
- & PP2(3),PP2(4),0,0,0)
- CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2),
- & PT2(3),PT2(4),0,0,0)
- KCH = KCH+1
- CALL DT_EVTPUT(KCH,88888,-2,-1,
- & PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
-
- RETURN
-
- 9999 CONTINUE
- IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN
-* "cancel" sea-sea chains
- CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1)
- IF (IREJ1.NE.0) GOTO 9998
-**sr 16.5. flag for EVENTB
- IREJ = -1
- RETURN
- ENDIF
- 9998 CONTINUE
- IREJ = 1
- RETURN
- END
-*
-*===chkine=============================================================*
-*
-CDECK ID>, DT_CHKINE
- SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
- & AMCH1,AMCH1N,AMCH2,IREJ)
-
-************************************************************************
-* This subroutine replaces CORMOM. *
-* This version dated 05.01.95 is written by S. Roesler *
-************************************************************************
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( LINP = 5 ,
- & LOUT = 6 ,
- & LDAT = 9 )
-
- PARAMETER (TINY10=1.0D-10)
-
-* flags for input different options
- LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
- COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
- & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
-* rejection counter
- COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
- & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
- & IREXCI(3),IRDIFF(2),IRINC
-
- DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
- & PP1I(4),PP2I(4),PT1I(4),PT2I(4)
-
- IREJ = 0
- JMSHL = IMSHL
-
- SCALE = AMCH1N/MAX(AMCH1,TINY10)
- DO 10 I=1,4
- PP1(I) = PP1I(I)
- PP2(I) = PP2I(I)
- PT1(I) = PT1I(I)
- PT2(I) = PT2I(I)
- PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I)
- PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I)
- PP1(I) = SCALE*PP1(I)
- PT1(I) = SCALE*PT1(I)
- 10 CONTINUE
- IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR.
- & (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997
-
- ECH = PP2(4)+PT2(4)
- PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+
- & (PP2(3)+PT2(3))**2 )
- AMCH22 = (ECH-PCH)*(ECH+PCH)
- IF (AMCH22.LT.0.0D0) THEN
- IF (IOULEV(1).GT.0)
- & WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
- GOTO 9997
- ENDIF
-
- AMCH1 = AMCH1N
- AMCH2 = SQRT(AMCH22)
-
-* put partons again on mass shell
- 13 CONTINUE
- XM1 = 0.0D0
- XM2 = 0.0D0
- IF (JMSHL.EQ.1) THEN
-
- XM1 = PYMASS(IFP1)
- XM2 = PYMASS(IFT1)
-
- ENDIF
- CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
- IF (IREJ1.NE.0) THEN
- IF (JMSHL.EQ.0) GOTO 9998
- JMSHL = 0
- GOTO 13
- ENDIF
- JMSHL = IMSHL
- DO 11 I=1,4
- PP1(I) = P1(I)
- PT1(I) = P2(I)
- 11 CONTINUE
- 14 CONTINUE
- XM1 = 0.0D0
- XM2 = 0.0D0
- IF (JMSHL.EQ.1) THEN
-
- XM1 = PYMASS(IFP2)
- XM2 = PYMASS(IFT2)
-
- ENDIF
- CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
- IF (IREJ1.NE.0) THEN
- IF (JMSHL.EQ.0) GOTO 9998
- JMSHL = 0
- GOTO 14
- ENDIF
- DO 12 I=1,4
- PP2(I) = P1(I)
- PT2(I) = P2(I)
- 12 CONTINUE
- DO 15 I=1,4
- PP1I(I) = PP1(I)
- PP2I(I) = PP2(I)
- PT1I(I) = PT1(I)
- PT2I(I) = PT2(I)
- 15 CONTINUE
- RETURN
-
- 9997 IRCHKI(1) = IRCHKI(1)+1
-**sr
-C GOTO 9999
- IREJ = -1
- RETURN
-**
- 9998 IRCHKI(2) = IRCHKI(2)+1
-
- 9999 CONTINUE
- IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
- IREJ = 1
- RETURN
- END
-*
-*===ch2res=============================================================*
-*
-CDECK ID>, DT_CH2RES
- SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
- & AM,AMN,IMODE,IREJ)
-
-************************************************************************
-* Check chains for resonance production. *
-* This subroutine replaces COMCMA/COBCMA/COMCM2 *
-* input: *
-* IF1,2,3,4 input flavors (q,aq in any order) *
-* AM chain mass *
-* MODE = 1 check q-aq chain for meson-resonance *
-* = 2 check q-qq, aq-aqaq chain for baryon-resonance *
-* = 3 check qq-aqaq chain for lower mass cut *
-* output: *
-* IDR = 0 no resonances found *
-* = -1 pseudoscalar meson/octet baryon *
-* = 1 vector-meson/decuplet baryon *
-* IDXR BAMJET-index of corresponding resonance *
-* AMN mass of corresponding resonance *
-* *
-* IREJ rejection flag *
-* This version dated 06.01.95 is written by S. Roesler *
-************************************************************************
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( LINP = 5 ,
- & LOUT = 6 ,
- & LDAT = 9 )
-
-* particle properties (BAMJET index convention)
- CHARACTER*8 ANAME
- COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
- & IICH(210),IIBAR(210),K1(210),K2(210)
-* quark-content to particle index conversion (DTUNUC 1.x)
- COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
- & IA08(6,21),IA10(6,21)
-* rejection counter
- COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
- & IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
- & IREXCI(3),IRDIFF(2),IRINC
-* flags for input different options
- LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
- COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
- & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
-
- DIMENSION IF(4),JF(4)
-
-**sr 4.7. test
-C DATA AMLOM,AMLOB /0.08D0,0.2D0/
- DATA AMLOM,AMLOB /0.1D0,0.7D0/
-**
-C DATA AMLOM,AMLOB /0.001D0,0.001D0/
-
- MODE = ABS(IMODE)
-
- IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN
- WRITE(LOUT,1000) MODE
- 1000 FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/,
- & 1X,' program stopped')
- STOP
- ENDIF
-
- AMX = AM
- IREJ = 0
- IDR = 0
- IDXR = 0
- AMN = AMX
- IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
- IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
-
- IF(1) = IF1
- IF(2) = IF2
- IF(3) = IF3
- IF(4) = IF4
- NF = 0
- DO 100 I=1,4
- IF (IF(I).NE.0) THEN
- NF = NF+1
- JF(NF) = IF(I)
- ENDIF
- 100 CONTINUE
- IF (NF.LE.MODE) THEN
- WRITE(LOUT,1001) MODE,IF
- 1001 FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ',
- & I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4)
- GOTO 9999
- ENDIF
-
- GOTO (1,2,3) MODE
-
-* check for meson resonance
- 1 CONTINUE
- IFQ = JF(1)
- IFAQ = ABS(JF(2))
- IF (JF(2).GT.0) THEN
- IFQ = JF(2)
- IFAQ = ABS(JF(1))
- ENDIF
- IFPS = IMPS(IFAQ,IFQ)
- IFV = IMVE(IFAQ,IFQ)
- AMPS = AAM(IFPS)
- AMV = AAM(IFV)
- AMHI = AMV+0.3D0
- IF (AMX.LT.AMV) THEN
- IF (AMX.LT.AMPS) THEN
- IF (IMODE.GT.0) THEN
- IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999
- ELSE
- IF (AMX.LT.0.8D0*AMPS) GOTO 9999
- ENDIF
- LOMRES = LOMRES+1
- ENDIF
-* replace chain by pseudoscalar meson
- IDR = -1
- IDXR = IFPS
- AMN = AMPS
- ELSEIF (AMX.LT.AMHI) THEN
-* replace chain by vector-meson
- IDR = 1
- IDXR = IFV
- AMN = AMV
- ENDIF
- RETURN
-
-* check for baryon resonance
- 2 CONTINUE
- CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
- AM8 = AAM(JB8)
- AM10 = AAM(JB10)
- AMHI = AM10+0.3D0
- IF (AMX.LT.AM10) THEN
- IF (AMX.LT.AM8) THEN
- IF (IMODE.GT.0) THEN
- IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999
- ELSE
- IF (AMX.LT.0.8D0*AM8) GOTO 9999
- ENDIF
- LOBRES = LOBRES+1
- ENDIF
-* replace chain by oktet baryon
- IDR = -1
- IDXR = JB8
- AMN = AM8
- ELSEIF (AMX.LT.AMHI) THEN
- IDR = 1
- IDXR = JB10
- AMN = AM10
- ENDIF
- RETURN
-
-* check qq-aqaq for lower mass cut
- 3 CONTINUE
-* empirical definition of AMHI to allow for (b-antib)-pair prod.
- AMHI = 2.5D0
- IF (AMX.LT.AMHI) GOTO 9999
- RETURN
-
- 9999 CONTINUE
- IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
- & WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
- IREJ = 1
- IRRES(2) = IRRES(2)+1
- RETURN
- END
-*
-*===rjseac=============================================================*
-*
-CDECK ID>, DT_RJSEAC
- SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
-
-************************************************************************
-* ReJection of SEA-sea Chains. *
-* MOP1/2 entries of projectile sea-partons in DTEVT1 *
-* MOT1/2 entries of projectile sea-partons in DTEVT1 *
-* This version dated 16.01.95 is written by S. Roesler *
-************************************************************************
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( LINP = 5 ,
- & LOUT = 6 ,
- & LDAT = 9 )
-
- PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
-
-* event history
-
- PARAMETER (NMXHKK=200000)
-
- COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
- & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
- & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
-* extended event history
- COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
- & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
- & IHIST(2,NMXHKK)
-* statistics
- COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
- & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
- & ICEVTG(8,0:30)
-
- DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
-
- IREJ = 0
-
-* projectile sea q-aq-pair
-* indices of sea-pair
- IDXSEA(1,1) = MOP1
- IDXSEA(1,2) = MOP2
-* index of mother-nucleon
- IDXNUC(1) = JMOHKK(1,MOP1)
-* status of valence quarks to be corrected
- ISTVAL(1) = -21
-
-* target sea q-aq-pair
-* indices of sea-pair
- IDXSEA(2,1) = MOT1
- IDXSEA(2,2) = MOT2
-* index of mother-nucleon
- IDXNUC(2) = JMOHKK(1,MOT1)
-* status of valence quarks to be corrected
- ISTVAL(2) = -22
-
- DO 1 N=1,2
- IDONE = 0
- DO 2 I=NPOINT(2),NHKK
- IF ((ISTHKK(I).EQ.ISTVAL(N)).AND.
- & (JMOHKK(1,I).EQ.IDXNUC(N))) THEN
-* valence parton found
-* inrease 4-momentum by sea 4-momentum
- DO 3 K=1,4
- PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
- & PHKK(K,IDXSEA(N,2))
- 3 CONTINUE
- PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
- & PHKK(2,I)**2-PHKK(3,I)**2))
-* "cancel" sea-pair
- DO 4 J=1,2
- ISTHKK(IDXSEA(N,J)) = 100
- IDHKK(IDXSEA(N,J)) = 0
- JMOHKK(1,IDXSEA(N,J)) = 0
- JMOHKK(2,IDXSEA(N,J)) = 0
- JDAHKK(1,IDXSEA(N,J)) = 0
- JDAHKK(2,IDXSEA(N,J)) = 0
- DO 5 K=1,4
- PHKK(K,IDXSEA(N,J)) = ZERO
- VHKK(K,IDXSEA(N,J)) = ZERO
- WHKK(K,IDXSEA(N,J)) = ZERO
- 5 CONTINUE
- PHKK(5,IDXSEA(N,J)) = ZERO
- 4 CONTINUE
- IDONE = 1
- ENDIF
- 2 CONTINUE
- IF (IDONE.NE.1) THEN
- WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2
- 1000 FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event',
- & '-record!',/,1X,' sea-quark pairs ',
- & 2I5,4X,2I5,' could not be canceled!')
- GOTO 9999
- ENDIF
- 1 CONTINUE
- ICRJSS = ICRJSS+1
- RETURN
-
- 9999 CONTINUE
- IREJ = 1
- RETURN
- END
-*
-*===vv2sch=============================================================*
-*
-CDECK ID>, DT_VV2SCH
- SUBROUTINE DT_VV2SCH
-
-************************************************************************
-* Change Valence-Valence chain systems to Single CHain systems for *
-* hadron-nucleus collisions with meson or antibaryon projectile. *
-* (Reggeon contribution) *
-* The single chain system is approximately treated as one chain and a *
-* meson at rest. *
-* This version dated 18.01.95 is written by S. Roesler *
-************************************************************************
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- SAVE
-
- PARAMETER ( LINP = 5 ,
- & LOUT = 6 ,
- & LDAT = 9 )
-
- PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
-
- LOGICAL LSTART
-
-* event history
-
- PARAMETER (NMXHKK=200000)
-
- COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
- & JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
- & PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
-* extended event history
- COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
- & IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
- & IHIST(2,NMXHKK)
-* flags for input different options
- LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
- COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
- & LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
-* statistics
- COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
- & ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
- & ICEVTG(8,0:30)
-
- DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
- & PCH2(4)
-
- DATA LSTART /.TRUE./
-
- IFSC = 0
- IF (LSTART) THEN
- WRITE(LOUT,1000)
- 1000 FORMAT(/,1X,'VV2SCH: Reggeon contribution to valance-',
- & 'valence chains treated')
- LSTART = .FALSE.
- ENDIF
-
- NSTOP = NHKK
-
-* get index of first chain
- DO 1 I=NPOINT(3),NHKK
- IF (IDHKK(I).EQ.88888) THEN
- NC = I
- GOTO 2
- ENDIF
- 1 CONTINUE
-
- 2 CONTINUE
- IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)
- & .AND.(NC.LT.NSTOP)) THEN
-* get valence-valence chains
- IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN
-* get "mother"-hadron indices
- MO1 = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC)))
- MO2 = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC)))
- KPROJ = IDT_ICIHAD(IDHKK(MO1))
- KTARG = IDT_ICIHAD(IDHKK(MO2))
-* Lab momentum of projectile hadron
- CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3)
- PTOT = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+
- & PHKK(3,MO1)**2)
-
- SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
- IF (DT_RNDM(PTOT).LE.SICHAP) THEN
- ICVV2S = ICVV2S+1
-* single chain requested
-* get flavors of chain-end partons
- MO(1) = JMOHKK(1,NC)
- MO(2) = JMOHKK(2,NC)
- MO(3) = JMOHKK(1,NC+3)
- MO(4) = JMOHKK(2,NC+3)
- DO 3 I=1,4
- IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
- IF(I,2) = 0
- IF (ABS(IDHKK(MO(I))).GE.1000)
- & IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
- 3 CONTINUE
-* which one is the q-aq chain?
-* N1,N1+1 - DTEVT1-entries for q-aq system
-* N2,N2+1 - DTEVT1-entries for the other chain
- IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN
- K1 = 1
- K2 = 3
- N1 = NC-2
- N2 = NC+1
- ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
- K1 = 3
- K2 = 1
- N1 = NC+1
- N2 = NC-2
- ELSE
- GOTO 10
- ENDIF
- DO 4 K=1,4
git://git.uio.no / u/mrichter/AliRoot.git / commitdiff